forked from alex-eg/sex
Compare commits
6 Commits
feature/pr
...
sdl-exampl
| Author | SHA1 | Date | |
|---|---|---|---|
| c709c69176 | |||
| 1e435f7fdf | |||
| c976378363 | |||
| 5af2e99f5f | |||
| bb1614a123 | |||
| c1fbb02c50 |
@@ -1,65 +0,0 @@
|
||||
name: Sex CI
|
||||
|
||||
on:
|
||||
push:
|
||||
branches: [main]
|
||||
pull_request:
|
||||
branches: [main]
|
||||
workflow_dispatch:
|
||||
|
||||
jobs:
|
||||
build-linux:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- name: Fetch repository
|
||||
env:
|
||||
GITEA_TOKEN: ${{ secrets.GITEA_TOKEN }}
|
||||
run: |
|
||||
set -eu
|
||||
git config --global --add safe.directory "$PWD"
|
||||
git init
|
||||
git remote add origin "${GITHUB_SERVER_URL%/}/${GITHUB_REPOSITORY}.git"
|
||||
git -c http.extraHeader="Authorization: token ${GITEA_TOKEN}" \
|
||||
fetch --depth 1 origin "${GITHUB_SHA}"
|
||||
git checkout --force FETCH_HEAD
|
||||
|
||||
- name: Install toolchain
|
||||
run: |
|
||||
set -eu
|
||||
if [ "$(id -u)" -eq 0 ]; then
|
||||
apt-get update
|
||||
apt-get install -y --no-install-recommends build-essential git wget ca-certificates
|
||||
else
|
||||
sudo apt-get update
|
||||
sudo apt-get install -y --no-install-recommends build-essential git wget ca-certificates
|
||||
fi
|
||||
|
||||
- name: Install Chicken
|
||||
env:
|
||||
CHICKEN_VERSION: "6.0.0"
|
||||
CHICKEN_SHA256: 92835552b1b687ad26737e429b5aba36510bf429f8816ec0f6d336c8cb41f443
|
||||
run: |
|
||||
set -eu
|
||||
tarball="chicken-${CHICKEN_VERSION}.tar.gz"
|
||||
wget -N "https://code.call-cc.org/releases/${CHICKEN_VERSION}/${tarball}"
|
||||
echo "${CHICKEN_SHA256} ${tarball}" | sha256sum -c
|
||||
tar zxf "${tarball}"
|
||||
(
|
||||
cd "chicken-${CHICKEN_VERSION}"
|
||||
./configure --prefix=/usr/local
|
||||
make -j"$(nproc)"
|
||||
if [ "$(id -u)" -eq 0 ]; then
|
||||
make install
|
||||
else
|
||||
sudo make install
|
||||
fi
|
||||
)
|
||||
hash -r
|
||||
csc -version
|
||||
|
||||
# Eggs are pinned in eggs.lock and installed by the Makefile into .eggs/.
|
||||
- name: Build sexc
|
||||
run: make && ./sexc --help
|
||||
|
||||
- name: Run tests
|
||||
run: make check
|
||||
55
.github/workflows/build.yaml
vendored
Normal file
55
.github/workflows/build.yaml
vendored
Normal file
@@ -0,0 +1,55 @@
|
||||
name: Sex CI
|
||||
|
||||
on:
|
||||
push:
|
||||
branches: [ main ]
|
||||
pull_request:
|
||||
branches: [ main ]
|
||||
|
||||
jobs:
|
||||
build-linux:
|
||||
|
||||
runs-on: ubuntu-latest
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v3
|
||||
- name: Install chicken
|
||||
run: |
|
||||
wget -N https://code.call-cc.org/releases/6.0.0/chicken-6.0.0.tar.gz
|
||||
tar zxf chicken-6.0.0.tar.gz
|
||||
sudo apt install -y make
|
||||
make -C chicken-6.0.0 PLATFORM=linux
|
||||
sudo make -C chicken-6.0.0 PLATFORM=linux install
|
||||
- name: Install dependencies
|
||||
# FIXME: [project-local deps]: use venv or something
|
||||
# run: make deps
|
||||
run: sudo chicken-install $(cat dependencies.txt)
|
||||
- name: Make sure that sexc builds
|
||||
# FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
|
||||
# Without it there will be `Error: cannot load extension: fmt`.
|
||||
run: make sexc && ./sexc --help
|
||||
- name: Run tests
|
||||
# FIXME: [project-local deps]: use local deps or build with -static
|
||||
# run: make run-tests
|
||||
run: make sex-tests && ./sex-tests
|
||||
|
||||
build-macos:
|
||||
|
||||
runs-on: macos-15
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v3
|
||||
- name: Install chicken
|
||||
run: brew install chicken make
|
||||
- name: Install dependencies
|
||||
# FIXME: [project-local deps]: use venv or something
|
||||
# run: make deps
|
||||
run: chicken-install $(cat dependencies.txt)
|
||||
- name: Make sure that sexc builds
|
||||
# FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
|
||||
# Without it there will be `Error: cannot load extension: fmt`.
|
||||
run: make sexc && ./sexc --help
|
||||
- name: Run tests
|
||||
# FIXME: [project-local deps]: use local deps or build with -static
|
||||
# run: make run-tests
|
||||
run: make sex-tests && ./sex-tests
|
||||
6
.gitignore
vendored
6
.gitignore
vendored
@@ -1,11 +1,5 @@
|
||||
# Project-local Chicken egg repository
|
||||
/.eggs
|
||||
|
||||
# Compilation artifacts
|
||||
*.o
|
||||
*.import.scm
|
||||
*.link
|
||||
sexc
|
||||
sex-tests
|
||||
sextest
|
||||
tools/sextest/sextest
|
||||
|
||||
86
Makefile
86
Makefile
@@ -1,6 +1,4 @@
|
||||
CHICKEN_C ?= csc
|
||||
CHICKEN_INSTALL ?= chicken-install
|
||||
CHICKEN_STATUS ?= chicken-status
|
||||
CHICKEN_C = csc
|
||||
CSC_FLAGS += -K prefix -static
|
||||
# What and why:
|
||||
# -emit-all-import-libraries: Emit import-libraries for all defined modules.
|
||||
@@ -14,44 +12,17 @@ CSC_FLAGS += -K prefix -static
|
||||
# error.
|
||||
# -c: Stop after compilation to object files. This one is obvious.
|
||||
|
||||
# GNU directory variables. Command line overrides, e.g.
|
||||
# make prefix=$(HOME)/.local install
|
||||
# make DESTDIR=/tmp/stage prefix=/usr install
|
||||
prefix = /usr/local
|
||||
exec_prefix = $(prefix)
|
||||
bindir = $(exec_prefix)/bin
|
||||
INSTALL = install
|
||||
INSTALL_PROGRAM = $(INSTALL)
|
||||
|
||||
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
|
||||
|
||||
# Order matters, since module check correctness on compilation
|
||||
MODULES = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
|
||||
OBJ = $(MODULES:%=%.o)
|
||||
|
||||
DEPSFILE = dependencies.txt
|
||||
DEPSLOCK = eggs.lock
|
||||
EGGS_DIR := $(abspath .eggs)
|
||||
|
||||
# Compiler's own repository (types.db, chicken.*), ignoring ambient venv vars.
|
||||
SYSTEM_CHICKEN_REPO := $(shell env -u CHICKEN_INSTALL_REPOSITORY -u CHICKEN_REPOSITORY_PATH -u CHICKEN_EGG_CACHE -u CHICKEN_INSTALL_PREFIX $(CHICKEN_INSTALL) -repository 2>/dev/null)
|
||||
CHICKEN_ABI := $(notdir $(SYSTEM_CHICKEN_REPO))
|
||||
EGGS_STAMP := $(EGGS_DIR)/.installed-$(CHICKEN_ABI)
|
||||
|
||||
export CHICKEN_EGG_CACHE := $(EGGS_DIR)/cache
|
||||
export CHICKEN_INSTALL_REPOSITORY := $(EGGS_DIR)
|
||||
export CHICKEN_INSTALL_PREFIX := $(EGGS_DIR)
|
||||
export CHICKEN_REPOSITORY_PATH := $(EGGS_DIR):$(SYSTEM_CHICKEN_REPO)
|
||||
|
||||
all: sexc
|
||||
|
||||
sexc: $(EGGS_STAMP) $(OBJ) main.scm
|
||||
sexc: $(OBJ) main.scm
|
||||
$(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc
|
||||
# otherwise csc hangs, probably because it tries to compile to sexc.o first
|
||||
mv sexc-tmp sexc
|
||||
|
||||
$(OBJ): $(EGGS_STAMP)
|
||||
|
||||
#------------------------------------------------------------------
|
||||
|
||||
utils.o: utils.module.scm utils.scm
|
||||
@@ -82,69 +53,28 @@ sexc.o: sexc.module.scm types.o sexc.scm fmt-c-writer.o sex-macros.o sex-modules
|
||||
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,types,utils
|
||||
|
||||
# Unit testing
|
||||
sex-tests: $(EGGS_STAMP)
|
||||
sex-tests:
|
||||
$(MAKE) -C ./tests sex-tests
|
||||
cp ./tests/sex-tests ./
|
||||
|
||||
sextest: $(EGGS_STAMP)
|
||||
sextest:
|
||||
$(MAKE) -C ./tools/sextest sextest
|
||||
cp ./tools/sextest/sextest .
|
||||
|
||||
SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features
|
||||
SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize
|
||||
|
||||
# Multi-module linking is checked end to end; see tests/modules/Makefile.
|
||||
check-modules: sexc
|
||||
@$(MAKE) --no-print-directory -C ./tests/modules check SEXC=../../sexc
|
||||
|
||||
# The failure paths are checked end to end; see tests/exit-code/Makefile.
|
||||
check-exit-code: sexc
|
||||
@$(MAKE) --no-print-directory -C ./tests/exit-code check SEXC=../../sexc
|
||||
|
||||
check run-tests: sexc sex-tests sextest
|
||||
./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules && $(MAKE) check-exit-code
|
||||
|
||||
install: all installdirs
|
||||
$(INSTALL_PROGRAM) sexc $(DESTDIR)$(bindir)/sexc
|
||||
|
||||
install-strip:
|
||||
$(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
|
||||
|
||||
installdirs:
|
||||
$(INSTALL) -d $(DESTDIR)$(bindir)
|
||||
|
||||
uninstall:
|
||||
rm -f $(DESTDIR)$(bindir)/sexc
|
||||
|
||||
# eggs.lock is the pin file (chicken-status -list). Install from it;
|
||||
# do not float versions on a normal build. Regenerating the lock:
|
||||
# make deps-update
|
||||
$(EGGS_STAMP): $(DEPSLOCK)
|
||||
mkdir -p $(CHICKEN_EGG_CACHE)
|
||||
$(CHICKEN_INSTALL) -force -from-list $(DEPSLOCK)
|
||||
touch $@
|
||||
|
||||
deps: $(EGGS_STAMP)
|
||||
|
||||
deps-update: $(DEPSFILE)
|
||||
rm -rf $(EGGS_DIR)
|
||||
mkdir -p $(CHICKEN_EGG_CACHE)
|
||||
$(CHICKEN_INSTALL) -force $$(cat $(DEPSFILE))
|
||||
CHICKEN_REPOSITORY_PATH=$(EGGS_DIR) $(CHICKEN_STATUS) -list | sort > $(DEPSLOCK).tmp
|
||||
mv $(DEPSLOCK).tmp $(DEPSLOCK)
|
||||
touch $(EGGS_STAMP)
|
||||
run-tests: sexc sex-tests sextest
|
||||
./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules
|
||||
|
||||
clean:
|
||||
rm -f $(OBJ) main.o
|
||||
rm -f *.import.scm
|
||||
rm -f *.link
|
||||
rm -f sexc sex-tests sextest
|
||||
$(MAKE) -C ./tests clean
|
||||
$(MAKE) -C ./tests/modules clean
|
||||
$(MAKE) -C ./tools/sextest clean
|
||||
|
||||
deps-clean:
|
||||
rm -rf $(EGGS_DIR)
|
||||
|
||||
.PHONY: all check run-tests check-modules check-exit-code \
|
||||
install install-strip installdirs uninstall \
|
||||
deps deps-update deps-clean clean sex-tests sextest
|
||||
.PHONY: clean run-tests sex-tests sextest check-modules
|
||||
|
||||
91
Readme.org
91
Readme.org
@@ -12,46 +12,16 @@ Sex is statically typed, compiled general purpose language.
|
||||
First, get yourself a Chicken, then, some Chicken deps. You also will
|
||||
need a C compiler.
|
||||
|
||||
Eggs are installed into a project-local ~.eggs/~ repository; they do not
|
||||
touch the Chicken system repository.
|
||||
** Install Chicken Eggs
|
||||
Tip: there's a way to make Chicken install eggs non-globally. You need
|
||||
to export ~CHICKEN_INSTALL_REPOSITORY~ and ~CHICKEN_REPOSITORY_PATH~
|
||||
environment variables. Refer to the documentation for more info:
|
||||
https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
|
||||
|
||||
~chicken-install `cat dependencies.txt`~
|
||||
|
||||
** Compilation
|
||||
#+begin_src sh
|
||||
make
|
||||
#+end_src
|
||||
|
||||
That installs pinned eggs from ~eggs.lock~ into ~.eggs/~ if needed, then
|
||||
builds ~sexc~. ~dependencies.txt~ is the unpinned request list. To
|
||||
refresh ~eggs.lock~ after changing it:
|
||||
|
||||
#+begin_src sh
|
||||
make deps-update
|
||||
#+end_src
|
||||
|
||||
** Static compilation
|
||||
The default ~CSC_FLAGS~ include ~-static~, so ~sexc~ does not need
|
||||
~.eggs~ at runtime and ~make install~ stays relocatable. Chicken must
|
||||
provide ~libchicken.a~ (E.g. for gentoo: ~dev-scheme/chicken~ with
|
||||
~static-libs~ use flag).
|
||||
|
||||
To link dynamically instead (the binary will look for eggs under this
|
||||
tree's ~.eggs~ path):
|
||||
|
||||
#+begin_src sh
|
||||
make CSC_FLAGS='-K prefix'
|
||||
#+end_src
|
||||
|
||||
** Installation
|
||||
GNU directory variables: ~prefix~, ~exec_prefix~, ~bindir~, ~DESTDIR~.
|
||||
|
||||
#+begin_src sh
|
||||
# default installation (/usr/local/bin/)
|
||||
make install
|
||||
# customize the prefix (installs to ~/.local/bin)
|
||||
make prefix=$(HOME)/.local install
|
||||
# staged install for packaging
|
||||
make DESTDIR=/tmp/stage prefix=/usr install
|
||||
#+end_src
|
||||
~make~
|
||||
|
||||
* Usage
|
||||
** Summary
|
||||
@@ -61,21 +31,13 @@ Options:
|
||||
--c-compiler=ARG Select C compiler. Defaults to value of SEX_CC
|
||||
environment variable, or if it is empty, to cc
|
||||
-c, --compile-object Compile object file instead of executable program
|
||||
-f, --features=ARG Comma-separated feature names, added to the host's own
|
||||
for #+ and #- feature expressions. May be given
|
||||
more than once
|
||||
--no-platform-features Leave out the host's own features. With --features,
|
||||
this reads a file the way another platform would
|
||||
-C, --emit-c Emit C code
|
||||
-C, --preprocess Emit C code
|
||||
--public-interface Get module's public interface
|
||||
-h, --help Show this help
|
||||
-m, --macro-expand Emit macro-expanded semantically processed Sex code
|
||||
(sort of IR). May be useful for debugging
|
||||
-o, --output=ARG Write output to file. Default file name is a.out.
|
||||
If -E or -m options are provided, defaults to stdout
|
||||
--line-directives=ARG How much #line information to emit: statement (default),
|
||||
toplevel, or none. `statement' is what makes a debugger
|
||||
land on the right source line; `none' is for reading -C
|
||||
output by eye
|
||||
#+end_src
|
||||
** Compiling Hello World
|
||||
#+begin_src shell
|
||||
@@ -139,39 +101,6 @@ Module's public interface consists of everything declared
|
||||
~pub~. Structures, function, macros, types, variables can be
|
||||
public.
|
||||
|
||||
** Read-time feature expressions
|
||||
Sex is able to use ~#+~ and ~#-~ for conditional compilation: the form that
|
||||
follows is kept only when the feature expression is true, and otherwise
|
||||
is read and thrown away.
|
||||
|
||||
#+begin_src scheme
|
||||
#+macosx (include OpenGL/gl3.h)
|
||||
#-macosx (include GL/gl.h)
|
||||
|
||||
#+(and unix (not macosx)) (define HAVE-EPOLL 1)
|
||||
#+end_src
|
||||
|
||||
An expression is a feature name, or ~and~, ~or~ and ~not~ of them.
|
||||
|
||||
This is read time, not compile time. What does not apply never reaches macro
|
||||
expansion, the type database or the generated C.
|
||||
|
||||
The features are the host's ~(software-version)~, ~(software-type)~
|
||||
and ~(machine-type)~, e.g. ~macosx unix arm64~ or ~linux unix
|
||||
x86-64~. ~--features~ adds to them:
|
||||
|
||||
#+begin_src shell
|
||||
sexc prog.sex -f debug,with-sdl
|
||||
sexc prog.sex --features=debug --features=with-sdl
|
||||
#+end_src
|
||||
|
||||
A feature is never taken away. The host's features can be disabled,
|
||||
e.g. for checking output for other platform:
|
||||
|
||||
#+begin_src shell
|
||||
sexc example/sdl3-triangle.sex -C --no-platform-features --features=linux,unix,x86-64
|
||||
#+end_src
|
||||
|
||||
** Syntactic macros
|
||||
Sex has support for syntactic macros. Macro definitions look like
|
||||
functions: they have a name, an argument list and a body. Macro should
|
||||
|
||||
@@ -1,8 +0,0 @@
|
||||
(brev-separate "1.100")
|
||||
(fmt "0.8.14")
|
||||
(getopt-long "4.0")
|
||||
(matchable "1.2")
|
||||
(srfi-1 "0.5.1")
|
||||
(srfi-13 "0.3.8")
|
||||
(srfi-69 "0.5.3")
|
||||
(test "1.3")
|
||||
@@ -8,29 +8,13 @@
|
||||
;;; triangle is and how far it has spun are passed in as uniforms, so
|
||||
;;; the geometry itself is uploaded once and never touched again.
|
||||
;;;
|
||||
;;; Build, macOS:
|
||||
;;; Build:
|
||||
;;; ./sexc example/sdl3-triangle.sex -o sdl3-triangle -- `pkg-config --cflags --libs sdl3` -framework OpenGL
|
||||
;;;
|
||||
;;; Build, Linux:
|
||||
;;; ./sexc example/sdl3-triangle.sex -o sdl3-triangle -- `pkg-config --cflags --libs sdl3 gl`
|
||||
;;;
|
||||
;;; The GL header is the one platform difference, and #+ / #- picks it.
|
||||
;;; Apple keeps the core-profile entry points in <OpenGL/gl3.h> and
|
||||
;;; links them through -framework OpenGL, which no pkg-config file
|
||||
;;; describes; everywhere else the prototypes come from <GL/glext.h>
|
||||
;;; with GL_GLEXT_PROTOTYPES defined, and -lGL -- `pkg-config --libs
|
||||
;;; gl' -- resolves them. SDL3/SDL_opengl.h is not the shortcut it
|
||||
;;; looks like: on Apple it resolves to the 2.1 header, which has no
|
||||
;;; glGenVertexArrays and so cannot bind the VAO this program needs.
|
||||
|
||||
#+macosx (define GL-SILENCE-DEPRECATION 1) ; OpenGL is deprecated on macOS
|
||||
(define GL-SILENCE-DEPRECATION 1) ; OpenGL is deprecated on macOS
|
||||
|
||||
(include SDL3/SDL.h)
|
||||
|
||||
#+macosx (include OpenGL/gl3.h)
|
||||
#-macosx (define GL-GLEXT-PROTOTYPES 1)
|
||||
#-macosx (include GL/gl.h)
|
||||
#-macosx (include GL/glext.h)
|
||||
(include OpenGL/gl3.h)
|
||||
|
||||
(define WINDOW-WIDTH 800)
|
||||
(define WINDOW-HEIGHT 600)
|
||||
|
||||
@@ -382,17 +382,10 @@ forms, and what remains."
|
||||
|
||||
(define (walk-enum form)
|
||||
(match form
|
||||
;; Naming one without defining it: `(var m (enum mood))', the same
|
||||
;; shape walk-struct accepts for `(struct foo)'. Guarded, and
|
||||
;; before the anonymous case, since `(enum (red green))' is also a
|
||||
;; two-element form
|
||||
(('enum (? symbol? name))
|
||||
`(enum ,(atom-to-fmt-c name)))
|
||||
(('enum (values ...))
|
||||
`(enum ,(map atom-to-fmt-c values)))
|
||||
(('enum name (values ...))
|
||||
`(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))
|
||||
(else (sex-error form "malformed enum" form))))
|
||||
`(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
|
||||
|
||||
(define (walk-extern form)
|
||||
(match form
|
||||
@@ -417,7 +410,6 @@ forms, and what remains."
|
||||
|
||||
('struct . _)
|
||||
('union . _)
|
||||
('enum . _)
|
||||
|
||||
('typedef . _))
|
||||
;; ignore here, used in generating public interface
|
||||
@@ -431,10 +423,7 @@ forms, and what remains."
|
||||
(('fn . _) (list 'static (walk-function form)))
|
||||
(('var . _) (list 'static (walk-var form)))
|
||||
(('extern . rest) (walk-extern rest))
|
||||
;; The cdr of a form has no location of its own, so hand it the
|
||||
;; `pub' form's -- otherwise a complaint about what follows `pub'
|
||||
;; cannot say where it was written
|
||||
(('pub . rest) (walk-public (copy-form-source! form rest)))
|
||||
(('pub . rest) (walk-public rest))
|
||||
((or ('struct . _)
|
||||
('union . _)) (walk-struct form))
|
||||
(('enum . _) (walk-enum form))
|
||||
|
||||
@@ -1,6 +1,3 @@
|
||||
(module reader (read-from-file
|
||||
read-raw-forms
|
||||
|
||||
current-features
|
||||
platform-features)
|
||||
read-raw-forms)
|
||||
"reader.scm")
|
||||
|
||||
45
reader.scm
45
reader.scm
@@ -7,8 +7,6 @@
|
||||
;;; - a leading `.' rewritten to the symbol `dot-access'
|
||||
;;; - `;' comments preserved as (comment "...") forms, so they can be
|
||||
;;; re-emitted into the generated C (keeping the source mapping)
|
||||
;;; - #+ / #- feature expressions, which decide at read time what the
|
||||
;;; compiler gets to see at all
|
||||
;;; It also records the source location of every form it reads (see
|
||||
;;; utils' form-source), so the C writer can emit #line directives.
|
||||
|
||||
@@ -17,8 +15,6 @@
|
||||
(scheme base) ; make-parameter
|
||||
(chicken base)
|
||||
(chicken pathname)
|
||||
(chicken platform) ; software-version, machine-type
|
||||
(only srfi-1 every any) ; srfi-1 also has an append-reverse
|
||||
utils)
|
||||
|
||||
;;; Sentinels for structural tokens
|
||||
@@ -164,8 +160,7 @@
|
||||
((string->number s) => identity)
|
||||
(else (string->symbol s))))
|
||||
|
||||
;;; #-dispatch: booleans, characters, vectors, block/datum comments,
|
||||
;;; feature expressions
|
||||
;;; #-dispatch: booleans, characters, vectors, block/datum comments
|
||||
(define (read-hash port)
|
||||
(let ((c (get-ch port)))
|
||||
(cond
|
||||
@@ -176,46 +171,8 @@
|
||||
((char=? c #\() (list->vector (read-list port close-paren)))
|
||||
((char=? c #\|) (skip-block-comment port 1) (next-token port))
|
||||
((char=? c #\;) (read-datum port) (next-token port)) ; datum comment
|
||||
((char=? c #\+) (read-conditional port #t))
|
||||
((char=? c #\-) (read-conditional port #f))
|
||||
(else (error "Unsupported # syntax" c)))))
|
||||
|
||||
;;; Feature expressions
|
||||
;;;
|
||||
;;; #+linux (include GL/gl.h) kept on Linux
|
||||
;;; #-macosx (foo) kept only on other than macOS
|
||||
;;; #+(and unix (not macosx)) (bar) and / or / not combine them
|
||||
;;;
|
||||
(define (platform-features)
|
||||
(list (software-version) (software-type) (machine-type)))
|
||||
|
||||
;;; The host's features are the default, so anything reading Sex sees
|
||||
;;; what the compiler would. sexc rebinds this to add --features
|
||||
(define current-features (make-parameter (platform-features)))
|
||||
|
||||
(define (feature-true? test)
|
||||
(cond
|
||||
((symbol? test) (and (memq test (current-features)) #t))
|
||||
((pair? test)
|
||||
(case (car test)
|
||||
((and) (every feature-true? (cdr test)))
|
||||
((or) (any feature-true? (cdr test)))
|
||||
((not)
|
||||
(if (and (pair? (cdr test)) (null? (cddr test)))
|
||||
(not (feature-true? (cadr test)))
|
||||
(error "Feature expression `not' takes exactly one operand" test)))
|
||||
(else (error "Unknown operator in feature expression" (car test)))))
|
||||
(else (error "Malformed feature expression" test))))
|
||||
|
||||
;;; The #-/#+ preceded datum is always read -- there is no other way
|
||||
;;; to know where it ends -- and then either returned or dropped
|
||||
(define (read-conditional port keep-when)
|
||||
(let ((keep (eq? keep-when (feature-true? (read-datum port)))))
|
||||
(if keep
|
||||
(read-datum port)
|
||||
(begin (read-datum port)
|
||||
(next-token port)))))
|
||||
|
||||
;;; #t / #true / #f / #false. `val' is the boolean; consume any
|
||||
;;; trailing name characters and validate
|
||||
(define (read-bool port val)
|
||||
|
||||
14
semen.scm
14
semen.scm
@@ -93,9 +93,17 @@
|
||||
(else (sex-error sex-form "unknown top level form" sex-form))))
|
||||
|
||||
(define (process-imports module-public-forms acc)
|
||||
;; consume (import ...) form and process imports so
|
||||
;; data types end up in types db
|
||||
(fold match-sex-form acc module-public-forms))
|
||||
;; Recursively process imports: register public macros, cons all
|
||||
;; other public things to our acc
|
||||
(if (null? module-public-forms) acc
|
||||
(match (car module-public-forms)
|
||||
(('defmacro . rest)
|
||||
(defmacro rest)
|
||||
(process-imports (cdr module-public-forms) acc))
|
||||
(else
|
||||
(process-imports (cdr module-public-forms)
|
||||
(cons (car module-public-forms)
|
||||
acc))))))
|
||||
|
||||
(define (macro-expand form)
|
||||
"Walk the form recursively and expand all macros, until none is left."
|
||||
|
||||
@@ -640,22 +640,16 @@
|
||||
(define (c-union . args) (apply c-struct/aux "union" args))
|
||||
(define (c-class . args) (apply c-struct/aux "class" args))
|
||||
|
||||
;; MODIFIED FROM UPSTREAM fmt-c: an enum may also be named without
|
||||
;; being defined -- `enum color m;' -- exactly as c-struct/aux
|
||||
;; already allows `struct point p;'. Upstream assumed a value list
|
||||
;; was always present and mapped over whatever stood in its place.
|
||||
(define (c-enum x . o)
|
||||
(define (c-enum-one x)
|
||||
(if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x)))
|
||||
(let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
|
||||
(vals (if name (if (null? o) #f (car o)) x)))
|
||||
(if vals
|
||||
(c-wrap-stmt
|
||||
(cat
|
||||
(c-braced-block
|
||||
(if name (cat "enum " name) (dsp "enum"))
|
||||
(c-in-expr (apply c-begin (map c-enum-one vals))))))
|
||||
(c-wrap-stmt (cat "enum " name)))))
|
||||
(vals (if name (car o) x)))
|
||||
(c-wrap-stmt
|
||||
(cat
|
||||
(c-braced-block
|
||||
(if name (cat "enum " name) (dsp "enum"))
|
||||
(c-in-expr (apply c-begin (map c-enum-one vals))))))))
|
||||
|
||||
(define (c-attribute . args)
|
||||
(cat "__attribute__ ((" (fmt-join c-expr args ", ") "))"))
|
||||
@@ -749,13 +743,7 @@
|
||||
(if (and (pair? (cadr type)) (eq? '%array (caadr type)))
|
||||
(c-paren name)
|
||||
name))))
|
||||
;; MODIFIED FROM UPSTREAM fmt-c: upstream passed the
|
||||
;; declarator's name to c-enum as the enum's tag, so
|
||||
;; `(var m (enum color))' emitted `enum m {...}' and lost the
|
||||
;; variable. Enums are laid out like structs: the type, then
|
||||
;; the name being declared.
|
||||
((enum)
|
||||
(cat (apply c-enum (cdr type)) (if name (cat " " name) "")))
|
||||
((enum) (apply c-enum name (cdr type)))
|
||||
((struct union class)
|
||||
(cat (apply c-struct/aux (car type) (cdr type)) (if name (cat " " name) "")))
|
||||
(else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
|
||||
|
||||
@@ -14,10 +14,6 @@
|
||||
|
||||
(define +persistent-module-paths+ (list))
|
||||
|
||||
;;; for guarding against multiple imports (sort of mandatory #pragma
|
||||
;;; once)
|
||||
(define +imported-modules+ (list))
|
||||
|
||||
(define (get-modules-public-forms module-list)
|
||||
;; Module list is a list of symbols
|
||||
;; How Sex handles modules:
|
||||
@@ -33,11 +29,7 @@
|
||||
(let ((module-path (locate-module name)))
|
||||
(assert module-path (fmt #f "Failed to find module " name " in "
|
||||
(get-module-paths)))
|
||||
(if (member module-path +imported-modules+)
|
||||
(list)
|
||||
(begin
|
||||
(set! +imported-modules+ (cons module-path +imported-modules+))
|
||||
(read-public-interface module-path)))))
|
||||
(read-public-interface module-path)))
|
||||
|
||||
(define (get-module-paths)
|
||||
(cons (current-directory)
|
||||
@@ -83,7 +75,7 @@
|
||||
;; A variable becomes an `extern' declaration
|
||||
((var)
|
||||
(cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc))
|
||||
((define defmacro enum import include struct typedef union)
|
||||
((define defmacro import include struct typedef union)
|
||||
(cons (copy-form-source! form (cdr form)) acc))
|
||||
(else (sex-error form "pub must be followed by a definition" form))))
|
||||
(else acc)))
|
||||
|
||||
55
sexc.scm
55
sexc.scm
@@ -2,14 +2,12 @@
|
||||
(scheme base) ; call/cc
|
||||
brev-separate
|
||||
(chicken base)
|
||||
(chicken condition) ; handle-exceptions
|
||||
(chicken file)
|
||||
(chicken plist)
|
||||
(chicken pretty-print)
|
||||
(chicken process)
|
||||
(chicken process-context)
|
||||
(chicken port)
|
||||
(chicken string) ; string-split
|
||||
fmt
|
||||
fmt-c-writer
|
||||
getopt-long
|
||||
@@ -32,17 +30,6 @@
|
||||
(required #f)
|
||||
(value #f)
|
||||
(single-char #\c))
|
||||
(features ,(fmt #f "Comma-separated feature names, added to the host's own" nl
|
||||
(pad padding) "for #+ and #- feature expressions. May be given" nl
|
||||
(pad padding) "more than once")
|
||||
(required #f)
|
||||
(value #t)
|
||||
(single-char #\f))
|
||||
(no-platform-features
|
||||
,(fmt #f "Leave out the host's own features. With --features," nl
|
||||
(pad padding) "this reads a file the way another platform would")
|
||||
(required #f)
|
||||
(value #f))
|
||||
(emit-c "Emit C code"
|
||||
(required #f)
|
||||
(value #f)
|
||||
@@ -110,15 +97,6 @@
|
||||
((equal? v "none") 'none)
|
||||
(else (error "--line-directives must be statement, toplevel or none, got" v)))))
|
||||
|
||||
|
||||
|
||||
;;; --features may be given more than once, and each may name several.
|
||||
;;; Collect all of them
|
||||
(define (cli-features args)
|
||||
(append-map (lambda (entry)
|
||||
(map string->symbol (string-split (cdr entry) ",")))
|
||||
(filter (lambda (entry) (eq? (car entry) 'features)) args)))
|
||||
|
||||
(define (get-input-file args)
|
||||
(let ((rest-args (get-rest-args args)))
|
||||
(if (null? rest-args)
|
||||
@@ -139,22 +117,15 @@
|
||||
(emit-c sex-forms)))))
|
||||
|
||||
(define (compile-to-file sex-forms output args cc-args)
|
||||
"Hand the generated C to the C compiler. Returns the compiler's exit
|
||||
status, which is ours to pass on."
|
||||
(let ((compiler (or (get-arg args 'c-compiler #f)
|
||||
(get-env-var "SEX_CC")
|
||||
"cc"))
|
||||
(out-file (if (eq? output 'default)
|
||||
"a.out"
|
||||
output))
|
||||
;; The generated C goes to a temporary .c file rather than the
|
||||
;; compiler's stdin. It is removed however we leave -- emit-c
|
||||
;; can throw, and used to leave the file behind when it did
|
||||
(c-file (create-temporary-file "c")))
|
||||
;; An unhandled error ends the process without unwinding, so the
|
||||
;; cleanup cannot be left to dynamic-wind
|
||||
(handle-exceptions exn
|
||||
(begin (delete-file* c-file) (abort exn))
|
||||
output)))
|
||||
;; The generated C goes to a temporary .c file rather than the
|
||||
;; compiler's stdin
|
||||
(let ((c-file (create-temporary-file "c")))
|
||||
(with-output-to-file c-file
|
||||
(lambda () (emit-c sex-forms)))
|
||||
(let ((proc (process compiler (append (list "-o" out-file)
|
||||
@@ -164,9 +135,9 @@ status, which is ours to pass on."
|
||||
(list c-file)
|
||||
cc-args))))
|
||||
(call-with-values (lambda () (process-wait proc))
|
||||
(lambda (pid normal-exit? status)
|
||||
(lambda status
|
||||
(delete-file* c-file)
|
||||
(if normal-exit? status 1)))))))
|
||||
(apply values status)))))))
|
||||
|
||||
(define (semantic-process-forms raw-forms input-source)
|
||||
(if (eq? input-source 'stdin)
|
||||
@@ -202,14 +173,6 @@ status, which is ours to pass on."
|
||||
(when help
|
||||
(print-help)
|
||||
(return #f))
|
||||
;; Read time comes before everything, so the features have to be
|
||||
;; in place before the first form is read
|
||||
(current-features
|
||||
(append (if (get-arg args 'no-platform-features #f)
|
||||
(list)
|
||||
(platform-features))
|
||||
(cli-features args)))
|
||||
|
||||
(when (get-arg args 'public-interface #f)
|
||||
(assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
|
||||
|
||||
@@ -235,7 +198,5 @@ status, which is ours to pass on."
|
||||
(get-arg args 'emit-c #f))
|
||||
;; Emit processed and macro-expanded sex code, or emit C code
|
||||
(emit-c-or-sex sex-forms output args)
|
||||
;; Compile file! The C compiler's status is ours too
|
||||
(let ((status (compile-to-file sex-forms output args cc-args)))
|
||||
(unless (zero? status)
|
||||
(exit status)))))))))
|
||||
;; Compile file!
|
||||
(compile-to-file sex-forms output args cc-args)))))))
|
||||
|
||||
@@ -46,5 +46,3 @@ clean:
|
||||
rm -f *.import.scm
|
||||
rm -f *.link
|
||||
rm -f sex-tests
|
||||
|
||||
.PHONY: clean
|
||||
|
||||
@@ -141,28 +141,6 @@ compiles."
|
||||
(test-assert "a comment in a body stays in the body"
|
||||
(emits? (in-fn "(while (< a b) ;; inside\n (g 1))")
|
||||
"while (a < b) {")))
|
||||
|
||||
(test-group "pub enum"
|
||||
(test-assert "is emitted"
|
||||
(emits? "(pub enum color (red green blue))" "enum color"))
|
||||
(test-assert "with its values"
|
||||
(emits? "(pub enum color (red green blue))" "red"))
|
||||
(test-assert "and a non-pub enum still is too"
|
||||
(emits? "(enum color (red green blue))" "enum color"))
|
||||
;; Naming an enum as a type, rather than defining it, had no
|
||||
;; walk-enum clause and died with `(match) no matching pattern'
|
||||
(test-assert "and it can then be used as a type"
|
||||
(emits? "(enum color (red green blue)) (fn f () void (var m (enum color) red))"
|
||||
"enum color m = red"))
|
||||
(test-assert "a malformed enum is rejected with its location"
|
||||
(reports? "(enum)" "codegen.sex:1:"))
|
||||
;; c-type handed the declarator's name to c-enum as the enum tag,
|
||||
;; so this emitted `enum m { up, down }' with no variable at all
|
||||
(test-assert "an anonymous enum keeps the variable"
|
||||
(emits? "(fn f () void (var e (enum (up down)) up))" "} e = up"))
|
||||
(test-assert "and a named definition keeps both"
|
||||
(emits? "(fn f () void (var n (enum named (a b)) a))" "enum named{")))
|
||||
|
||||
;; `|', `||' and `|=' read as ordinary symbols -- our own reader has
|
||||
;; no |symbol| syntax for them to collide with -- but fmt-c cannot
|
||||
;; dispatch on a symbol whose name it cannot write in Scheme source,
|
||||
|
||||
@@ -1,26 +0,0 @@
|
||||
# The failure paths.
|
||||
#
|
||||
# Both need a process to show themselves, so neither fits the unit
|
||||
# suite: sexc has to fail when cc fails -- exiting 0 after a failed
|
||||
# compile makes every driver, sextest included, read it as success --
|
||||
# and it has to clean up its temporary .c when its own emission throws.
|
||||
#
|
||||
# Everything is built inside a scratch TMPDIR, so nothing is left here
|
||||
# to clean up.
|
||||
|
||||
SEXC ?= ../../sexc
|
||||
|
||||
check:
|
||||
@d=`mktemp -d`; \
|
||||
TMPDIR=$$d $(SEXC) nested-pointer.sex -o $$d/out >/dev/null 2>&1; \
|
||||
if [ -n "`find $$d -name '*.c'`" ]; then \
|
||||
echo "exit code FAILED: the temporary .c survived a failed emission"; \
|
||||
rm -rf $$d; exit 1; \
|
||||
fi; \
|
||||
if $(SEXC) hello.sex -o $$d/out -- -no-such-cc-flag >/dev/null 2>&1; then \
|
||||
echo "exit code FAILED: sexc reported success after cc failed"; \
|
||||
rm -rf $$d; exit 1; \
|
||||
fi; \
|
||||
rm -rf $$d; echo "exit code ok"
|
||||
|
||||
.PHONY: check
|
||||
@@ -1,4 +0,0 @@
|
||||
;;; Compiles cleanly, so the only way the build can fail is the bogus
|
||||
;;; flag handed to cc -- which is the point.
|
||||
(pub fn main () int
|
||||
(return 0))
|
||||
@@ -1,4 +0,0 @@
|
||||
;;; Rejected by the writer, so emit-c throws: there is a temporary .c
|
||||
;;; by then, and it must not survive.
|
||||
(fn f () void
|
||||
(var p (* (* char))))
|
||||
@@ -7,14 +7,10 @@
|
||||
# module's object survives being passed after `--'. Get any of them
|
||||
# wrong and this fails to link -- or, in the `pub var' case, links and
|
||||
# quietly counts into a private copy.
|
||||
#
|
||||
# It also checks what only a second translation unit can check: that an
|
||||
# imported type reaches the type database, by expanding a macro that
|
||||
# reads the imported struct's fields.
|
||||
|
||||
SEXC ?= ../../sexc
|
||||
|
||||
EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1
|
||||
EXPECTED = hello, world\nhello, sex\n2 greetings
|
||||
|
||||
check:
|
||||
@$(SEXC) greet.sex -c -o greet.o
|
||||
|
||||
@@ -7,9 +7,6 @@
|
||||
;;; as a prototype and `greet-count' as an extern. Both keep external
|
||||
;;; linkage, so they refer to the one definition in greet.o rather than
|
||||
;;; to private copies.
|
||||
;;;
|
||||
;;; Also check that import populates type-database, by means of
|
||||
;;; describe-fields macro, which should work on imported type.
|
||||
|
||||
(include stdio.h)
|
||||
|
||||
@@ -19,11 +16,4 @@
|
||||
(greet "world")
|
||||
(greet "sex")
|
||||
(printf "%d greetings\n" greet-count)
|
||||
(describe-fields greeting)
|
||||
(printf "\n")
|
||||
;; ...and through the imported typedef for it
|
||||
(describe-fields greeting-t)
|
||||
(printf "\n")
|
||||
(var m (enum mood) grumpy)
|
||||
(printf "mood %d\n" m)
|
||||
(return 0))
|
||||
|
||||
@@ -9,20 +9,6 @@
|
||||
|
||||
(pub var greet-count int 0)
|
||||
|
||||
(pub struct greeting ((text (* const char)) (times int)))
|
||||
|
||||
(pub enum mood (cheerful grumpy))
|
||||
|
||||
(pub typedef greeting-t (struct greeting))
|
||||
|
||||
;;; Compile-time reflection across the module boundary: both the macro
|
||||
;;; and the struct it asks about are exported, and the importing unit
|
||||
;;; has to know the struct's fields to expand this.
|
||||
(pub defmacro (describe-fields type)
|
||||
`(do ,@(map-fields type
|
||||
(lambda (name field-type)
|
||||
`(printf "%s " ,(symbol->string name))))))
|
||||
|
||||
(pub fn greet ((name (* const char))) void
|
||||
(++ greet-count)
|
||||
(printf "hello, %s\n" name))
|
||||
|
||||
@@ -1,14 +1,6 @@
|
||||
(import (chicken port)
|
||||
reader)
|
||||
|
||||
(define-syntax feature-test
|
||||
(syntax-rules ()
|
||||
((feature-test result features string)
|
||||
(test result
|
||||
(parameterize ((current-features 'features))
|
||||
(with-input-from-string string
|
||||
(lambda () (read-raw-forms 'stdin))))))))
|
||||
|
||||
(define-syntax reader-test
|
||||
(syntax-rules ()
|
||||
((reader-test result string)
|
||||
@@ -46,41 +38,4 @@
|
||||
(reader-test '((a b) (comment " t")) "(a b) ; t")
|
||||
;; a `;' inside a string is not a comment
|
||||
(reader-test '("a;b") "\"a;b\"")
|
||||
|
||||
;; #+ / #- feature expressions. What does not apply is read and
|
||||
;; dropped, so it never reaches the compiler at all
|
||||
(feature-test '((a)) (linux) "#+linux (a)")
|
||||
(feature-test '() (macosx) "#+linux (a)")
|
||||
(feature-test '() (linux) "#-linux (a)")
|
||||
(feature-test '((a)) (macosx) "#-linux (a)")
|
||||
;; the guarded datum can be anything, not only a list
|
||||
(feature-test '(42) (x) "#+x 42")
|
||||
(feature-test '("s") (x) "#+x \"s\"")
|
||||
|
||||
;; and / or / not
|
||||
(feature-test '((a)) (unix linux) "#+(and unix linux) (a)")
|
||||
(feature-test '() (unix) "#+(and unix linux) (a)")
|
||||
(feature-test '((a)) (unix) "#+(or linux unix) (a)")
|
||||
(feature-test '() (bsd) "#+(or linux unix) (a)")
|
||||
(feature-test '((a)) (unix) "#+(and unix (not macosx)) (a)")
|
||||
(feature-test '() (unix macosx) "#+(and unix (not macosx)) (a)")
|
||||
;; (and) is true and (or) is false, as they are in CL
|
||||
(feature-test '((a)) () "#+(and) (a)")
|
||||
(feature-test '() () "#+(or) (a)")
|
||||
|
||||
;; a guard inside a form, including as the last element -- dropping
|
||||
;; continues with the next token, so the closing paren still arrives
|
||||
(feature-test '((f 1 3)) (a) "(f #+a 1 #-a 2 3)")
|
||||
(feature-test '((f 2 3)) (b) "(f #+a 1 #-a 2 3)")
|
||||
(feature-test '((f 1)) (a) "(f #+a 1 #+b 2)")
|
||||
(feature-test '((f)) (b) "(f #+a 1)")
|
||||
;; ...and as the last form in the file
|
||||
(feature-test '((a)) (x) "(a) #+y (b)")
|
||||
|
||||
;; guards nest
|
||||
(feature-test '((a)) (x y) "#+x #+y (a)")
|
||||
(feature-test '((b)) (x) "#+x #+y (a) (b)")
|
||||
|
||||
;; a feature the program was not given is simply absent
|
||||
(feature-test '() () "#+anything (a)")
|
||||
)
|
||||
|
||||
@@ -1,23 +0,0 @@
|
||||
(compilation "--features=test-on")
|
||||
(input)
|
||||
(output "selected" "on" "and-not")
|
||||
(return 0)
|
||||
|
||||
;;; #+ and #- pick what the compiler gets to see. `test-on' is handed
|
||||
;;; to sexc by the (compilation ...) form above, so this program reads
|
||||
;;; the same way on every platform.
|
||||
|
||||
(include stdio.h)
|
||||
|
||||
#+test-on (define GREETING "on")
|
||||
#-test-on (define GREETING "off")
|
||||
|
||||
#-test-on (pub fn main () int (puts "the whole function is dropped") (return 1))
|
||||
|
||||
(pub fn main () int
|
||||
;; ...and inside a form, not only at toplevel
|
||||
(puts #+test-on "selected" #-test-on "rejected")
|
||||
(puts GREETING)
|
||||
#+(and test-on (not test-off)) (puts "and-not")
|
||||
#-test-on (puts "never printed")
|
||||
(return 0))
|
||||
@@ -1,14 +1,3 @@
|
||||
(module types
|
||||
(add-struct
|
||||
add-union
|
||||
add-enum
|
||||
add-typedef
|
||||
add-define
|
||||
|
||||
type-match
|
||||
map-fields
|
||||
|
||||
get-type-info
|
||||
get-fields
|
||||
get-underlying-type)
|
||||
*
|
||||
"../types.scm")
|
||||
|
||||
@@ -54,42 +54,6 @@
|
||||
#f
|
||||
(get-underlying-type 't-point))
|
||||
|
||||
;; Reflection through an alias. Both spellings of the target occur:
|
||||
;; (typedef point-t point) and (typedef point-t (struct point)).
|
||||
(add-typedef 't-point-t '(typedef t-point-t t-point))
|
||||
(test "a typedef to a struct has the struct's fields"
|
||||
'((x int) (y int))
|
||||
(get-fields 't-point-t))
|
||||
(add-typedef 't-point-s '(typedef t-point-s (struct t-point)))
|
||||
(test "written the other way round too"
|
||||
'((x int) (y int))
|
||||
(get-fields 't-point-s))
|
||||
(add-typedef 't-point-2 '(typedef t-point-2 t-point-t))
|
||||
(test "and through a chain of them"
|
||||
'((x int) (y int))
|
||||
(get-fields 't-point-2))
|
||||
(test "map-fields follows an alias as well"
|
||||
'((x int) (y int))
|
||||
(map-fields 't-point-t (lambda (name type) (list name type))))
|
||||
(add-typedef 't-color-t '(typedef t-color-t t-color))
|
||||
(test "an aliased enum is still named as it was declared"
|
||||
'((red (enum t-color)) (green (enum t-color)) (blue (enum t-color)))
|
||||
(map-fields 't-color-t (lambda (name type) (list name type))))
|
||||
(test "a typedef to a primitive has no fields"
|
||||
#f
|
||||
(get-fields 't-u8))
|
||||
|
||||
;; A typedef can be written to lead back to itself. Resolving it must
|
||||
;; stop rather than spin
|
||||
(add-typedef 't-loop-a '(typedef t-loop-a t-loop-b))
|
||||
(add-typedef 't-loop-b '(typedef t-loop-b t-loop-a))
|
||||
(test "a typedef cycle terminates"
|
||||
't-loop-a
|
||||
(get-underlying-type 't-loop-a))
|
||||
(test "and has no fields"
|
||||
#f
|
||||
(get-fields 't-loop-a))
|
||||
|
||||
;; A #define keeps its value forms -- there can be more than one.
|
||||
(add-define 't-maxn '(define t-maxn 8))
|
||||
(test "defines are recorded"
|
||||
|
||||
@@ -1,6 +1,3 @@
|
||||
(module reader (read-from-file
|
||||
read-raw-forms
|
||||
|
||||
current-features
|
||||
platform-features)
|
||||
read-raw-forms)
|
||||
"../../reader.scm")
|
||||
|
||||
@@ -7,63 +7,36 @@
|
||||
(chicken port)
|
||||
(chicken process)
|
||||
(chicken process-context)
|
||||
(chicken string) ; string-split
|
||||
fmt
|
||||
getopt-long
|
||||
reader ; read-raw-forms, shared with sexc
|
||||
srfi-1
|
||||
srfi-13) ; string-prefix?
|
||||
srfi-1)
|
||||
|
||||
(define (print-help)
|
||||
(fmt #t "Usage: sextest [options] filename" nl
|
||||
"Options:" nl
|
||||
(usage opts-grammar) nl))
|
||||
|
||||
(define (split-settings contents)
|
||||
(foldl (lambda (acc elt)
|
||||
(case (car elt)
|
||||
((compilation input output return)
|
||||
(cons
|
||||
(append (car acc) (list elt))
|
||||
(cdr acc)))
|
||||
(else
|
||||
(cons
|
||||
(car acc)
|
||||
(append (cdr acc) (list elt))))))
|
||||
(cons (list) (list))
|
||||
contents))
|
||||
|
||||
;;; --features from the (compilation ...) form, which we have to honour
|
||||
;;; ourselves: the program is read here and printed back out for sexc,
|
||||
;;; so #+ and #- are resolved on this side
|
||||
(define (compilation-features settings)
|
||||
(let ((compilation (assoc 'compilation settings)))
|
||||
(if compilation
|
||||
(append-map (lambda (flag)
|
||||
(if (string-prefix? "--features=" flag)
|
||||
(map string->symbol
|
||||
(string-split (substring flag 11) ","))
|
||||
(list)))
|
||||
(string-split (cadr compilation)))
|
||||
(list))))
|
||||
|
||||
(define (process-file target-path)
|
||||
(let* ((first-pass (split-settings (read-raw-forms target-path)))
|
||||
(features (compilation-features (car first-pass))))
|
||||
(if (null? features)
|
||||
first-pass
|
||||
(parameterize ((current-features (append (platform-features) features)))
|
||||
(split-settings (read-raw-forms target-path))))))
|
||||
(let ((contents (read-raw-forms target-path)))
|
||||
(foldl (lambda (acc elt)
|
||||
(case (car elt)
|
||||
((compilation input output return)
|
||||
(cons
|
||||
(append (car acc) (list elt))
|
||||
(cdr acc)))
|
||||
(else
|
||||
(cons
|
||||
(car acc)
|
||||
(append (cdr acc) (list elt))))))
|
||||
(cons (list) (list))
|
||||
contents)))
|
||||
|
||||
(define (compile src compilation sexc)
|
||||
(define (compile src flags sexc)
|
||||
(let ((compiler (or
|
||||
(and sexc (cdr sexc))
|
||||
(get-environment-variable "SEXC")
|
||||
"sexc"))
|
||||
;; (compilation "--features=x -- -O2") -- one string
|
||||
(flags (if compilation
|
||||
(string-split (cadr compilation))
|
||||
(list)))
|
||||
(compiled-file (create-temporary-file)))
|
||||
;; `process' returns one record; `process-input-port' is named from
|
||||
;; the child's side, so it is the port we write to.
|
||||
@@ -137,7 +110,7 @@
|
||||
(let* ((settings-and-src (process-file path))
|
||||
(settings (car settings-and-src))
|
||||
(src (cdr settings-and-src))
|
||||
(compiled-file (compile src (assoc 'compilation settings) sexc)))
|
||||
(compiled-file (compile src (assoc 'compile settings) sexc)))
|
||||
(if (not compiled-file)
|
||||
(begin (fmt #t "Failed to compile " path nl)
|
||||
#f)
|
||||
|
||||
44
types.scm
44
types.scm
@@ -76,44 +76,21 @@
|
||||
;;; ((name type) ...) for a struct or union, #f for anything else --
|
||||
;;; including a name that was never declared. Callers give the better
|
||||
;;; error, since they know what they wanted it for.
|
||||
;;;
|
||||
;;; A typedef is followed to what it stands for, so reflection over an
|
||||
;;; alias works exactly as it does over the name it aliases.
|
||||
(define (get-fields name)
|
||||
(let ((info (resolve-type-info name)))
|
||||
(let ((info (get-type-info name)))
|
||||
(and info
|
||||
(memq (car info) '(struct union))
|
||||
(caddr info))))
|
||||
|
||||
;;; Follow a typedef chain to the name it stands for. #f if NAME is
|
||||
;;; not a typedef. A typedef that leads back to itself stops rather
|
||||
;;; than spinning: nothing prevents one from being written.
|
||||
;;; Follow a typedef chain to the name it ultimately stands for. #f if
|
||||
;;; NAME is not a typedef.
|
||||
(define (get-underlying-type name)
|
||||
(let follow ((name name) (seen (list)))
|
||||
(and (not (member name seen))
|
||||
(let ((info (get-type-info name)))
|
||||
(and info
|
||||
(eq? (car info) 'typedef)
|
||||
(let ((target (caddr info)))
|
||||
(or (and (symbol? target) (follow target (cons name seen)))
|
||||
target)))))))
|
||||
|
||||
;;; The declaration NAME ultimately names. For a typedef that is the
|
||||
;;; entry of whatever it stands for, and for anything else it is
|
||||
;;; NAME's own info.
|
||||
(define (resolve-type-info name)
|
||||
(let ((info (get-type-info name)))
|
||||
(and info
|
||||
(if (eq? (car info) 'typedef)
|
||||
(let* ((target (get-underlying-type name))
|
||||
(tag (cond ((symbol? target) target)
|
||||
((and (pair? target)
|
||||
(pair? (cdr target))
|
||||
(symbol? (cadr target)))
|
||||
(cadr target))
|
||||
(else #f))))
|
||||
(and tag (get-type-info tag)))
|
||||
info))))
|
||||
(eq? (car info) 'typedef)
|
||||
(let ((target (caddr info)))
|
||||
(or (and (symbol? target) (get-underlying-type target))
|
||||
target)))))
|
||||
|
||||
;;; Type matcher macro
|
||||
;;; (type-match type
|
||||
@@ -142,16 +119,15 @@
|
||||
;;;
|
||||
;;; Returns #f if nothing of that name was declared
|
||||
(define (map-fields struct-union-enum fn)
|
||||
(let ((info (resolve-type-info struct-union-enum)))
|
||||
(let ((info (get-type-info struct-union-enum)))
|
||||
(and info
|
||||
(case (car info)
|
||||
((struct union)
|
||||
(map (lambda (field) (fn (car field) (cadr field)))
|
||||
(caddr info)))
|
||||
;; An enumerator's type is the enum itself -- named as it was
|
||||
;; declared, since `enum some-typedef' is not a C type.
|
||||
;; An enumerator's type is the enum itself.
|
||||
((enum)
|
||||
(let ((type (list 'enum (cadr info))))
|
||||
(let ((type (list 'enum struct-union-enum)))
|
||||
(map (lambda (value) (fn value type))
|
||||
(caddr info))))
|
||||
(else #f)))))
|
||||
|
||||
Reference in New Issue
Block a user