read the feature flags in sextest in the way sexc does

sextest resolves #+ and #- itself -- it reads the program and prints
what survives to sexc -- so a flag spelling it does not recognise
decides which branch gets compiled

.gitea/workflows/build.yaml

@@ -0,0 +1,65 @@
+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

.gitignore

@@ -0,0 +1,11 @@
+# Project-local Chicken egg repository
+/.eggs
+
+# Compilation artifacts
+*.o
+*.import.scm
+*.link
+sexc
+sex-tests
+sextest
+tools/sextest/sextest

Makefile

@@ -1,20 +1,151 @@
-CHICKEN_C = csc
+CHICKEN_C ?= csc
+CHICKEN_INSTALL ?= chicken-install
+CHICKEN_STATUS ?= chicken-status
+CSC_FLAGS += -K prefix -static
+# What and why:
+# -emit-all-import-libraries: Emit import-libraries for all defined modules.
+#    Used to generate .import.scm files so compiler would know how to use the modules.
+#    Without it, csc fails with "cannot import from undefined module" error.
+# -module-registration: Always  generate  module registration code, even when
+#    import libraries are emitted. Enables us to import from our modules at run time.
+#    Used in macros, where we inject `(import (only sex-macros cat))' before the macro body.
+#    Without it, sexc compiles scuccessfully, but is unable to process macros, failing with
+#    "during expansion of (import ...) - cannot import from undefined module: sex-macros"
+#     error.
+# -c: Stop after compilation to object files. This one is obvious.
 
-MODULES = sexc sex-macros sex-modules sex-types utils fmt-c
+# 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)
 
-sexc: main.o $(OBJ)
-	$(CHICKEN_C) $^ -o $@
+DEPSFILE = dependencies.txt
+DEPSLOCK = eggs.lock
+EGGS_DIR := $(abspath .eggs)
 
-main.o: main.scm
-	$(CHICKEN_C) $< -c -o $@
+# 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)
 
-%.o: %.scm
-	$(CHICKEN_C) $< -e -c -o $@
+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)
 
-sex-tests: $(OBJ) tests/*.scm
-	cd ./tests && $(CHICKEN_C) run.scm -c -o sex-tests.o
-	$(CHICKEN_C) $(OBJ) ./tests/sex-tests.o -o sex-tests
+all: sexc
+
+sexc: $(EGGS_STAMP) $(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
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
+
+types.o: types.module.scm types.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types
+
+sex-macros.o: sex-macros.module.scm sex-macros.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
+
+reader.o: reader.module.scm reader.scm utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
+
+sex-modules.o: sex-modules.module.scm sex-modules.scm reader.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
+
+semen.o: semen.module.scm semen.scm sex-macros.o sex-modules.o types.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,types,utils
+
+sex-fmt-c.o: sex-fmt-c.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
+
+fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
+
+sexc.o: sexc.module.scm types.o sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
+	$(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)
+	$(MAKE) -C ./tests sex-tests
+	cp ./tests/sex-tests ./
+
+sextest: $(EGGS_STAMP)
+	$(MAKE) -C ./tools/sextest sextest
+	cp ./tools/sextest/sextest .
+
+SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \
+                    feature-flags
+
+# 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)
 
 clean:
-	rm -f $(OBJ) sexc sex-tests main.o ./tests/sex-tests.o
+	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

Readme.org

@@ -1,21 +1,57 @@
 * The Sex language
-Sex is a S-expressions language. Sex is written in Chicken, which is a
-[[https://call-cc.org][R5RS Scheme]].
+
+#+NAME: the Sex logo
+#+ATTR_HTML: :width 300px
+[[sex.png][file:./sex.png]]
+
+Sex is a S-expressions language. Sex is written in Chicken, which is an
+[[https://call-cc.org][R7RS Scheme]].
+Sex is statically typed, compiled general purpose language.
 
 * Compilation
 First, get yourself a Chicken, then, some Chicken deps. You also will
 need a C compiler.
 
-** 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 fmt getopt-long brev-separate test tree srfi-1 srfi-13 srfi-69~
+Eggs are installed into a project-local ~.eggs/~ repository; they do not
+touch the Chicken system repository.
 
 ** Compilation
-~make~
+#+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
 
 * Usage
 ** Summary
@@ -25,12 +61,21 @@ 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
- -E, --preprocess         Emit C code
+ -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
  --public-interface       Get module's public interface
  -h, --help               Show this help
- -m, --macro-expand       Emit macro-expanded Sex code
+ -m, --macro-expand       Emit macro-expanded semantically processed Sex code
  -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
@@ -42,18 +87,24 @@ directory. Sex uses C under the hood, the default C compiler is ~cc~,
 but you can pass any using ~--c-compiler~ option, or by setting
 ~SEX_CC~ environment variable.
 
+Everything after ~--~ is handed to the C compiler exactly as written:
+
+#+begin_src shell
+sexc example/sdl3-triangle.sex -o triangle -- `pkg-config --cflags --libs sdl3` -framework OpenGL
+#+end_src
+
 ** Example
 An example of Sex source:
 #+begin_src scheme
 (include stdio.h)
 
-(pub fn int main ((int argc) (char **argv))
+(pub fn main ((argc int) (argv  [* const char])) int
   (puts "Hello from Sex!")
-  (var (array char 512) name)
+  (var name [char 512])
   (puts "What is your name?")
-  (scanf "%s" (cast char* &name))
+  (scanf "%s" (cast (& name) (* char)))
   (printf "Hello, %s!\n" name)
-  0)
+  (return 0))
 #+end_src
 
 Compile and run:
@@ -71,9 +122,9 @@ Hello, Alex!
 Just ~(include "Your/Favourite/Library.h")~ and use it as you would
 have is C.
 
-** Auto unkebabification
+*** Auto kebabification
 For hardcore fans of traditional Lisp naming convention,
-Sex offers automatic unkebabification of all symbols, i.e. no more
+Sex offers automatic kebabification of all symbols, i.e. no more
 ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
 proper form: ~GL-ARRAY-BUFFER~.
 
@@ -88,6 +139,39 @@ 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
@@ -99,40 +183,45 @@ return Sex code.
 (pub defmacro (list-T type)
   (let ((list-type (cat 'list- type)))
     `(struct ,list-type
-       ((,type value)
-        ((* ,list-type) next)))))
+       ((value ,type)
+        (next (* ,list-type))))))
 
 (list-T int)
 #+end_src
 ->
 #+begin_src scheme
 (struct list_int
- ((int value)
-  ((* list_int) next)))
+ ((value int)
+  (next (* list_int))))
 #+end_src
 
 **** Wrapper for checking return codes
 #+begin_src scheme
 (pub defmacro (check-sdl-return call message ret-code)
-  `((if (< 0 ,call)
-        (begin
+  `(if (< 0 ,call)
+       (do
          (puts ,message)
-         (return ,ret-code)))))
+         (return ,ret-code))))
 
-(pub fn int init ()
+(pub fn init () int
   (check-sdl-return
     (SDL-Init SDL-INIT-VIDEO) "Failed to initialize SDL" 1)
 ...)
 #+end_src
 ->
-#+begin_src c
-(%fun int init ()
+#+begin_src scheme
+(pub fn init () int
   (if (< 0 (SDL_Init SDL_INIT_VIDEO))
-    (%begin (puts "Failed to initialize SDL") (return 1)))
+    (do (puts "Failed to initialize SDL") (return 1)))
   ...)
-}
 #+end_src
 
+** Compile-time type information
+Sex has a number of type reflection features, aiming to help with
+macro writing. During the compilation, all type info is collected, and
+is accessible during macro expansion. This allows us to write things
+like providing auto serialization, adding meta information, and so on.
+
 ** Use an established environment for development
 As Sex is S-expressions, you always have Emacs with paredit as your
 best option.

dependencies.txt

@@ -0,0 +1 @@
+fmt getopt-long brev-separate test srfi-1 srfi-13 srfi-69 matchable

eggs.lock

@@ -0,0 +1,8 @@
+(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")

example/begin.sex

@@ -1,8 +0,0 @@
-(pub fn void other-fn ()
-  (begin (while true (begin 1 2 3 4)))
-  (switch a
-          ((1) (begin
-                (var (const char *) str "121232132")
-                (puts "str")))
-          ((2) (puts "2"))
-          (default (puts "more"))))

example/fn-no-args.sex

@@ -1 +0,0 @@
-(pub fn void no-args-fn () ())

example/fns.sex

@@ -0,0 +1,10 @@
+;;; Prototypes
+(fn puk () void)
+
+(pub fn plak () void)
+
+;;; Functions
+(fn foo () int (return 1))
+
+(pub fn bar ((a int) (b int)) void
+  (printf "%d\n" (+ a b)))

example/hello-world.sex

@@ -1,9 +1,9 @@
 (include stdio.h)
 
-(pub fn int main ((int argc) (char **argv))
-  (var (array char 512) name)
+(pub fn main ((argc int) (argv  [* const char])) int
   (puts "Hello from Sex!")
+  (var name [char 512])
   (puts "What is your name?")
-  (scanf "%s" (cast char* &name))
+  (scanf "%s" (cast (& name) (* char)))
   (printf "Hello, %s!\n" name)
   (return 0))

example/lambdas.sex

@@ -0,0 +1,51 @@
+(include stdio.h)
+
+(fn sum ((a int) (b int)) int
+  (return (+ a b)))
+
+(pub fn main () int
+  (var a int 10)
+  (var b int 20)
+  (var (fn ((int) (int)) int) sum-fn sum)
+
+  (var (fn ((int) (int)) int) sum-lambda
+
+       (lambda ((a int) (b int)) int ()
+         (return (+ a b))))
+
+  (var (fn ((int)) int) sum-lambda-2
+
+       (lambda ((a int)) int ()
+         (return (+ a 20))))
+
+  (printf "Hello from main fn!\n")
+  (printf "We will now perform some function calling.\n")
+
+  (printf "Calling fn ptr: %d\n" (sum-fn a b))
+  (printf "Calling lambda: %d\n" (sum-lambda a b))
+  (printf "Calling other lambda: %d\n" (sum-lambda-2 a))
+  (printf "Calling lambda inplace: %d\n" ((lambda ((a int) (b int)) int ()
+                                            (return (+ a b 100)))
+                                          a b))
+
+  (var (fn ((int)) int) l-1
+       (lambda ((a int)) int ()
+         (var (fn ((int)) int) l-2
+              (lambda ((a int)) int ()
+                (return (+ 60 a))))
+         (return (+ 600 (l-2 a)))))
+  (printf "Calling nested lambdas: %d\n" (l-1 6))
+
+  ;; Not supported yet
+  ;; Closure
+  ;;  (var (fn (fn ((int)) int) ((int))) make-adder
+  ;;       (lambda (fn int ((int a))) ()
+  ;;         (return (lambda int ((int b)) (a)
+  ;;                   (return (+ a b))))))
+  ;;
+  ;;  (var (fn int ((int))) add-10
+  ;;       (make-adder 10))
+  ;;  (var (fn int ((int))) add-20
+  ;;       (make-adder 20))
+  ;;  (printf "Calling closures: %d\n" (add-10 24))
+  (return 0))

example/list.sex

@@ -1,21 +1,21 @@
 (pub defmacro (list-T type)
   (let ((list-type (cat 'list- type)))
     `(struct ,list-type
-       ((,type value)
-        ((* ,list-type) next)))))
+       ((value ,type)
+        (next (* struct ,list-type))))))
 
 (pub defmacro (make-list-T type is-public?)
-  (let ((list-type (cat 'list- type))
+  (let ((list-type (list 'struct (cat 'list- type)))
         (fn-name (cat 'make-list- type)))
-    `(,@(if is-public? '(pub) '()) fn (* ,list-type) ,fn-name ()
-      (var (* ,list-type) list (cast (* ,list-type) (malloc (sizeof ,list-type))))
+    `(,@(if is-public? '(pub) '()) fn ,fn-name () (* ,list-type)
+      (var list (* ,list-type) (cast  (malloc (sizeof ,list-type)) (* ,list-type)))
       (= (-> list next) NULL)
       (return list))))
 
 (pub defmacro (add-value-list-T type is-public?)
-  (let ((list-type (cat 'list- type))
+  (let ((list-type (list 'struct (cat 'list- type)))
         (fn-name (cat 'add-value-list- type)))
-    `(,@(if is-public? '(pub) '()) fn void ,fn-name ((,list-type *list) (,type value))
+    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list * ,list-type) (value ,type)) void
       (while (!= (-> list next) NULL)
         (= list (-> list next)))
       (= (-> list next) (,(cat 'make-list- type)))
@@ -23,25 +23,26 @@
 
 (pub defmacro (length-list-T type is-public?)
   (let ((fn-name (cat 'length-list- type))
-        (list-type (cat 'list- type)))
-    `(,@(if is-public? '(pub) '()) fn size-t ,fn-name ((,list-type *list))
-      (var size-t n 0)
+        (list-type (list 'struct (cat 'list- type))))
+    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list ,(cons '* list-type))) size-t
+      (var n size-t 0)
       (while (!= (-> list next) NULL)
         (= list (-> list next))
         (++ n))
       (return n))))
 
 (pub defmacro (is-empty-list-T type is-public?)
-  `(,@(if is-public? '(pub) '()) fn bool ,(cat 'is-empty-list- type)
-    ((,(cat 'list- type) *list))
+  `(,@(if is-public? '(pub) '()) fn ,(cat 'is-empty-list- type)
+    ((list ,(list '* 'struct (cat 'list- type))))
+    bool
     (return (== (-> list next) NULL))))
 
 (pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
   (let ((list-var-2 (cat list-var '-2)))
-    `((begin
-       (var (pointer ,list-type) ,list-var-2 ,list-var)
-       (var ,elt-type ,elt-var (-> ,list-var-2 value))
-       (while (!= (-> ,list-var-2 next) NULL)
-         ,what-do
-         (= ,list-var-2 (-> ,list-var-2 next))
-         (= ,elt-var (-> ,list-var-2 value)))))))
+    `(do
+      (var ,list-var-2 (* ,list-type) ,list-var)
+      (var ,elt-var ,elt-type (-> ,list-var-2 value))
+      (while (!= (-> ,list-var-2 next) NULL)
+        ,what-do
+        (= ,list-var-2 (-> ,list-var-2 next))
+        (= ,elt-var (-> ,list-var-2 value))))))

example/polymorphism.sex

@@ -1,25 +0,0 @@
-(include stdint.h)
-
-(struct vec2
-  ((uint32_t x)
-   (uint32_t y)))
-
-(trait gui
-  (fn void update ((float dt)))
-  (fn void render ())
-  (fn vec2 get-position ())
-  (fn void add-child ((gui *w))))
-
-(struct button
-  ((vector gui) children)
-  ((vec2 pos)))
-
-(impl gui button
-  (fn void update ((float dt))
-    ())
-  (fn void render ()
-    ())
-  (fn vec2 get-position ()
-    (return self->pos))
-  (fn void add-child ((gui *w))
-    (push self->children w)))

example/sdl3-triangle.sex

@@ -0,0 +1,262 @@
+;;; A triangle that follows the mouse pointer, spins while the left
+;;; mouse button is held down, and quits on Escape (or on closing the
+;;; window).
+;;;
+;;; SDL3 supplies the window, the GL context and the events. Everything
+;;; drawn goes through an OpenGL 3.3 core-profile pipeline: a vertex and
+;;; fragment shader, and one VAO/VBO holding a unit triangle. Where the
+;;; 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:
+;;;   ./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
+
+(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)
+
+(define WINDOW-WIDTH 800)
+(define WINDOW-HEIGHT 600)
+
+(define TRIANGLE-RADIUS 70.0)           ; in window units
+(define SPIN-SPEED 3.0)                 ; radians per second
+
+;;; The vertex shader does the whole transform: spin the unit triangle
+;;; by u_angle, scale it to u_radius, move it to u_center, then convert
+;;; from window coordinates to clip space. That way a frame only has to
+;;; push four uniforms rather than rebuild any geometry.
+(var vertex-shader-src (* const char) "
+#version 330 core
+
+layout (location = 0) in vec2 a_pos;
+layout (location = 1) in vec3 a_color;
+
+uniform vec2  u_center;      // triangle centre, in window units
+uniform vec2  u_viewport;    // window size, same units as u_center
+uniform float u_angle;       // current spin, in radians
+uniform float u_radius;      // triangle size, in window units
+
+out vec3 v_color;
+
+void main()
+{
+    float s = sin(u_angle);
+    float c = cos(u_angle);
+    vec2 spun = vec2(a_pos.x * c - a_pos.y * s,
+                     a_pos.x * s + a_pos.y * c);
+    vec2 p = spun * u_radius + u_center;
+
+    // Window coordinates have their origin top-left with y growing
+    // downwards; clip space is centred with y growing upwards.
+    gl_Position = vec4(p.x / u_viewport.x * 2.0 - 1.0,
+                       1.0 - p.y / u_viewport.y * 2.0,
+                       0.0,
+                       1.0);
+    v_color = a_color;
+}
+")
+
+(var fragment-shader-src (* const char) "
+#version 330 core
+
+in vec3 v_color;
+out vec4 frag_color;
+
+void main()
+{
+    frag_color = vec4(v_color, 1.0);
+}
+")
+
+(fn compile-shader ((kind GLenum) (src (* const char))) GLuint
+  (var shader GLuint (glCreateShader kind))
+  (glShaderSource shader 1 (& src) NULL)
+  (glCompileShader shader)
+
+  (var ok GLint 0)
+  (glGetShaderiv shader GL-COMPILE-STATUS (& ok))
+  (if (== ok 0)
+      (do
+        (var info [char 1024])
+        (glGetShaderInfoLog shader 1024 NULL info)
+        (SDL-Log "shader compilation failed: %s" info)
+        (glDeleteShader shader)
+        (return 0)))
+  (return shader))
+
+(fn make-program () GLuint
+  (var vertex-shader GLuint (compile-shader GL-VERTEX-SHADER vertex-shader-src))
+  (var fragment-shader GLuint (compile-shader GL-FRAGMENT-SHADER fragment-shader-src))
+  (if (c-or (== vertex-shader 0) (== fragment-shader 0))
+      (do
+        (glDeleteShader vertex-shader)
+        (glDeleteShader fragment-shader)
+        (return 0)))
+
+  (var program GLuint (glCreateProgram))
+  (glAttachShader program vertex-shader)
+  (glAttachShader program fragment-shader)
+  (glLinkProgram program)
+
+  ;; The shaders are only needed until the program is linked; the
+  ;; program holds its own reference until then.
+  (glDeleteShader vertex-shader)
+  (glDeleteShader fragment-shader)
+
+  (var ok GLint 0)
+  (glGetProgramiv program GL-LINK-STATUS (& ok))
+  (if (== ok 0)
+      (do
+        (var info [char 1024])
+        (glGetProgramInfoLog program 1024 NULL info)
+        (SDL-Log "program linking failed: %s" info)
+        (glDeleteProgram program)
+        (return 0)))
+  (return program))
+
+(pub fn main () int
+  (if (! (SDL-Init SDL-INIT-VIDEO))
+      (do
+        (SDL-Log "SDL_Init failed: %s" (SDL-GetError))
+        (return 1)))
+
+  ;; Ask for core profile 3.3 before the window exists: these attributes
+  ;; are read when the context is created.
+  (SDL-GL-SetAttribute SDL-GL-CONTEXT-MAJOR-VERSION 3)
+  (SDL-GL-SetAttribute SDL-GL-CONTEXT-MINOR-VERSION 3)
+  (SDL-GL-SetAttribute SDL-GL-CONTEXT-PROFILE-MASK SDL-GL-CONTEXT-PROFILE-CORE)
+  (SDL-GL-SetAttribute SDL-GL-DOUBLEBUFFER 1)
+
+  (var window (* SDL-Window)
+       (SDL-CreateWindow "Sex + SDL3 + OpenGL"
+                         WINDOW-WIDTH WINDOW-HEIGHT
+                         SDL-WINDOW-OPENGL))
+  (if (== window NULL)
+      (do
+        (SDL-Log "SDL_CreateWindow failed: %s" (SDL-GetError))
+        (SDL-Quit)
+        (return 1)))
+
+  (var gl-context SDL-GLContext (SDL-GL-CreateContext window))
+  (if (== gl-context NULL)
+      (do
+        (SDL-Log "SDL_GL_CreateContext failed: %s" (SDL-GetError))
+        (SDL-DestroyWindow window)
+        (SDL-Quit)
+        (return 1)))
+
+  (SDL-GL-MakeCurrent window gl-context)
+  (SDL-GL-SetSwapInterval 1)
+
+  (var program GLuint (make-program))
+  (if (== program 0)
+      (do
+        (SDL-GL-DestroyContext gl-context)
+        (SDL-DestroyWindow window)
+        (SDL-Quit)
+        (return 1)))
+
+  ;; A unit triangle, two position components then three colour
+  ;; components per vertex. The vertices sit on the unit circle at 90,
+  ;; 210 and 330 degrees; the shader spins, scales and moves it.
+  (var verts [GLfloat 15]
+       #( 0.000   1.000    1.00 0.35 0.35
+         -0.866  -0.500    0.35 1.00 0.45
+          0.866  -0.500    0.40 0.50 1.00))
+
+  (var vao GLuint 0)
+  (var vbo GLuint 0)
+  (glGenVertexArrays 1 (& vao))
+  (glBindVertexArray vao)
+  (glGenBuffers 1 (& vbo))
+  (glBindBuffer GL-ARRAY-BUFFER vbo)
+  (glBufferData GL-ARRAY-BUFFER (sizeof verts) verts GL-STATIC-DRAW)
+
+  (var stride GLsizei (cast (* 5 (sizeof GLfloat)) GLsizei))
+  (glVertexAttribPointer 0 2 GL-FLOAT GL-FALSE stride (cast 0 (* void)))
+  (glEnableVertexAttribArray 0)
+  (glVertexAttribPointer 1 3 GL-FLOAT GL-FALSE stride
+                         (cast (* 2 (sizeof GLfloat)) (* void)))
+  (glEnableVertexAttribArray 1)
+
+  (var u-center GLint (glGetUniformLocation program "u_center"))
+  (var u-viewport GLint (glGetUniformLocation program "u_viewport"))
+  (var u-angle GLint (glGetUniformLocation program "u_angle"))
+  (var u-radius GLint (glGetUniformLocation program "u_radius"))
+
+  (var running bool true)
+  (var angle float 0.0)
+  (var last-ticks Uint64 (SDL-GetTicks))
+  (var event SDL-Event)
+
+  (while running
+    (while (SDL-PollEvent (& event))
+      (switch (. event type)
+        (case SDL-EVENT-QUIT
+          (= running false))
+        (case SDL-EVENT-KEY-DOWN
+          (if (== (. event key key) SDLK-ESCAPE)
+              (= running false)))))
+
+    ;; Seconds since the previous frame, so the spin rate does not
+    ;; depend on how fast we happen to be rendering.
+    (var now Uint64 (SDL-GetTicks))
+    (var dt float (/ (cast (- now last-ticks) float) 1000.0))
+    (= last-ticks now)
+
+    (var mouse-x float 0.0)
+    (var mouse-y float 0.0)
+    (var buttons SDL-MouseButtonFlags (SDL-GetMouseState (& mouse-x) (& mouse-y)))
+    (if (!= 0 (& buttons SDL-BUTTON-LMASK))
+        (= angle (+ angle (* SPIN-SPEED dt))))
+
+    ;; The viewport is in pixels, which is not the same as window units
+    ;; on a HiDPI display; the mouse position is in window units, so the
+    ;; shader needs that size rather than the pixel one.
+    (var pixel-width int 0)
+    (var pixel-height int 0)
+    (SDL-GetWindowSizeInPixels window (& pixel-width) (& pixel-height))
+    (glViewport 0 0 pixel-width pixel-height)
+
+    (var window-width int 0)
+    (var window-height int 0)
+    (SDL-GetWindowSize window (& window-width) (& window-height))
+
+    (glClearColor 0.06 0.06 0.09 1.0)
+    (glClear GL-COLOR-BUFFER-BIT)
+
+    (glUseProgram program)
+    (glUniform2f u-center mouse-x mouse-y)
+    (glUniform2f u-viewport (cast window-width float) (cast window-height float))
+    (glUniform1f u-angle angle)
+    (glUniform1f u-radius TRIANGLE-RADIUS)
+
+    (glBindVertexArray vao)
+    (glDrawArrays GL-TRIANGLES 0 3)
+
+    (SDL-GL-SwapWindow window))
+
+  (glDeleteVertexArrays 1 (& vao))
+  (glDeleteBuffers 1 (& vbo))
+  (glDeleteProgram program)
+  (SDL-GL-DestroyContext gl-context)
+  (SDL-DestroyWindow window)
+  (SDL-Quit)
+  (return 0))

example/serialize.sex

@@ -0,0 +1,64 @@
+;;; Generating code from a type's own definition.
+;;;
+;;; `serialize-struct' is handed nothing but a struct's name. It asks
+;;; the compiler's type database what fields that struct has and what
+;;; type each one is, and writes a printer to match. Add a field to the
+;;; struct and the printer grows with it, with no other edit.
+;;;
+;;; The database is filled in as toplevel forms are processed, in order,
+;;; so a struct has to be declared before the macro call that asks about
+;;; it -- the same rule C has.
+
+(include stdio.h)
+
+(defmacro (serialize-struct type-name)
+  ;; map-fields walks the declaration; type-match picks a printf
+  ;; conversion per field. Both come from the compiler's type database,
+  ;; so the macro never takes a type apart itself.
+  (let ((printers
+         (map-fields type-name
+           (lambda (name type)
+             `(fprintf out
+                       ,(string-append
+                         " " (symbol->string name) "="
+                         (type-match type
+                           (int             "%d")
+                           (char            "%c")
+                           (long            "%ld")
+                           (unsigned        "%u")
+                           (float           "%g")
+                           (double          "%g")
+                           ((* const char)  "%s")
+                           ((* char)        "%s")
+                           (else (error "serialize-struct: unsupported field type"
+                                        type-name name type))))
+                       (-> v ,name))))))
+    (if (not printers)
+        (error "serialize-struct: no such struct" type-name)
+        `(pub fn ,(cat 'serialize- type-name)
+              ((v (* const struct ,type-name)) (out (* FILE)))
+              void
+           (fprintf out ,(string-append (symbol->string type-name) " {"))
+           ,@printers
+           (fprintf out " }\n")))))
+
+(struct point ((x int) (y int)))
+
+(struct person
+  ((name (* const char))
+   (age int)
+   (height float)))
+
+;;; Two printers, written by the compiler from the declarations above.
+(serialize-struct point)
+(serialize-struct person)
+
+(pub fn main () int
+  (var origin (struct point) #(0 0))
+  (var corner (struct point) #(640 -480))
+  (var alex (struct person) #("Alex" 34 1.82))
+
+  (serialize-point (& origin) stdout)
+  (serialize-point (& corner) stdout)
+  (serialize-person (& alex) stdout)
+  (return 0))

example/test-list.sex

@@ -2,20 +2,15 @@
 (include stddef.h)
 (include stdio.h)
 
-(chicken-import srfi-1 brev-separate)                 ; list routines, e.g. fold
-
 (import list)
 
-(chicken-define (imports-test a b c)
-  (fold + 0 (list 1 2 3 a b c)))
-
 (struct foo
-  ((float a-field)
-   (int b)
-   ((const char *) c)
-   ((fn bool ((bool val))) not)))
+  ((a-field float)
+   (b int)
+   (c (* const char))
+   (not (fn ((val bool)) bool))))
 
-(var foo f)
+(var f (struct foo))
 
 (list-T int)
 (make-list-T int #f)
@@ -23,27 +18,27 @@
 (length-list-T int #f)
 (is-empty-list-T int #f)
 
-(extern fn void puk ((int a) (float b)))
-(fn int bar () (return ,(imports-test 10 20 30)))
-(pub fn bool baz () (return true))
+(extern fn puk ((a int) (b float)) void)
+(pub fn baz () bool
+  (return true))
 
-(extern var int i)
-(var int j)
-(pub var int k)
+(extern var i int)
+(var j int)
+(pub var k int)
 
-(pub fn int main ()
-     (var (* list-int) l (make-list-int))
+(pub fn main () int
+     (var l (* struct list-int) (make-list-int))
      (printf "Size of the list: %lu\n" (length-list-int l))
      (add-value-list-int l 3)
      (add-value-list-int l 4)
      (printf "Size of the list: %lu\n" (length-list-int l))
-     (list-for-each list-int l int v
+     (list-for-each (struct list-int) l int v
        (printf "%d " v))
      (printf "\n")
      (printf "Size of the list: %lu\n" (length-list-int l))
-     (printf "%p\n" (cast void* l->next))
+     (printf "%p\n" (cast l->next (* void)))
      (return 0))
 
-(pub fn void print-list (((const list-int) *l))
-     (list-for-each (const list-int) l int v (printf "%d " v))
+(pub fn print-list ((l (* const struct list-int))) void
+     (list-for-each (const struct list-int) l int v (printf "%d " v))
      (printf "\n"))

fmt-c-writer.module.scm

@@ -0,0 +1,3 @@
+(module fmt-c-writer (emit-c
+                      sex-line-directives)
+  "fmt-c-writer.scm")

fmt-c-writer.scm

@@ -0,0 +1,479 @@
+;;; Sex fmt-c output writer
+
+(import
+  scheme
+  (scheme base)                         ; make-parameter
+  (chicken base)
+  (chicken string)
+  (chicken syntax)
+  brev-separate                         ; fn, flatten
+  fmt
+  sex-fmt-c
+  matchable
+  (chicken irregex)                     ; unkebabify
+  srfi-1                                ; lists
+  srfi-13                               ; strings
+  utils)
+
+;;; egg `tree' not ported to CHICKEN 6 yet
+(define (tree-map f tree)
+  (cond ((null? tree) (list))
+        ((pair? tree) (cons (tree-map f (car tree))
+                            (tree-map f (cdr tree))))
+        (else (f tree))))
+
+;;; How much #line information to emit:
+;;;
+;;;   statement -- before every statement.
+;;;   toplevel  -- one directive per toplevel form.
+;;;   none      -- none at all, for reading -C output by eye.
+(define sex-line-directives (make-parameter 'statement))
+
+(define (anchor-statements?)
+  (eq? (sex-line-directives) 'statement))
+
+(define (line-directive src)
+  ;; `%line' is fmt-c's #line directive. cpp-line concatenates its
+  ;; second argument verbatim, so the file name arrives already quoted.
+  `(%line ,(cdr src) ,(fmt #f #\" (car src) #\")))
+
+(define (walk-body stmts)
+  "Walk a statement list, re-anchoring each statement that has a known
+source location. Only statement positions may be walked this way: a
+#line inside an expression is a C syntax error."
+  (if (anchor-statements?)
+      (append-map (lambda (s)
+                    (let ((src (form-source s)))
+                      (if src
+                          (list (line-directive src) (walk-expr s))
+                          (list (walk-expr s)))))
+                  (pack-comments stmts))
+      (map walk-expr (pack-comments stmts))))
+
+(define (walk-stmt s)
+  "A statement in a slot that holds exactly one form -- an `if' arm.
+Splicing is not possible there, since c-if reads anything past the arm
+as an `else if' chain, so the anchor and the statement are wrapped in
+`%begin': a statement sequence that emits no braces of its own (the
+surrounding c-block supplies them)."
+  (let ((src (and (pair? s) (anchor-statements?) (form-source s))))
+    (if src
+        `(%begin ,(line-directive src) ,(walk-expr s))
+        (walk-expr s))))
+
+;;; A `;' comment reads as a form, so one written inside a construct
+;;; with positional slots lands in a slot and shifts everything after
+;;; it. So take the positional slots by skipping comments, and hand
+;;; the comments back to be emitted just before the statement
+(define (take-slots forms n)
+  "Three values: the comment forms skipped over, the next N non-comment
+forms, and what remains."
+  (let loop ((fs forms) (n n) (comments (list)) (slots (list)))
+    (cond ((or (= n 0) (null? fs))
+           (values (reverse comments) (reverse slots) fs))
+          ((comment-form? (car fs))
+           (loop (cdr fs) n (cons (car fs) comments) slots))
+          (else
+           (loop (cdr fs) (- n 1) comments (cons (car fs) slots))))))
+
+;;; `%begin' is a statement sequence that emits no braces of its own, so
+;;; the comments simply precede the statement.
+(define (with-comments comments form)
+  (if (null? comments)
+      form
+      `(%begin ,@(map walk-expr comments) ,form)))
+
+(define (walk-if-clauses clauses)
+  "(test stmt test stmt ... [else-stmt]) -- tests stay expressions."
+  (let loop ((cs clauses) (acc (list)))
+    (cond ((null? cs) (reverse acc))
+          ((null? (cdr cs))                    ; trailing else statement
+           (reverse (cons (walk-stmt (car cs)) acc)))
+          (else (loop (cddr cs)
+                      (cons (walk-stmt (cadr cs))
+                            (cons (walk-expr (car cs)) acc)))))))
+
+(define (unkebabify sym)
+  (case sym
+    ((-) sym)
+    ((--) sym)
+    ((->) sym)
+    ((-=) sym)
+    (else
+     (string->symbol
+      (irregex-replace/all "-(?!>)" (symbol->string sym) "_")))))
+
+(define (atom-to-fmt-c atom)
+  (case atom
+    ((fn) '%fun)
+    ((prototype) '%prototype)
+    ((do) '%block-begin)
+    ((define) '%define)
+    ((pointer) '%pointer)
+    ((array) '%array)
+    ((attribute) '%attribute)
+    ((¤) 'vector-ref)
+    ((include) '%include)
+    ;; a `|' inside a symbol has to be escaped to be written in
+    ;; a Scheme source, so we just rename it in fmt-c compatible
+    ;; way
+    ((|\||) 'bit-or)
+    ((|\|\||) '%or)
+    ((|\|=|) 'bit-or=)
+    ;; uh things we do for c89 compatibility
+    ((bool) 'int)
+    ((true) 1)
+    ((false) 0)
+    (else
+     (if (symbol? atom)
+         (unkebabify atom)
+         atom))))
+
+(define (maybe-unwrap-type type)
+  (if (and (list? type)
+           (= 1 (length type)))
+      (car type)
+      type))
+
+;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
+(define (strip-comment-marker text)
+  (string-trim-both (string-trim text #\;)))
+
+(define (walk-comment texts)
+  (list '%comment
+        (string-append " "
+                       (string-intersperse (map strip-comment-marker texts)
+                                           "\n ")
+                       " ")))
+
+;;; Merge multiple lines of /* */ into single block
+(define (pack-comments forms)
+  (let loop ((fs forms) (acc (list)))
+    (cond
+     ((null? fs) (reverse acc))
+     ((comment-form? (car fs))
+      (let ((first (car fs)))
+        (let gather ((rest (cdr fs)) (texts (cdr first)) (line (form-line first)))
+          (if (and (pair? rest)
+                   (comment-form? (car rest))
+                   line
+                   (equal? (form-file first) (form-file (car rest)))
+                   (eqv? (form-line (car rest)) (+ line 1)))
+              (gather (cdr rest)
+                      (append texts (cdr (car rest)))
+                      (form-line (car rest)))
+              (loop rest
+                    (cons (if (eq? texts (cdr first))
+                              first          ; a run of one, left alone
+                              (copy-form-source! first (cons 'comment texts)))
+                          acc))))))
+     (else (loop (cdr fs) (cons (car fs) acc))))))
+
+(define (walk-generic-toplevel form)
+  (cond ((atom? form) (atom-to-fmt-c form))
+        ((list? form) (map walk-generic-toplevel form))
+        (else (sex-error form "malformed form" form))))
+
+(define (walk-expr form)
+  (match form
+    ((? vector?)
+     (list->vector
+      (walk-expr (vector->list form))))
+    ((? atom?)
+     (atom-to-fmt-c form))
+    ;; (comment "text") -> /* text */. `%comment' is the fmt-c directive.
+    (('comment . text) (walk-comment text))
+    ;; (dot-access obj field ...) -> obj.field... member access. `%.'
+    ;; is the fmt-c directive for the `.' operator (see sex-fmt-c).
+    (('dot-access . rest) (cons '%. (map walk-expr rest)))
+    (('var . _) (walk-var form))
+    ;; An expression has no room for a statement, so a comment in a
+    ;; cast is dropped rather than relocated.
+    (('cast . rest)
+     (let-values (((comments slots _) (take-slots rest 2)))
+       (list '%cast (walk-type (cadr slots)) (walk-expr (car slots)))))
+    (('enum . _) (walk-enum form))
+    (('c-or . rest) (apply c-or (map walk-expr rest)))
+    (('c-bit-or . rest) (apply c-bit-or (map walk-expr rest)))
+    (('c-bit-or= . rest) (apply c-bit-or= (map walk-expr rest)))
+
+    ;; Statement positions. These are the only places a #line may go,
+    ;; and each is spliced or wrapped according to what the
+    ;; corresponding fmt-c procedure accepts.
+    (('do . stmts) (cons '%block-begin (walk-body stmts)))
+    (('if . clauses)
+     (with-comments (filter comment-form? clauses)
+       (cons 'if (walk-if-clauses (remove comment-form? clauses)))))
+    (('while . rest)
+     (let-values (((comments slots body) (take-slots rest 1)))
+       (with-comments comments
+         (cons* 'while (walk-expr (car slots)) (walk-body body)))))
+    (('for . rest)
+     (let-values (((comments slots body) (take-slots rest 3)))
+       (with-comments comments
+         (cons* 'for (walk-expr (car slots)) (walk-expr (cadr slots))
+                (walk-expr (caddr slots))
+                (walk-body body)))))
+    ;; No anchor *between* switch clauses: c-switch requires every clause
+    ;; to be a case/default form and errors on anything else. The clause
+    ;; bodies are anchored from inside, which is what a debugger steps
+    ;; onto -- a `case' label is not a statement.
+    ;; A comment between clauses has to go too: c-switch requires every
+    ;; clause to be a case/default form and errors on anything else.
+    (('switch . rest)
+     (let-values (((comments slots clauses) (take-slots rest 1)))
+       (with-comments (append comments (filter comment-form? clauses))
+         (cons* 'switch (walk-expr (car slots))
+                (map walk-expr (remove comment-form? clauses))))))
+    (('case . rest)
+     (let-values (((comments slots body) (take-slots rest 1)))
+       (with-comments comments
+         (cons* 'case (walk-expr (car slots)) (walk-body body)))))
+    (('case/fallthrough . rest)
+     (let-values (((comments slots body) (take-slots rest 1)))
+       (with-comments comments
+         (cons* 'case/fallthrough (walk-expr (car slots)) (walk-body body)))))
+    (('default . body) (cons 'default (walk-body body)))
+
+    ;; Drop comments so they will not generate additional comma
+    (else (map walk-expr (remove comment-form? form)))))
+
+(define (walk-var form)
+  ;; (var a int) -> (%var int a)
+  ;; (var a (const int) 32) -> (%var (const int) a 32)
+  ;; (var b [const char 512]) -> (%var (%array (const char) 512) b)
+  ;; note: [...] is actually (¤ ...) after reading
+  ;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c)
+  ;; Likewise a declaration: drop any comment rather than shift the
+  ;; name and type apart.
+  (let ((form (cons (car form) (remove comment-form? (cdr form)))))
+    `(%var
+      ,(walk-type (third form))
+      ,(atom-to-fmt-c (second form))
+      .
+      ,(if (null? (drop form 3))
+           (list)
+           (walk-expr (drop form 3)))))) ; optional init expression
+
+(define (walk-type form)
+  ;; int -> int
+  ;; (const int) -> const int
+  ;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512)
+  ;; [float 8] -> (%array float 8)
+  ;; (* const char) -> (const char *)
+  ;; (const * const * const char) -> (const char * const * const)
+  ;; (fn ((int) (float)) void) -> (%fun void ((int) (float)))
+  (match form
+    (('¤ . array-type)
+     (if (integer? (last array-type))
+         ;; sized array
+         (let* ((type-list (drop-right array-type 1))
+                (type (maybe-unwrap-type type-list))
+                (size (last array-type)))
+           `(%array ,(walk-type type)
+                    ,size))
+         ;; sugar for pointer... Do we really need it? Guess why not,
+         ;; it's a strong semantic cue
+         `(%array ,(walk-type (maybe-unwrap-type array-type)))))
+    (('fn arglist ret-type)
+     `(%fun ,(walk-type ret-type) ,(walk-arg-types arglist)))
+    (('fn . _)
+     (sex-error form "malformed function type" form))
+
+    ;; Special case: nested structs/unions
+    ((or ('struct . _)
+         ('union . _)) (walk-struct form))
+
+    (('enum . _) (walk-enum form))
+    (else
+     (type-convert-to-c form))))
+
+;;; An array or a function type
+(define (structured-type? form)
+  (and (pair? form) (memq (car form) '(¤ fn))))
+
+(define (has-pointer-star? form)
+  (and (pair? form)
+       (not (structured-type? form))
+       (or (memq '* form)
+           (any has-pointer-star? (filter pair? form)))))
+
+;;; A `*' inside a sublist. Pointer chains are written flat -- (* * T),
+;;; never (* (* T))
+;;; Sublists that merely group, like (* (const struct suc)), contain
+;;; no `*' and are fine.
+(define (nested-pointer? type)
+  (and (pair? type)
+       (any has-pointer-star? (filter pair? type))))
+
+(define (nested-structured-type type)
+  (and (pair? type)
+       (find structured-type? (filter pair? type))))
+
+(define (type-convert-to-c type)
+  ;; Our pointers to C pointers
+  ;; int -> int
+  ;; * const char -> const char *
+  ;; const * const char -> const char * const
+  (when (nested-pointer? type)
+    (sex-error type "pointer chains are written flat, as (* * T), not nested" type))
+  (let ((inner (nested-structured-type type)))
+    (when inner
+      (if (eq? (car inner) 'fn)
+          ;; (fn ...) is spelled as the pointer it already is in C
+          (sex-error type "a fn type is a function pointer already: write (fn ...), not (* (fn ...))" type)
+          (sex-error type "a pointer to an array is not supported" type))))
+  (if (atom? type) (atom-to-fmt-c type)
+      (flatten
+       (tree-map atom-to-fmt-c
+                 (flatten
+                  (list-join (reverse (list-split type '*))
+                             '(*)))))))
+
+(define (walk-fn-def form)
+  (match form
+    (('fn name args ret-type . maybe-body)
+     `(%fun
+       ,(walk-type ret-type)
+       ,(atom-to-fmt-c name)
+       ,(walk-arglist args)
+       .
+       ,(walk-body maybe-body)))))
+
+;;; TODO: isn't there a better way?
+(define (is-probably-type form)
+  (case (car form)
+    ((¤ * const volatile struct union) #t)
+    (else #f)))
+
+;;; Does the parameter name itself?
+;;; (f1 float) does
+;;; (float), (const char) and (¤ float 4) do not
+(define (named-arg? arg)
+  (and (pair? arg)
+       (pair? (cdr arg))                ; 1 element args are always type
+       (not (eq? (car arg) '¤))
+       (not (is-probably-type arg))))
+
+;;; The type of one parameter
+(define (arg-type arg)
+  (if (named-arg? arg)
+      (walk-type (maybe-unwrap-type (cdr arg)))
+      ;; A lone type may arrive wrapped in parens of its own, and those
+      ;; are not part of it: ((* const char))
+      ;; Plain names e.g. (int) are left as is
+      (walk-type (if (and (pair? arg) (null? (cdr arg)) (pair? (car arg)))
+                     (car arg)
+                     arg))))
+
+(define (walk-arglist form)
+  ;; E.g.:
+  ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
+  ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
+  (map (lambda (arg)
+         (if (named-arg? arg)
+             (list (arg-type arg) (walk-type (car arg)))
+             (arg-type arg)))
+       (remove comment-form? form)))
+
+(define (walk-arg-types form)
+  (map arg-type (remove comment-form? form)))
+
+(define (walk-function form)
+  ;; (fn ret-type name arglist body) -> normal function
+  ;; (fn ret-type name arglist) -> prototype
+  (if (>= (length form) 5)
+      (walk-fn-def form)
+      (cons '%prototype (cdr (walk-fn-def form)))))
+
+(define (process-struct-fields fields)
+  (map (fn
+        (let ((type (walk-type (last x))))
+          (cons type (map atom-to-fmt-c (drop-right x 1)))))
+       (remove comment-form? fields)))
+
+(define (walk-struct form)
+  (match form
+    ((type (fields ...) . attrs)        ; anonymous struct
+     `(,type ,(process-struct-fields fields)
+             . ,(tree-map atom-to-fmt-c attrs)))
+    ((type name)                        ; simple 'struct whatever', like in variable def
+     `(,type ,(atom-to-fmt-c name)))
+    ((type name (fields ...) . attrs)
+     `(,type ,(atom-to-fmt-c name)
+             ,(process-struct-fields fields)
+             . ,(tree-map atom-to-fmt-c attrs)))
+    (else (sex-error form "malformed aggregate definition" form))))
+
+(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))))
+
+(define (walk-extern form)
+  (match form
+    (('fn . _)
+     ;; extern function?.. What
+     (list 'extern (walk-function form)))
+    (('var . _)
+     (list 'extern (walk-var form)))
+    (else (sex-error form "extern must be followed by fn or var" form))))
+
+(define (walk-public form)
+  (match form
+    (('fn . _)
+     (walk-function form))
+    (('var . _)
+     (walk-var form))
+    ((or ('define . _)
+         ('defmacro . _)
+
+         ('import . _)
+         ('include . _)
+
+         ('struct . _)
+         ('union . _)
+         ('enum . _)
+
+         ('typedef . _))
+     ;; ignore here, used in generating public interface
+     (process-toplevel-form form))
+    (else
+     (sex-error form "pub must be followed by a definition" form))))
+
+(define (process-toplevel-form form)
+  (match form
+    (('comment . text) (walk-comment text))
+    (('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)))
+    ((or ('struct . _)
+         ('union . _)) (walk-struct form))
+    (('enum . _) (walk-enum form))
+    (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
+    (else (walk-expr form))))
+
+(define (emit-c sex-forms)
+  (for-each (lambda (form)
+              ;; Forms the reader did not produce -- the prelude, and
+              ;; anything a macro built that we could not attribute --
+              ;; have no location and get no directive.
+              (let ((src (and (not (eq? (sex-line-directives) 'none))
+                              (form-source form))))
+                (when src
+                  (fmt #t (c-expr (line-directive src)))))
+              (fmt #t (c-expr (process-toplevel-form form)) nl))
+            (pack-comments sex-forms)))

fmt-c.scm

@@ -1,919 +0,0 @@
-;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code
-;;
-;; Copyright (c) 2007 Alex Shinn.  All rights reserved.
-;; BSD-style license: http://synthcode.com/license.txt
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; additional state information
-
-(declare (unit fmt-c))
-
-(import fmt
-        srfi-13)
-
-(define (fmt-in-macro? st) (fmt-ref st 'in-macro?))
-(define (fmt-macro-params st) (fmt-ref st 'macro-params))
-(define (fmt-expression? st) (fmt-ref st 'expression?))
-(define (fmt-return? st) (fmt-ref st 'return?))
-(define (fmt-newline-before-brace? st) (fmt-ref st 'newline-before-brace?))
-(define (fmt-braceless-bodies? st) (fmt-ref st 'braceless-bodies?))
-(define (fmt-non-spaced-ops? st) (fmt-ref st 'non-spaced-ops?))
-(define (fmt-no-wrap? st) (fmt-ref st 'no-wrap?))
-(define (fmt-indent-space st) (fmt-ref st 'indent-space))
-(define (fmt-switch-indent-space st) (fmt-ref st 'switch-indent-space))
-(define (fmt-op st) (fmt-ref st 'op 'stmt))
-(define (fmt-gen st) (fmt-ref st 'gen))
-
-(define (c-in-expr proc) (fmt-let 'expression? #t proc))
-(define (c-in-stmt proc) (fmt-let 'expression? #f proc))
-(define (c-reset-newline proc) (fmt-let 'newline-before-brace? #f proc))
-
-(define (c-in-test proc) (fmt-let 'in-cond? #t (c-in-expr proc)))
-(define (c-with-op op proc) (fmt-let 'op op proc))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; be smart about operator precedence
-
-(define (c-op-precedence x)
-  (if (string? x)
-      (cond
-        ((or (string=? x ".") (string=? x "->")) 10)
-        ((or (string=? x "++") (string=? x "--")) 20)
-        ((string=? x "&") 55)
-        ((string=? x "|") 65)
-        ((string=? x "&&") 70)
-        ((string=? x "||") 75)
-        ((string=? x "|=") 85)
-        ((or (string=? x "+=") (string=? x "-=")) 85)
-        (else 95))
-      (case x
-        ;;((|::|) 5) ; C++
-        ((dot arrow post-decrement post-increment) 10)
-        ((**) 15)                       ; Perl
-        ((unary+ unary- ! ~ cast unary-* unary-& sizeof) 20) ; ++ --
-        ((=~ !~) 25)                    ; Perl
-        ((* / %) 30)
-        ((+ -) 35)
-        ((<< >>) 40)
-        ((< > <= >=) 45)
-        ((lt gt le ge) 45)              ; Perl
-        ((== !=) 50)
-        ((eq ne cmp) 50)                ; Perl
-        ((&) 55)
-        ((^) 60)
-        ;;((|\||) 65)
-        ((&& %and) 70)
-        ((%or) 75)
-        ;;((|\|\||) 75)
-        ;;((.. ...) 77)                   ; Perl
-        ((?) 80)
-        ((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ;  += -=
-        ((comma) 90)
-        ((=>) 90)                       ; Perl
-        ((not) 92)                      ; Perl
-        ((and) 93)                      ; Perl
-        ((or xor) 94)                   ; Perl
-        ((paren bracket) 100)
-        (else 95))))
-
-(define (c-op< x y) (< (c-op-precedence x) (c-op-precedence y)))
-(define (c-op<= x y) (<= (c-op-precedence x) (c-op-precedence y)))
-
-(define (c-paren x) (cat "(" (c-expr x) ")"))
-
-(define (c-maybe-paren op x)
-  (lambda (st)
-    ((fmt-let 'op op
-              (if (c-op<= (fmt-op st) op)
-                  (c-paren x)
-                  x))
-     st)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; default literals writer
-
-(define (c-control-operator? x)
-  (memq x '(if while switch repeat do for fun begin)))
-
-(define (c-literal? x)
-  (or (number? x) (string? x) (char? x) (boolean? x)))
-
-(define (char->c-char c)
-  (string-append "'" (c-escape-char c #\') "'"))
-
-(define (c-escape-char c quote-char)
-  (let ((n (char->integer c)))
-    (if (<= 32 n 126)
-        (if (or (eqv? c quote-char) (eqv? c #\\))
-            (string #\\ c)
-            (string c))
-        (case n
-          ((7) "\\a") ((8) "\\b") ((9) "\\t") ((10) "\\n")
-          ((11) "\\v") ((12) "\\f") ((13) "\\r")
-          (else (string-append "\\x" (number->string (char->integer c) 16)))))))
-
-(define (c-format-number x)
-  (if (and (integer? x) (exact? x))
-      (lambda (st)
-        ((case (fmt-radix st)
-           ((16) (cat "0x" (string-upcase (number->string x 16))))
-           ((8) (cat "0" (number->string x 8)))
-           (else (dsp (number->string x))))
-         st))
-      (dsp (number->string x))))
-
-(define (c-format-string x)
-  (lambda (st) ((cat #\" (apply-cat (c-string-escaped x)) #\") st)))
-
-(define (c-string-escaped x)
-  (let loop ((parts '()) (idx (string-length x)))
-    (cond ((string-index-right x c-needs-string-escape? 0 idx)
-           => (lambda (special-idx)
-                (loop (cons (c-escape-char (string-ref x special-idx) #\")
-                            (cons (substring/shared x (+ special-idx 1) idx)
-                                  parts))
-                      special-idx)))
-          (else
-           (cons (substring/shared x 0 idx) parts)))))
-
-(define (c-needs-string-escape? c)
-  (if (<= 32 (char->integer c) 127) (memv c '(#\" #\\)) #t))
-
-(define (c-simple-literal x)
-  (c-wrap-stmt
-   (cond ((char? x) (dsp (char->c-char x)))
-         ((boolean? x) (dsp (if x "1" "0")))
-         ((number? x) (c-format-number x))
-         ((string? x) (c-format-string x))
-         ((null? x) (dsp "NULL"))
-         ((eof-object? x) (dsp "EOF"))
-         (else (dsp (write-to-string x))))))
-
-(define (c-literal x)
-  (lambda (st)
-    ((if (and (symbol? x) (memq x (or (fmt-macro-params st) '())))
-         (c-paren (c-simple-literal x))
-         (c-simple-literal x))
-     st)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; default expression generator
-
-(define (c-expr/sexp x)
-  (if (procedure? x)
-      x
-      (lambda (st)
-        (cond
-         ((pair? x)
-          (case (car x)
-            ((if) ((apply c-if (cdr x)) st))
-            ((for) ((apply c-for (cdr x)) st))
-            ((while) ((apply c-while (cdr x)) st))
-            ((switch) ((apply c-switch (cdr x)) st))
-            ((case) ((apply c-case (cdr x)) st))
-            ((case/fallthrough) ((apply c-case/fallthrough (cdr x)) st))
-            ((default) ((apply c-default (cdr x)) st))
-            ((break) (c-break st))
-            ((continue) (c-continue st))
-            ((return) ((apply c-return (cdr x)) st))
-            ((goto) ((apply c-goto (cdr x)) st))
-            ((typedef) ((apply c-typedef (cdr x)) st))
-            ((struct union class) ((apply c-struct/aux x) st))
-            ((enum) ((apply c-enum (cdr x)) st))
-            ((inline auto restrict register volatile extern static)
-             ((cat (car x) " " (apply c-begin (cdr x))) st))
-            ;; non C-keywords must have some character invalid in a C
-            ;; identifier to avoid conflicts - by default we prefix %
-            ((vector-ref)
-             ((c-wrap-stmt
-               (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
-              st))
-            ((vector-set!)
-             ((c= (c-in-expr
-                   (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
-                  (c-expr (cadddr x)))
-              st))
-            ((extern/C) ((apply c-extern/C (cdr x)) st))
-            ((%apply) ((apply c-apply (cdr x)) st))
-            ((%define) ((apply cpp-define (cdr x)) st))
-            ((%include) ((apply cpp-include (cdr x)) st))
-            ((%fun) ((apply c-fun (cdr x)) st))
-            ((%cond)
-             (let lp ((ls (cdr x)) (res '()))
-               (if (null? ls)
-                   ((apply c-if (reverse res)) st)
-                   (lp (cdr ls)
-                       (cons (if (pair? (cddar ls))
-                                 (apply c-begin (cdar ls))
-                                 (cadar ls))
-                             (cons (caar ls) res))))))
-            ((%prototype) ((apply c-prototype (cdr x)) st))
-            ((%var) ((apply c-var (cdr x)) st))
-            ((%begin) ((apply c-begin (cdr x)) st))
-            ((%attribute) ((apply c-attribute (cdr x)) st))
-            ((%line) ((apply cpp-line (cdr x)) st))
-            ((%pragma %error %warning)
-             ((apply cpp-generic (substring/shared (symbol->string (car x)) 1)
-                     (cdr x)) st))
-            ((%if %ifdef %ifndef %elif)
-             ((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1)
-                     (cdr x)) st))
-            ((%endif) ((apply cpp-endif (cdr x)) st))
-            ((%block-begin) ((apply c-braced-block #f (cdr x)) st))
-            ((%block) ((apply c-braced-block (cdr x)) st))
-            ((%comment) ((apply c-comment (cdr x)) st))
-            ((:) ((apply c-label (cdr x)) st))
-            ((%cast) ((apply c-cast (cdr x)) st))
-            ((+ - & * / % ! ~ ^ && < > <= >= == != << >>
-                = *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
-             ((apply c-op x) st))
-            ((bitwise-and bit-and) ((apply c-op '& (cdr x)) st))
-            ((bitwise-ior bit-or) ((apply c-op "|" (cdr x)) st))
-            ((bitwise-xor bit-xor) ((apply c-op '^ (cdr x)) st))
-            ((bitwise-not bit-not) ((apply c-op '~ (cdr x)) st))
-            ((arithmetic-shift) ((apply c-op '<< (cdr x)) st))
-            ((bitwise-ior= bit-or=) ((apply c-op "|=" (cdr x)) st))
-            ((%and) ((apply c-op "&&" (cdr x)) st))
-            ((%or) ((apply c-op "||" (cdr x)) st))
-            ((%. %field) ((apply c-op "." (cdr x)) st))
-            ((%->) ((apply c-op "->" (cdr x)) st))
-            (else
-             (cond
-              ((eq? (car x) (string->symbol "."))
-               ((apply c-op "." (cdr x)) st))
-              ((eq? (car x) (string->symbol "->"))
-               ((apply c-op "->" (cdr x)) st))
-              ((eq? (car x) (string->symbol "++"))
-               ((apply c-op "++" (cdr x)) st))
-              ((eq? (car x) (string->symbol "--"))
-               ((apply c-op "--" (cdr x)) st))
-              ((eq? (car x) (string->symbol "+="))
-               ((apply c-op "+=" (cdr x)) st))
-              ((eq? (car x) (string->symbol "-="))
-               ((apply c-op "-=" (cdr x)) st))
-              (else ((c-apply x) st))))))
-         ((vector? x)
-          ((c-wrap-stmt
-            (fmt-try-fit
-             (fmt-let 'no-wrap? #t
-                      (cat "{" (fmt-join c-expr (vector->list x) ", ") "}"))
-             (lambda (st)
-               (let* ((col (fmt-col st))
-                      (sep (string-append "," (make-nl-space col))))
-                 ((cat "{" (fmt-join c-expr (vector->list x) sep)
-                       "}" nl)
-                  st)))))
-           st))
-         (else
-          ((c-literal x) st))))))
-
-(define (c-apply ls)
-  (c-wrap-stmt
-   (c-with-op
-    'paren
-    (cat (c-expr (car ls))
-         (let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", "))))
-           (fmt-if
-            fmt-no-wrap?
-            (c-paren flat)
-            (c-paren
-             (fmt-try-fit
-              flat
-              (lambda (st)
-                (let* ((col (fmt-col st))
-                       (sep (string-append "," (make-nl-space col))))
-                  ((fmt-join c-expr (cdr ls) sep) st)))))))))))
-
-(define (c-expr x)
-  (lambda (st) (((or (fmt-gen st) c-expr/sexp) x) st)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; comments, with Emacs-friendly escaping of nested comments
-
-(define (make-comment-writer st)
-  (let ((output (fmt-ref st 'writer)))
-    (lambda (str st)
-      (let ((lim (- (string-length str) 1)))
-        (let lp ((i 0) (st st))
-          (let ((j (string-index str #\/ i)))
-            (if j
-                (let ((st (if (and (> j 0)
-                                   (eqv? #\* (string-ref str (- j 1))))
-                              (output
-                               "\\/"
-                               (output (substring/shared str i j) st))
-                              (output (substring/shared str i (+ j 1)) st))))
-                  (lp (+ j 1)
-                      (if (and (< j lim) (eqv? #\* (string-ref str (+ j 1))))
-                          (output "\\" st)
-                          st)))
-                (output (substring/shared str i) st))))))))
-
-(define (c-comment . args)
-  (lambda (st)
-    ((cat "/*" (fmt-let 'writer (make-comment-writer st)
-                        (apply-cat args))
-          "*/")
-     st)))
-
-(define (make-block-comment-writer st)
-  (let ((output (make-comment-writer st))
-        (indent (string-append (make-nl-space (+ (fmt-col st) 1)) "* ")))
-    (lambda (str st)
-      (let ((lim (string-length str)))
-        (let lp ((i 0) (st st))
-          (let ((j (string-index str #\newline i)))
-            (if j
-                (lp (+ j 1)
-                    (output indent (output (substring/shared str i j) st)))
-                (output (substring/shared str i) st))))))))
-
-(define (c-block-comment . args)
-  (lambda (st)
-    (let ((col (fmt-col st))
-          (row (fmt-row st))
-          (indent (c-current-indent-string st)))
-      ((cat "/* "
-            (fmt-let 'writer (make-block-comment-writer st) (apply-cat args))
-            (lambda (st)
-              (cond
-                ((= row (fmt-row st)) ((dsp " */") st))
-                ;;((= (+ 3 col) (fmt-col st)) ((dsp "*/") st))
-                (else ((cat fl indent " */") st)))))
-       st))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; preprocessor
-
-(define (make-cpp-writer st)
-  (let ((output (fmt-ref st 'writer)))
-    (lambda (str st)
-      (let lp ((i 0) (st st))
-        (let ((j (string-index str #\newline i)))
-          (if j
-              (lp (+ j 1)
-                  (output
-                   nl-str
-                   (output " \\" (output (substring/shared str i j) st))))
-              (output (substring/shared str i) st)))))))
-
-(define (cpp-include file)
-  (if (string? file)
-      (cat fl "#include " (wrt file) fl)
-      (cat fl "#include <" file ">" fl)))
-
-(define (list-dot x)
-  (cond ((pair? x) (list-dot (cdr x)))
-        ((null? x) #f)
-        (else x)))
-
-(define (flatten-list ls)
-  (let lp ((ls ls) (res '()))
-    (cond ((pair? ls) (lp (cdr ls) (cons (car ls) res)))
-          ((null? ls) (reverse res))
-          (else (reverse (cons ls res))))))
-
-(define (replace-tree from to x)
-  (let replace ((x x))
-    (cond ((eq? x from) to)
-          ((pair? x) (cons (replace (car x)) (replace (cdr x))))
-          (else x))))
-
-(define (cpp-define x . body)
-  (define (name-of x) (c-expr (if (pair? x) (cadr x) x)))
-  (lambda (st)
-    (let* ((body (cond
-                   ((and (pair? x) (list-dot x))
-                    => (lambda (dot)
-                         (if (eq? dot '...)
-                             body
-                             (replace-tree dot '__VA_ARGS__ body))))
-                   (else body)))
-           (params (map (lambda (x) (if (pair? x) (cadr x) x))
-                        (flatten-list (if (pair? x) (cdr x) '()))))
-           (tail
-            (if (pair? body)
-                (cat " "
-                     (fmt-let 'writer (make-cpp-writer st)
-                              (fmt-let 'macro-params params
-                                       ((if (or (not (pair? x))
-                                                (and (null? (cdr body))
-                                                     (c-literal? (car body))))
-                                            (lambda (x) x)
-                                            c-paren)
-                                        (c-in-expr (apply c-begin body))))))
-                (lambda (x) x))))
-      ((c-in-expr
-        (if (pair? x)
-            (cat fl "#define " (name-of (car x))
-                 (c-paren
-                  (fmt-join/dot name-of
-                                (lambda (dot) (dsp "..."))
-                                (cdr x)
-                                ", "))
-                 tail fl)
-            (cat fl "#define " (c-expr x) tail fl)))
-       st))))
-
-(define (cpp-expr x)
-  (if (or (symbol? x) (string? x)) (dsp x) (c-expr x)))
-
-(define (cpp-if/aux name check . o)
-  (let* ((pass (and (pair? o) (car o)))
-         (comment (if (member name '("ifdef" "ifndef"))
-                      (cat "  "
-                           (c-comment
-                            " " (if (equal? name "ifndef") "! " "")
-                            check " "))
-                      ""))
-         (endif (if pass (cat fl "#endif" comment) ""))
-         (tail (cond
-                ((and (pair? o) (pair? (cdr o)))
-                 (if (pair? (cddr o))
-                     (apply cpp-elif (cdr o))
-                     (cat (cpp-else) (cadr o) endif)))
-                (else endif))))
-    (lambda (st)
-      (let ((indent (c-current-indent-string st)))
-        ((cat fl "#" name " " (cpp-expr check) fl
-              (if pass (cat indent pass) "") fl
-              tail fl)
-         st)))))
-
-(define (cpp-if check . o)
-  (apply cpp-if/aux "if" check o))
-(define (cpp-ifdef check . o)
-  (apply cpp-if/aux "ifdef" check o))
-(define (cpp-ifndef check . o)
-  (apply cpp-if/aux "ifndef" check o))
-(define (cpp-elif check . o)
-  (apply cpp-if/aux "elif" check o))
-(define (cpp-else . o)
-  (cat fl "#else " (if (pair? o) (c-comment (car o)) "") fl))
-(define (cpp-endif . o)
-  (cat fl "#endif " (if (pair? o) (c-comment (car o)) "") fl))
-
-(define (cpp-wrap-header name . body)
-  (let ((name name)) ; consider auto-mangling
-    (cpp-ifndef name (c-begin (cpp-define name) nl (apply c-begin body) nl))))
-
-(define (cpp-line num . o)
-  (cat fl "#line " num (if (pair? o) (cat " " (car o)) "") fl))
-
-(define (cpp-generic name . ls)
-  (cat fl "#" name (apply-cat ls) fl))
-
-(define (cpp-undef . args) (apply cpp-generic "undef" args))
-(define (cpp-pragma . args) (apply cpp-generic "pragma" args))
-(define (cpp-error . args) (apply cpp-generic "error" args))
-(define (cpp-warning . args) (apply cpp-generic "warning" args))
-
-(define (cpp-stringify x)
-  (cat "#" x))
-
-(define (cpp-sym-cat . args)
-  (fmt-join dsp args " ## "))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; general indentation and brace rules
-
-(define (c-current-indent-string st . o)
-  (make-space (max 0 (+ (fmt-col st) (if (pair? o) (car o) 0)))))
-
-(define (c-indent st . o)
-  (dsp (make-space (max 0 (+ (fmt-col st) (or (fmt-indent-space st) 4)
-                             (if (pair? o) (car o) 0))))))
-
-(define (c-indent/switch st)
-  (dsp (make-space (+ (fmt-col st) (or (fmt-switch-indent-space st) 4)))))
-
-(define (c-open-brace st)
-  (if (fmt-newline-before-brace? st)
-      (begin
-        (fmt-set! st 'newline-before-brace? #t)
-        (cat "{" nl))
-      (begin
-        (fmt-set! st 'newline-before-brace? #t)
-        (cat " {" nl))))
-
-(define (c-close-brace st)
-  (dsp "}"))
-
-(define (c-wrap-stmt x)
-  (fmt-if fmt-expression?
-          (c-expr x)
-          (cat (c-in-expr (c-expr x)) ";" nl)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; code blocks
-
-(define (c-block . args)
-  (apply c-block/aux 0 args))
-
-(define (c-block/aux offset header body0 . body)
-   (let ((inner (apply c-begin body0 body)))
-     (if (or (pair? body)
-             (not (or (c-literal? body0)
-                      (and (pair? body0)
-                           (not (c-control-operator? (car body0)))))))
-         (c-braced-block/aux offset header inner)
-         (lambda (st)
-           (if (fmt-braceless-bodies? st)
-               ((cat header fl (c-indent st offset) inner fl) st)
-               ((c-braced-block/aux offset header inner) st))))))
-
-(define (c-braced-block . args)
-  (apply c-braced-block/aux 0 args))
-
-(define (c-braced-block/aux offset header . body)
-   (lambda (st)
-     ((cat (if header header "") (c-open-brace st) (c-indent st offset)
-           (apply c-begin body) fl
-           (c-current-indent-string st offset) (c-close-brace st))
-      st)))
-
-(define (c-begin . args)
-  (apply c-begin/aux #f args))
-
-(define (c-begin/aux ret? body0 . body)
-   (if (null? body)
-       (c-expr body0)
-       (lambda (st)
-         (if (fmt-expression? st)
-             ((fmt-try-fit
-               (fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", "))
-               (lambda (st)
-                 (let ((indent (c-current-indent-string st)))
-                   ((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st))))
-              st)
-             (let ((orig-ret? (fmt-return? st)))
-               ((fmt-join/last c-expr
-                               (lambda (x) (fmt-let 'return? orig-ret? (c-expr x)))
-                               (cons body0 body)
-                               (cat fl (c-current-indent-string st)))
-                (fmt-set! st 'return? (and ret? orig-ret?))))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; data structures
-
-(define (c-struct/aux type x . o)
-  (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
-         (body (if name (if (not (null? o)) (car o) '()) x))
-         (o (if (null? o) o (cdr o))))
-    (if (not (null? body))
-        (c-wrap-stmt
-         (cat
-          (c-braced-block
-           (cat type (if (and name (not (equal? name ""))) (cat " " name) ""))
-           (cat
-            (c-in-stmt
-             (if (list? body)
-                 (apply c-begin (map c-wrap-stmt (map c-field body)))
-                 (c-wrap-stmt (c-expr body))))))
-          (if (pair? o) (cat " " (apply c-begin o)) (dsp ""))))
-        (c-wrap-stmt
-         (cat type (if (and name (not (equal? name ""))) (cat " " name) ""))))))
-
-(define (c-struct . args) (apply c-struct/aux "struct" args))
-(define (c-union . args) (apply c-struct/aux "union" args))
-(define (c-class . args) (apply c-struct/aux "class" args))
-
-(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 (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 ", ") "))"))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; basic control structures
-
-(define (c-while check . body)
-  (c-reset-newline
-   (cat (c-block (cat "while (" (c-in-test (c-expr check)) ")")
-                 (c-in-stmt (apply c-begin body)))
-        fl)))
-
-(define (c-for init check update . body)
-  (c-reset-newline
-   (cat
-    (c-block
-     (c-in-expr
-      (cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; "
-           (c-expr update ) ")"))
-     (c-in-stmt (apply c-begin body)))
-    fl)))
-
-(define (c-param x)
-  (cond
-    ((procedure? x) x)
-    ((pair? x) (c-type (car x) (cadr x)))
-    (else (error "missing type" x))))
-
-(define (c-field x)
-  (cond
-    ((procedure? x) x)
-    ((pair? x)
-     (if (list? (car x))
-         (case (caar x)
-           ((union struct class)
-            (if (> (length x) 1)
-                (c-type (car x)
-                        (cadr x))
-                (c-type (car x))))
-           (else (c-type (car x) (cadr x))))
-         (c-type (car x)
-                 (fmt-join c-expr (cdr x) ", "))))
-    (else (error "missing type" x))))
-
-(define (c-param-list ls)
-  (if (null? ls)
-      (c-type 'void)
-      (c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", "))))
-
-(define (c-fun type name params . body)
-  (cat (c-block (c-in-expr (c-prototype type name params))
-                (c-in-stmt (apply c-begin body)))
-       fl))
-
-(define (c-prototype type name params . o)
-  (c-wrap-stmt
-   (cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")"
-        (fmt-join/prefix c-expr o " "))))
-
-(define (c-static x) (cat "static " (c-expr x)))
-(define (c-const x) (cat "const " (c-expr x)))
-(define (c-restrict x) (cat "restrict " (c-expr x)))
-(define (c-volatile x) (cat "volatile " (c-expr x)))
-(define (c-auto x) (cat "auto " (c-expr x)))
-(define (c-inline x) (cat "inline " (c-expr x)))
-(define (c-extern x) (cat "extern " (c-expr x)))
-(define (c-extern/C . body)
-  (cat "extern \"C\" {" nl (apply c-begin body) nl "}" nl))
-
-(define (c-type type . o)
-  (let ((name (and (pair? o) (car o))))
-    (cond
-     ((pair? type)
-      (case (car type)
-        ((%fun)
-         (cat (c-type (cadr type) #f)
-              " (*" (or name "") ")("
-              (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
-        ((%array)
-         (let ((name (cat name "[" (if (pair? (cddr type))
-                                       (c-expr (caddr type))
-                                       "")
-                          "]")))
-           (c-type (cadr type) name)))
-        ((%pointer *)
-         (let ((name (cat "*" (if name (c-expr name) ""))))
-           (c-type (cadr type)
-                   (if (and (pair? (cadr type)) (eq? '%array (caadr type)))
-                       (c-paren name)
-                       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 " "))))
-     ((not type)
-      (lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st)))
-     (else
-      (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
-
-(define (c-var type name . init)
-  (c-wrap-stmt
-   (if (pair? init)
-       (cat (c-type type name) " = " (c-expr (car init)))
-       (c-type type (if (pair? name)
-                        (fmt-join c-expr name ", ")
-                        (c-expr name))))))
-
-(define (c-cast type expr)
-  (cat "(" (c-type type) ")" (c-expr expr)))
-
-(define (c-typedef type alias . o)
-  (c-wrap-stmt
-   (cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " "))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Generalized IF: allows multiple tail forms for if/else if/.../else
-;; blocks.  A final ELSE can be signified with a test of #t or 'else,
-;; or by simply using an odd number of expressions (by which the
-;; normal 2 or 3 clause IF forms are special cases).
-
-(define (c-if/stmt c p . rest)
-  (lambda (st)
-    (let ((indent (c-current-indent-string st)))
-      ((let lp ((c c) (p p) (ls rest))
-         (if (or (eq? c 'else) (eq? c #t))
-             (if (not (null? ls))
-                 (error "forms after else clause in IF" c p ls)
-                 (cat (c-block/aux -1 " else" p) fl))
-             (let ((tail (if (pair? ls)
-                             (if (pair? (cdr ls))
-                                 (lp (car ls) (cadr ls) (cddr ls))
-                                 (lp 'else (car ls) '()))
-                             fl)))
-               (cat (c-block/aux
-                     (if (eq? ls rest) 0 -1)
-                     (cat (if (eq? ls rest) (lambda (x) x) " else ")
-                          "if (" (c-in-test (c-expr c)) ")") p)
-                    tail))))
-       st))))
-
-(define (c-if/expr c p . rest)
-  (let lp ((c c) (p p) (ls rest))
-    (cond
-      ((or (eq? c 'else) (eq? c #t))
-       (if (not (null? ls))
-           (error "forms after else clause in IF" c p ls)
-           (c-expr p)))
-      ((pair? ls)
-       (cat (c-in-test (c-expr c)) " ? " (c-expr p) " : "
-            (if (pair? (cdr ls))
-                (lp (car ls) (cadr ls) (cddr ls))
-                (lp 'else (car ls) '()))))
-      (else
-       (c-or (c-in-test (c-expr c)) (c-expr p))))))
-
-(define (c-if . args)
-  (fmt-if fmt-expression?
-          (apply c-if/expr args)
-          (apply c-if/stmt args)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; switch statements, automatic break handling
-
-(define (c-label name)
-  (lambda (st)
-    (let ((indent (make-space (max 0 (- (fmt-col st) 2)))))
-      ((cat fl indent name ":" fl) st))))
-
-(define c-break
-  (c-wrap-stmt (dsp "break")))
-(define c-continue
-  (c-wrap-stmt (dsp "continue")))
-(define (c-return . result)
-  (if (pair? result)
-      (c-wrap-stmt (cat "return " (c-expr (car result))))
-      (c-wrap-stmt (dsp "return"))))
-(define (c-goto label)
-  (c-wrap-stmt (cat "goto " (c-expr label))))
-
-(define (c-switch val . clauses)
-  (c-reset-newline
-   (lambda (st)
-     ((cat "switch (" (c-in-expr val) ")" (c-open-brace st)
-           (c-indent/switch st)
-           (c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl
-           (c-current-indent-string st) (c-close-brace st) fl)
-      st))))
-
-(define (c-switch-clause/breaks x)
-  (lambda (st)
-    (let* ((break?
-            (and (car x)
-                 (not (member (cadr x) '(case/fallthrough
-                                         default/fallthrough
-                                         else/fallthrough)))))
-           (explicit-case? (member (cadr x) '(case case/fallthrough)))
-           (indent (c-current-indent-string st))
-           (indent-body (c-indent st))
-           (sep (string-append ":" nl-str indent)))
-      ((cat (c-in-expr
-             (fmt-join/suffix
-              dsp
-              (cond
-               ((pair? (cadr x))
-                (map (lambda (y) (cat (dsp "case ") (c-expr y)))
-                     (cadr x)))
-               (explicit-case?
-                (map (lambda (y) (cat (dsp "case ") (c-expr y)))
-                     (if (list? (caddr x))
-                         (caddr x)
-                         (list (caddr x)))))
-               ((member (cadr x)
-                        '(default else default/fallthrough else/fallthrough))
-                (list (dsp "default")))
-               (else
-                (error
-                 "unknown switch clause, expected a list or default but got"
-                 (cadr x))))
-              sep))
-            (make-space (or (fmt-indent-space st) 4))
-            (fmt-join c-expr
-                      (if explicit-case? (cdddr x) (cddr x))
-                      indent-body)
-            (if (and break? (not (fmt-return? st)))
-                (cat fl indent-body c-break)
-                ""))
-       st))))
-
-(define (c-switch-clause x)
-  (if (procedure? x) x (c-switch-clause/breaks (cons #t x))))
-(define (c-switch-clause/no-break x)
-  (if (procedure? x) x (c-switch-clause/breaks (cons #f x))))
-
-(define (c-case x . body)
-  (c-switch-clause (cons (if (pair? x) x (list x)) body)))
-(define (c-case/fallthrough x . body)
-  (c-switch-clause/no-break (cons (if (pair? x) x (list x)) body)))
-(define (c-default . body)
-  (c-switch-clause/breaks (cons #t (cons 'else body))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; operators
-
-(define (c-op op first . rest)
-  (if (null? rest)
-      (c-unary-op op first)
-      (apply c-binary-op op first rest)))
-
-(define (c-binary-op op . ls)
-  (define (lit-op? x) (or (c-literal? x) (symbol? x)))
-  (let ((str (display-to-string op)))
-    (c-wrap-stmt
-     (c-maybe-paren
-      op
-      (if (or (equal? str ".") (equal? str "->"))
-          (fmt-join c-expr ls str)
-          (let ((flat
-                 (fmt-let 'no-wrap? #t
-                          (lambda (st)
-                            ((fmt-join c-expr
-                                       ls
-                                       (if (and (fmt-non-spaced-ops? st)
-                                                (every lit-op? ls))
-                                           str
-                                           (string-append " " str " ")))
-                             st)))))
-            (fmt-if
-             fmt-no-wrap?
-             flat
-             (fmt-try-fit
-              flat
-              (lambda (st)
-                   ((fmt-join c-expr
-                              ls
-                              (cat nl (make-space (+ 2 (fmt-col st))) str " "))
-                    st))))))))))
-
-(define (c-unary-op op x)
-  (c-wrap-stmt
-   (cat (display-to-string op) (c-maybe-paren op (c-expr x)))))
-
-;; some convenience definitions
-
-(define (c++ . args) (apply c-op "++" args))
-(define (c-- . args) (apply c-op "--" args))
-(define (c+ . args) (apply c-op '+ args))
-(define (c- . args) (apply c-op '- args))
-(define (c* . args) (apply c-op '* args))
-(define (c/ . args) (apply c-op '/ args))
-(define (c% . args) (apply c-op '% args))
-(define (c& . args) (apply c-op '& args))
-;; (define (|c\|| . args) (apply c-op '|\|| args))
-(define (c^ . args) (apply c-op '^ args))
-(define (c~ . args) (apply c-op '~ args))
-(define (c! . args) (apply c-op '! args))
-(define (c&& . args) (apply c-op '&& args))
-;; (define (|c\|\|| . args) (apply c-op '|\|\|| args))
-(define (c<< . args) (apply c-op '<< args))
-(define (c>> . args) (apply c-op '>> args))
-(define (c== . args) (apply c-op '== args))
-(define (c!= . args) (apply c-op '!= args))
-(define (c< . args) (apply c-op '< args))
-(define (c> . args) (apply c-op '> args))
-(define (c<= . args) (apply c-op '<= args))
-(define (c>= . args) (apply c-op '>= args))
-(define (c= . args) (apply c-op '= args))
-(define (c+= . args) (apply c-op "+=" args))
-(define (c-= . args) (apply c-op "-=" args))
-(define (c*= . args) (apply c-op '*= args))
-(define (c/= . args) (apply c-op '/= args))
-(define (c%= . args) (apply c-op '%= args))
-(define (c&= . args) (apply c-op '&= args))
-;; (define (|c\|=| . args) (apply c-op '|\|=| args))
-(define (c^= . args) (apply c-op '^= args))
-(define (c<<= . args) (apply c-op '<<= args))
-(define (c>>= . args) (apply c-op '>>= args))
-
-(define (c. . args) (apply c-op "." args))
-(define (c-> . args) (apply c-op "->" args))
-
-(define (c-bit-or . args) (apply c-op "|" args))
-(define (c-or . args) (apply c-op "||" args))
-(define (c-bit-or= . args) (apply c-op "|=" args))
-
-(define (c++/post x)
-  (cat (c-maybe-paren 'post-increment (c-expr x)) "++"))
-(define (c--/post x)
-  (cat (c-maybe-paren 'post-decrement (c-expr x)) "--"))

main.scm

@@ -1,6 +1,5 @@
 ;;; The purpose of this file is to compile it to the only
 ;;; .o that has main entry point.
 
-(declare (uses sexc))
-
+(import sexc)
 (main)

reader.module.scm

@@ -0,0 +1,6 @@
+(module reader (read-from-file
+                read-raw-forms
+
+                current-features
+                platform-features)
+  "reader.scm")

reader.scm

@@ -0,0 +1,353 @@
+;;; Sex reader
+;;;
+;;; A hand-written tokenizer + recursive-descent parser that replaces
+;;; CHICKEN's built-in `read'. We need our own reader because the
+;;; features Sex requires cannot be expressed on top of `read':
+;;;   - [ ... ] array/pointer sugar, read as (¤ ...)
+;;;   - 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.
+
+(import
+  scheme
+  (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
+(define close-paren   (list '%close-paren))
+(define close-bracket (list '%close-bracket))
+(define dot-token     (list '%dot))
+
+;;; Current source line. Tracked as characters are consumed
+(define current-line (make-parameter 1))
+
+(define (get-ch port)
+  (let ((c (read-char port)))
+    (when (and (char? c) (char=? c #\newline))
+      (current-line (+ 1 (current-line))))
+    c))
+
+(define (peek port)
+  (peek-char port))
+
+;;; Record where a form started. Called with the line of the opening
+;;; delimiter, sampled before it is consumed
+(define (stamp form line)
+  (when (pair? form)
+    (set-form-source! form (current-source-file) line))
+  form)
+
+(define (delimiter? c)
+  (or (eof-object? c)
+      (char-whitespace? c)
+      (memv c '(#\( #\) #\[ #\] #\" #\; #\' #\` #\,))))
+
+;;; Skip whitespace. `;' comments are NOT skipped here: they are read
+;;; as (comment "...") forms by the tokenizer. Block comments (#| |#)
+;;; and datum comments (#;) are discarded in the tokenizer's `#'
+;;; dispatch, since `#' also introduces real data (#t, #f, #\c, #(...))
+(define (skip-whitespace port)
+  (let ((c (peek port)))
+    (cond
+     ((eof-object? c) #t)
+     ((char-whitespace? c) (get-ch port) (skip-whitespace port))
+     (else #t))))
+
+;;; A `;' comment, read as (comment "<rest of line>"). The leading `;'
+;;; is consumed; the newline is left in the stream so line tracking and
+;;; the surrounding parser see it normally
+(define (read-comment port)
+  (get-ch port)                         ; consume the leading ;
+  (let loop ((chars (list)))
+    (let ((c (peek port)))
+      (if (or (eof-object? c) (char=? c #\newline))
+          (list 'comment (list->string (reverse chars)))
+          (begin (get-ch port)
+                 (loop (cons c chars)))))))
+
+;;; Read the next token: a datum, one of the structural sentinels
+;;; (close-paren / close-bracket / dot-token), or the eof-object
+(define (next-token port)
+  (skip-whitespace port)
+  (let ((c (peek port)))
+    (cond
+     ((eof-object? c) c)
+     ((char=? c #\()
+      (let ((line (current-line)))
+        (get-ch port)
+        (stamp (read-list port close-paren) line)))
+     ((char=? c #\[)
+      (let ((line (current-line)))
+        (get-ch port)
+        (stamp (cons '¤ (read-list port close-bracket)) line)))
+     ((char=? c #\)) (get-ch port) close-paren)
+     ((char=? c #\]) (get-ch port) close-bracket)
+     ((char=? c #\;)
+      (let ((line (current-line)))
+        (stamp (read-comment port) line)))
+     ((char=? c #\") (read-string-lit port))
+     ((char=? c #\') (get-ch port) (list 'quote (read-datum port)))
+     ((char=? c #\`) (get-ch port) (list 'quasiquote (read-datum port)))
+     ((char=? c #\,)
+      (get-ch port)
+      (if (eqv? (peek port) #\@)
+          (begin (get-ch port) (list 'unquote-splicing (read-datum port)))
+          (list 'unquote (read-datum port))))
+     ((char=? c #\#) (get-ch port) (read-hash port))
+     (else (read-atom port)))))
+
+;;; Like next-token, but a full datum is required: the structural
+;;; sentinels and eof are errors here (e.g. after a quote or `.')
+(define (read-datum port)
+  (let ((tok (next-token port)))
+    (cond
+     ((eof-object? tok) (error "Unexpected end of input"))
+     ((eq? tok close-paren) (error "Unexpected )"))
+     ((eq? tok close-bracket) (error "Unexpected ]"))
+     ((eq? tok dot-token) (error "Unexpected ."))
+     (else tok))))
+
+;;; A token that stands for a datum
+(define (datum-token? tok)
+  (not (or (eof-object? tok)
+           (eq? tok close-paren)
+           (eq? tok close-bracket)
+           (eq? tok dot-token))))
+
+;;; next-token, sans the comments
+(define (next-code-token port)
+  (let loop ()
+    (let ((tok (next-token port)))
+      (if (comment-form? tok)
+          (loop)
+          tok))))
+
+;;; Read list elements up to close-paren or close-bracket,
+;;; honoring dotted-pair notation (a b . c)
+(define (read-list port closer)
+  (let loop ((acc (list)))
+    (let ((tok (next-token port)))
+      (cond
+       ((eof-object? tok) (error "Unexpected end of input inside list"))
+       ((eq? tok close-paren)
+        (if (eq? closer close-paren)
+            (reverse acc)
+            (error "Unmatched closing bracket")))
+       ((eq? tok close-bracket)
+        (if (eq? closer close-bracket)
+            (reverse acc)
+            (error "Unmatched closing bracket")))
+       ((eq? tok dot-token)
+        (if (null? acc)
+            ;; Leading `.': the member/method access operator. It reads
+            ;; as an ordinary `dot-access' symbol in first position.
+            (loop (cons 'dot-access acc))
+            ;; Otherwise: ordinary dotted-pair notation (a b . c).
+            (let ((tail (read-datum port))
+                  (end (next-token port)))
+              (unless (eq? end closer)
+                (error "Malformed dotted list"))
+              (append-reverse acc tail))))
+       (else (loop (cons tok acc)))))))
+
+;;; Append the reversed list `rev' in front of `tail', producing a
+;;; possibly-improper list (used for dotted pairs)
+(define (append-reverse rev tail)
+  (if (null? rev)
+      tail
+      (append-reverse (cdr rev) (cons (car rev) tail))))
+
+;;; A bare atom: symbol or number, or the dot token when it is exactly "."
+(define (read-atom port)
+  (let loop ((chars (list)))
+    (let ((c (peek port)))
+      (if (delimiter? c)
+          (finish-atom (list->string (reverse chars)))
+          (begin (get-ch port) (loop (cons c chars)))))))
+
+(define (finish-atom s)
+  (cond
+   ((string=? s ".") dot-token)
+   ((string->number s) => identity)
+   (else (string->symbol s))))
+
+;;; #-dispatch: booleans, characters, vectors, block/datum comments,
+;;; feature expressions
+(define (read-hash port)
+  (let ((c (get-ch port)))
+    (cond
+     ((eof-object? c) (error "Unexpected end of input after #"))
+     ((or (char=? c #\t) (char=? c #\T)) (read-bool port #t))
+     ((or (char=? c #\f) (char=? c #\F)) (read-bool port #f))
+     ((char=? c #\\) (read-char-lit port))
+     ((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. What
+;;; follows a dropped datum is read in its place: `#+x #+y (a) (b)'
+;;; with only x is (b).
+;;;
+;;; That next thing may be nothing: the end of the file, or the
+;;; paren closing the list we are in
+(define (read-conditional port keep-when)
+  (let* ((test (next-code-token port))
+         (keep (begin
+                 (unless (datum-token? test)
+                   (error "Unexpected end of input in feature expression"))
+                 (eq? keep-when (feature-true? test))))
+         (guarded (next-code-token port)))
+    (cond
+     (keep guarded)
+     ;; A datum was dropped, so the next one stands in for it
+     ((datum-token? guarded) (next-token port))
+     (else guarded))))
+
+;;; #t / #true / #f / #false. `val' is the boolean; consume any
+;;; trailing name characters and validate
+(define (read-bool port val)
+  (let ((rest (read-atom-string port)))
+    (cond
+     ((string=? rest "") val)
+     ((and val (string=? rest "rue")) val)
+     ((and (not val) (string=? rest "alse")) val)
+     (else (error "Malformed boolean literal" rest)))))
+
+(define (read-atom-string port)
+  (let loop ((chars (list)))
+    (let ((c (peek port)))
+      (if (delimiter? c)
+          (list->string (reverse chars))
+          (begin (get-ch port) (loop (cons c chars)))))))
+
+(define named-chars
+  '(("space" . #\space) ("newline" . #\newline) ("tab" . #\tab)
+    ("return" . #\return) ("nul" . #\nul) ("null" . #\nul)
+    ("delete" . #\delete) ("escape" . #\escape) ("alarm" . #\alarm)
+    ("backspace" . #\backspace)))
+
+(define (read-char-lit port)
+  (let ((first (get-ch port)))
+    (when (eof-object? first)
+      (error "Unexpected end of input in character literal"))
+    (if (char-alphabetic? first)
+        (let ((rest (read-atom-string port)))
+          (if (string=? rest "")
+              first
+              (let ((name (string-append (string first) rest)))
+                (cond
+                 ((assoc name named-chars) => cdr)
+                 (else (error "Unknown character name" name))))))
+        first)))
+
+;;; String literal with escape processing, matching the common escapes
+;;; the previous reader (CHICKEN `read') interpreted
+(define (read-string-lit port)
+  (get-ch port)                         ; consume opening quote
+  (let loop ((chars (list)))
+    (let ((c (get-ch port)))
+      (cond
+       ((eof-object? c) (error "Unterminated string literal"))
+       ((char=? c #\") (list->string (reverse chars)))
+       ((char=? c #\\) (loop (cons (read-escape port) chars)))
+       (else (loop (cons c chars)))))))
+
+(define (read-escape port)
+  (let ((c (get-ch port)))
+    (cond
+     ((eof-object? c) (error "Unterminated string literal"))
+     ((char=? c #\n) #\newline)
+     ((char=? c #\t) #\tab)
+     ((char=? c #\r) #\return)
+     ((char=? c #\a) #\alarm)
+     ((char=? c #\b) #\backspace)
+     ((char=? c #\f) (integer->char 12))
+     ((char=? c #\v) (integer->char 11))
+     ((char=? c #\0) #\nul)
+     (else c))))                        ; \" \\ and anything else: literal
+
+(define (skip-block-comment port depth)
+  (if (= depth 0)
+      #t
+      (let ((c (get-ch port)))
+        (cond
+         ((eof-object? c) (error "Unterminated block comment"))
+         ((and (char=? c #\|) (eqv? (peek port) #\#))
+          (get-ch port) (skip-block-comment port (- depth 1)))
+         ((and (char=? c #\#) (eqv? (peek port) #\|))
+          (get-ch port) (skip-block-comment port (+ depth 1)))
+         (else (skip-block-comment port depth))))))
+
+;;; Read every top-level form from `port'. Locations are recorded by
+;;; next-token, for every form rather than only these
+(define (parse-all port)
+  (parameterize ((current-line 1))
+    (let loop ((acc (list)))
+      (skip-whitespace port)
+      (let ((tok (next-token port)))
+        (cond
+         ((eof-object? tok) (reverse acc))
+         ((or (eq? tok close-paren)
+              (eq? tok close-bracket))
+          (error "Unmatched closing bracket at top level"))
+         ((eq? tok dot-token)
+          (error "Unexpected . at top level"))
+         (else
+          (loop (cons tok acc))))))))
+
+;;; Entry point: read all forms from a file, or from the current input
+;;; port when the source is 'stdin
+(define (read-from-file file)
+  ;; Resolve the name before with-directory moves us, so an imported
+  ;; module's forms carry that module's path rather than the importer's
+  (let ((source-file (to-absolute-pathname file)))
+    (with-directory file
+      (with-input-from-file (pathname-strip-directory file)
+        (lambda ()
+          (parameterize ((current-source-file source-file))
+            (parse-all (current-input-port))))))))
+
+(define (read-raw-forms input-source)
+  (if (eq? input-source 'stdin)
+      (parameterize ((current-source-file "stdin"))
+        (parse-all (current-input-port)))
+      (read-from-file input-source)))

semen.module.scm

@@ -0,0 +1,2 @@
+(module semen ()
+  "semen.scm")

semen.scm

@@ -0,0 +1,317 @@
+;;; Sex semantic engine
+
+(import
+  scheme
+  (chicken base)
+  (chicken keyword)
+  (chicken string)
+  (chicken module)
+  fmt
+  sex-macros
+  sex-modules
+  types
+  matchable                         ; pattern matching
+  srfi-1                            ; list routines
+  srfi-69                           ; hash tables
+  utils
+  )
+
+(export/rename (process semen-process))
+
+;;; for lambda extraction, docstring processing, macro expansion,
+;;; injection of module headers, i.e. all things that rearrange code
+;;; structurally, add or remove forms
+;;;
+;;; The algorithm: feed toplevel forms to appropriate handlers, then
+;;; append their return to the resulting list. Each handler can return
+;;; multiple forms, e.g. lambdas collected from a function may result
+;;; in auxiliary structures and functions.
+(define (process raw-sex-forms)
+  (process-rec raw-sex-forms (list)))
+
+(define (process-rec forms acc)
+  (cond
+   ((null? forms) (reverse acc))
+   ((macro? (car forms))
+    (process-rec
+     (macroexpand (car forms) (cdr forms))
+     acc))
+   (else
+    (process-rec (cdr forms)
+                 (match-sex-form (car forms) acc)))))
+
+(define (macroexpand macro-form rest-forms)
+  ;; We want to replace macro with its expansion. The problem is,
+  ;; top-level macro can return either a single form, or a list of
+  ;; forms, when it for example generates some aux
+  ;; structures/functions/typedefs.
+  ;;
+  ;; Single form we just cons to the top of rest-forms, but multiple
+  ;; forms have to be appended to the rest-forms.
+  (let ((res (apply-macro macro-form))
+        (src (form-source macro-form)))
+    ;; An expansion is fresh structure with no location of its own. Give
+    ;; it the call site's, the way cpp attributes a macro body to where
+    ;; the macro was used
+    (if (list? (car res))
+        (append (map (lambda (f) (stamp-form-source! f src)) res)
+                rest-forms)
+        (cons (stamp-form-source! res src) rest-forms))))
+
+(define (match-sex-form sex-form acc)
+  (match sex-form
+    ((or ('fn . _)
+         ('pub 'fn . _)
+         ('extern 'fn . _)) (process-fn sex-form acc))
+    ((or ('struct . _)
+         ('pub 'struct . _)) (process-struct sex-form acc))
+    ((or ('union . _)
+         ('pub 'union . _)) (process-struct sex-form acc))
+    ((or ('enum . _)
+         ('pub 'enum . _)) (process-struct sex-form acc))
+    ((or ('var . _)
+         ('pub 'var . _)
+         ('extern 'var . _)) (process-global-var sex-form acc))
+    (('include _) (cons sex-form acc))
+    ((or ('define name . _)
+         ('pub 'define name . _))
+     (add-define name sex-form)
+     (cons sex-form acc))
+    (('comment . _) (cons sex-form acc))
+
+    (('import . modules)
+     (process-imports (get-modules-public-forms modules) acc))
+
+    ((or ('defmacro . rest)
+         ('pub 'defmacro . rest)) (defmacro rest) acc)
+
+    ((or ('typedef new-type target)
+         ('pub 'typedef new-type target))
+     (add-typedef new-type sex-form)
+     (process-typedef sex-form new-type target acc))
+
+    (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))
+
+(define (macro-expand form)
+  "Walk the form recursively and expand all macros, until none is left."
+  (walk-form
+   form
+   (lambda (subform env)
+     (if (macro? subform)
+         (cons walk-embed-result (macroexpand subform (list)))
+         subform))
+   #f))
+
+;;; walk-form and friends: form walker with various abilities.
+;;; By default, replaces walked form with walk-fn result But may
+;;; perform additional operations depending of what the walk function
+;;; has requested.
+
+;;; For inspiration, see SBCL's walk.lisp and their template
+;;; system.
+
+(define walk-embed-result (gensym)
+  ;; For cases when result is a list which must be embedded in the
+  ;; form, e.g. when it returned from a macro
+  )
+
+(define (walk-form form walk-fn env)
+  (if (atom? form) form
+      (let ((new-form (walk-fn form env)))
+        (cond ((not (eq? form new-form))
+               (walk-form new-form walk-fn env))
+              (else
+               (let ((new-car (walk-form (car new-form) walk-fn env))
+                     (new-cdr (walk-form (cdr new-form) walk-fn env)))
+                 (cond ((and (pair? new-car)
+                             (eq? (car new-car) walk-embed-result))
+                        (append (cdr new-car) new-cdr))
+                       (else
+                        (recons new-form new-car new-cdr)))))))))
+
+;;; Typdef
+
+(define (process-typedef form new-type target acc)
+  (cons (copy-form-source! form `(typedef ,target ,new-type)) acc))
+
+;;; Fn processing
+;;;
+;;; A string as the first body form is a docstring. In the generated
+;;; C code it will be placed as a C commentary just before the function
+;;; definition (actually that works for all blocky things: enum, struct, union as well).
+
+(define (fn-header-length fn-form)
+  (if (memq (first fn-form) '(pub extern)) 5 4))
+
+(define (fn-core form)
+  ;; The (fn name args rettype . body) list, without pub/extern
+  (if (memq (first form) '(pub extern))
+      (cdr form)
+      form))
+
+(define (take-leading-docstring forms)
+  ;; If FORMS starts with a string, possibly after comment forms, return
+  ;; that string and FORMS without it. Otherwise #f and FORMS unchanged
+  (let loop ((fs forms) (prefix (list)))
+    (match fs
+      (() (values #f forms))
+      (((and cmt ('comment . _)) . rest)
+       (loop rest (cons cmt prefix)))
+      (((? string? doc) . rest)
+       (values doc (append (reverse prefix) rest)))
+      (_ (values #f forms)))))
+
+(define (extract-fn-docstring fn-form)
+  (let ((lift
+         (lambda (proto body)
+           (let-values (((doc rest) (take-leading-docstring body)))
+             (if doc
+                 (values doc (copy-form-source! fn-form (append proto rest)))
+                 (values #f fn-form))))))
+    (match fn-form
+      (('pub 'fn name args ret . body)
+       (lift `(pub fn ,name ,args ,ret) body))
+      (('extern 'fn name args ret . body)
+       (lift `(extern fn ,name ,args ,ret) body))
+      (('fn name args ret . body)
+       (lift `(fn ,name ,args ,ret) body))
+      (_ (values #f fn-form)))))
+
+(define (extract-aggregate-docstring form)
+  ;; A string immediately after the name is the docstring; comments
+  ;; between name and fields are not skipped, they already confuse the
+  ;; writer
+  (match form
+    (('pub (and kind (or 'struct 'union 'enum))
+           (? symbol? name) (? string? doc) . rest)
+     (values doc (copy-form-source! form `(pub ,kind ,name ,@rest))))
+    (((and kind (or 'struct 'union 'enum))
+      (? symbol? name) (? string? doc) . rest)
+     (values doc (copy-form-source! form `(,kind ,name ,@rest))))
+    (_ (values #f form))))
+
+(define (with-docstring doc form acc)
+  ;; acc is newest-first; FORM is consed last so the final reverse
+  ;; emits the comment immediately before the declaration
+  (cons form
+        (if doc
+            (cons (list 'comment doc) acc)
+            acc)))
+
+(define (strip-fn-header-comments fn-form)
+  ;; ([pub|extern] fn name arglist rettype). Comments in the body are
+  ;; left in place as ordinary statements and preserved into the
+  ;; generated C.
+  (strip-header-comments fn-form (fn-header-length fn-form)))
+
+(define (process-fn sex-fn-raw acc)
+  (let-values (((doc sex-fn)
+                (extract-fn-docstring (strip-fn-header-comments sex-fn-raw))))
+    (let* ((expanded (macro-expand sex-fn))
+           (env (make-hash-table))
+           (processed
+            (walk-form
+             expanded
+             fn-walker
+             (begin
+               (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
+               (set! (hash-table-ref env :lambda-counter) 0)
+               (set! (hash-table-ref env :lambda-aux-code) (list))
+               env))))
+      (with-docstring doc processed
+                      (append (hash-table-ref env :lambda-aux-code) acc)))))
+
+(define (fn-walker form env)
+  (if (eq? 'lambda (car form))
+      (let ((lambda-name (make-lambda-name (hash-table-ref env :fn-name)
+                                           (hash-table-ref env :lambda-counter))))
+        (set! (hash-table-ref env :lambda-aux-code)
+          (append (make-aux-lambda-struct lambda-name form)
+                  (hash-table-ref env :lambda-aux-code)))
+        (set! (hash-table-ref env :lambda-counter)
+          (+ (hash-table-ref env :lambda-counter) 1))
+        lambda-name)
+      form))
+
+(define (make-lambda-name enclosing-fn-name counter)
+  (string->symbol
+   (fmt #f "__lambda_" counter "_" enclosing-fn-name)))
+
+(define (make-aux-lambda-struct name form)
+  (match form
+    (('lambda ret-type arglist captures . body)
+     ;; Captures are ignored for now, but
+     ;; we'll need them for TODO: closures support
+     (process-fn (copy-form-source! form `(fn ,ret-type ,name ,arglist ,@body))
+                 (list)))
+    (else (sex-error form "malformed lambda" form))))
+
+;;; Structs
+
+;;; Record the named structs, unions and enums in the type database
+(define (process-struct sex-struct acc)
+  (let-values (((doc form) (extract-aggregate-docstring sex-struct)))
+    (register-aggregate! form)
+    (with-docstring doc form acc)))
+
+(define (register-aggregate! form)
+  (let* ((f (if (eq? (car form) 'pub) (cdr form) form))
+         (name (and (pair? (cdr f)) (symbol? (cadr f)) (cadr f))))
+    ;; An anonymous aggregate has a field list where the name would be,
+    ;; and nothing can refer to it by name anyway
+    (when name
+      (case (car f)
+        ((struct) (add-struct name form))
+        ((union) (add-union name form))
+        ((enum) (add-enum name form))))))
+
+(define (process-global-var sex-var acc)
+  (cons sex-var acc))
+
+;;; Utils
+(define (non-empty-list? form)
+  (and (list? form)
+       (not (null? form))))
+
+(define (sex-fn? form)
+  "The `form` must be toplevel.
+Returns #f if the form is not a function, returns the form otherwise"
+  (match form
+    ((or ('fn . _)
+         ('pub 'fn . _)
+         ('extern 'fn . _)) form)
+    (else #f)))
+
+(define (sex-fn-public? fn-form)
+  (eq? (first fn-form) 'pub))
+
+(define (sex-fn-name fn-form)
+  (assert (sex-fn? fn-form)
+          (fmt #f "Form " fn-form " is not a function"))
+  (second (fn-core fn-form)))
+
+(define (sex-fn-arglist fn-form)
+  (assert (sex-fn? fn-form)
+          (fmt #f "Form " fn-form " is not a function"))
+  (third (fn-core fn-form)))
+
+(define (sex-fn-return-type fn-form)
+  (assert (sex-fn? fn-form)
+          (fmt #f "Form " fn-form " is not a function"))
+  (fourth (fn-core fn-form)))
+
+(define (sex-fn-prototype fn-form)
+  "Returns all except body"
+  (assert (sex-fn? fn-form)
+          (fmt #f "Form " fn-form " is not a function"))
+  (take fn-form (fn-header-length fn-form)))
+
+(define (sex-fn-body fn-form)
+  (assert (sex-fn? fn-form)
+          (fmt #f "Form " fn-form " is not a function"))
+  (drop fn-form (fn-header-length fn-form)))

sex-macros.module.scm

@@ -0,0 +1,9 @@
+(module sex-macros
+    (register-macro
+     cat
+     comment
+     get-macro
+     macro?
+     apply-macro
+     defmacro)
+  "sex-macros.scm")

sex-macros.scm

@@ -1,19 +1,33 @@
-(declare (unit sex-macros))
-
 (import
+  scheme
+  (only fmt fmt)
+  (chicken base)
   (chicken plist)
   (chicken string))
 
 (define (cat-syms s-1 s-2)
-  (import fmt)
   (fmt #f s-1 s-2))
 
 (define (cat sym-1 sym-2)
   (string->symbol (cat-syms sym-1 sym-2)))
 
+;;; The reader keeps `;' comments as (comment "...") forms so they can
+;;; be re-emitted into the generated C. In a macro body a comment
+;;; should be a call which does nothing, hence this one
+(define (comment . _)
+  (void))
+
 (define (register-macro name arglist body)
   (put! name 'sex-macro
         `(lambda ,arglist
+           ;; A macro body is ordinary Scheme, evaluated at compile
+           ;; time. It gets `cat' for building names, and read access to
+           ;; the type database
+           (import scheme
+                   (scheme base)
+                   (only sex-macros cat comment)
+                   (only types get-type-info get-tag-info get-fields
+                         get-underlying-type type-match map-fields))
            ,@body)))
 
 (define (get-macro name)
@@ -24,6 +38,12 @@
        (symbol? (car form))
        (get (car form) 'sex-macro)))
 
+(define (apply-macro form)
+  (assert (macro? form)
+          (fmt #f (car form) " is not a macro"))
+  (apply (get-macro (car form))
+         (cdr form)))
+
 (define (defmacro form)
   (let ((arglist (car form))
         (body (cdr form)))

sex-mode.el

@@ -35,13 +35,11 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
                                  "define"
                                  "defmacro"
                                  "extern"
-                                 "impl"
                                  "import"
                                  "include"
                                  "fn"
                                  "pub"
                                  "struct"
-                                 "trait"
                                  "var"
                                  "union")
                                'word)
@@ -53,13 +51,14 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
      ;; Keywords
      (list (concat "("
                    (regexp-opt '(
+                                 "do"
                                  "case"
+                                 "default"
                                  "do"
                                  "if"
                                  "for"
                                  "goto"
                                  "return"
-                                 "self"
                                  "switch"
                                  "var"
                                  "while")
@@ -84,10 +83,10 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
 (put 'defmacro 'lisp-indent-function 'defun)
 (put 'struct 'lisp-indent-function 'defun)
 (put 'union 'lisp-indent-function 'defun)
-(put 'trait 'lisp-indent-function 'defun)
-(put 'impl 'lisp-indent-function 'defun)
 (put 'var 'lisp-indent-function 0)
 (put 'import 'lisp-indent-function 1)
+(put 'switch 'lisp-indent-function 1)
+(put 'case 'lisp-indent-function 1)
 
 ;;;###autoload
 (define-derived-mode sex-mode lisp-data-mode "Sex"

sex-modules.module.scm

@@ -0,0 +1,5 @@
+(module sex-modules
+    (get-modules-public-forms
+     load-persistent-module-paths
+     read-public-interface)
+  "sex-modules.scm")

sex-modules.scm

@@ -1,20 +1,25 @@
-; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
-; things start to break.
-(declare (unit sex-modules)
-         (uses utils))
-
-(import brev-separate
-        (chicken file)
-        (chicken load)
-        (chicken pathname)
-        (chicken process-context)
-        (chicken string)
-        fmt
-        srfi-1)
+(import
+  scheme
+  brev-separate
+  (chicken base)
+  (chicken file)
+  (chicken load)
+  (chicken pathname)
+  (chicken process-context)
+  (chicken string)
+  fmt
+  matchable
+  reader
+  srfi-1
+  utils)
 
 (define +persistent-module-paths+ (list))
 
-(define (import-modules module-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:
   ;; For each module in a list, construct path, find module by path in
@@ -29,7 +34,11 @@
   (let ((module-path (locate-module name)))
     (assert module-path (fmt #f "Failed to find module " name " in "
                              (get-module-paths)))
-    (read-public-interface module-path)))
+    (if (member module-path +imported-modules+)
+        (list)
+        (begin
+          (set! +imported-modules+ (cons module-path +imported-modules+))
+          (read-public-interface module-path)))))
 
 (define (get-module-paths)
   (cons (current-directory)
@@ -63,18 +72,35 @@
      (list)
      raw-forms)))
 
+(define (public-fn-interface raw-form)
+  ;; (pub fn name args ret . body) -> prototype, keeping a docstring so
+  ;; the importer can emit it above the declaration
+  (let ((form (strip-header-comments raw-form 5)))
+    (match form
+      (('pub 'fn name args ret)
+       form)
+      (('pub 'fn name args ret ('comment . _) . rest)
+       (public-fn-interface `(pub fn ,name ,args ,ret ,@rest)))
+      (('pub 'fn name args ret (? string? doc) . _)
+       `(pub fn ,name ,args ,ret ,doc))
+      (('pub 'fn name args ret . _)
+       `(pub fn ,name ,args ,ret)))))
+
+;;; TODO: use semen facilities to analyze modules
 (define (process-public-interface-form form acc)
-  (case (car form)
-    ((pub)
-     (case (cadr form)
-       ((fn) ; replace with prototype
-        ;; fn type name (arg-list) (body)
-        ;; 1    2   3       4 - we need first 4
-        (cons (take (cdr form) 4) acc))
-       ((define defmacro import include struct typedef union var)
-        (cons (cdr form) acc))
-       (else (error "Pub what? " (cadr form)))))
-    (else acc)))
+  (match form
+    ;; Reduced to a prototype, still `pub', so the importer declares it
+    ;; with external linkage
+    (('pub 'fn . _)
+     (cons (copy-form-source! form (public-fn-interface form)) acc))
+    (('pub 'var . _)
+     (match-let ((('pub 'var name type . _) (strip-header-comments form 4)))
+       (cons (copy-form-source! form `(extern var ,name ,type)) acc)))
+    (('pub (or 'define 'defmacro 'enum 'import 'include 'struct 'typedef 'union) . _)
+     (cons (copy-form-source! form (cdr form)) acc))
+    (('pub . _)
+     (sex-error form "pub must be followed by a definition" form))
+    (_ acc)))
 
 (define (load-persistent-module-paths)
   (let ((sex-module-path-env-var

sex-types.scm

@@ -1,23 +0,0 @@
-(declare
-  (unit sex-types)
-  (uses fmt-c))
-
-(import fmt
-        srfi-69)
-
-(define +all-types+ (make-hash-table))
-
-(define (normalize-type type)
-  )
-
-(define (add-pointer type)
-  (list 'pointer type))
-
-(define (add-const type)
-  (list 'const type))
-
-(define (get-types-from-arglist arglist)
-  (list))
-
-(define (to-c-type type)
-  (fmt #f (c-type type)))

sexc.module.scm

@@ -0,0 +1 @@
+(module sexc (main) "sexc.scm")

sexc.scm

@@ -1,217 +1,24 @@
-(declare (unit sexc)
-         (uses fmt-c
-               sex-macros
-               sex-modules))
-
-(include "utils.macros.scm")
-
-(import brev-separate
+(import scheme
+        (scheme base)                   ; call/cc
+        brev-separate
+        (chicken base)
+        (chicken condition)             ; handle-exceptions
         (chicken file)
-        (chicken pathname)
         (chicken plist)
         (chicken pretty-print)
         (chicken process)
         (chicken process-context)
         (chicken port)
-        (chicken string)
+        (chicken string)                ; string-split
         fmt
+        fmt-c-writer
         getopt-long
-        regex
+        sex-macros
+        sex-modules
+        reader
+        semen
         srfi-1                          ; list routines
-        srfi-13                         ; string routines
-        tree)
-
-(define (unkebabify sym)
-  (case sym
-    ((-) sym)
-    ((--) sym)
-    ((->) sym)
-    ((-=) sym)
-    (else
-     (string->symbol
-      (string-substitute "-(?!>)" "_"
-                         (symbol->string sym) #t)))))
-
-(define (atom-to-fmt-c atom)
-  (case atom
-    ((fn) '%fun)
-    ((prototype) '%prototype)
-    ((var) '%var)
-    ((begin) '%block-begin)
-    ((define) '%define)
-    ((pointer) '%pointer)
-    ((array) '%array)
-    ((attribute) '%attribute)
-    ((@) 'vector-ref)
-    ((include) '%include)
-    ((cast) '%cast)
-    ;; uh things we do for c89 compatibility
-    ((bool) 'int)
-    ((true) 1)
-    ((false) 0)
-    (else
-     (if (symbol? atom)
-         (unkebabify atom)
-         atom))))
-
-(define (make-field-access form)
-  (assert (= 2 (length form)) "Wrong field access format")
-  (unkebabify
-   (string->symbol
-    (fmt #f (cadr form) (car form)))))
-
-(require-library chicken-syntax)
-
-(define (walk-generic form acc)
-  (cond
-   ((null? form) (cons '() acc))
-
-   ;; vector, e.g. {}-initializer
-   ((vector? form)
-    (cons
-     (list->vector
-      (car (walk-sex-tree (vector->list form) (list))))
-     acc))
-
-   ;; atom (hopefully)
-   ((not (list? form)) (cons (atom-to-fmt-c form) acc))
-
-   ;; special case - replace unquote with its expansion
-   ((eq? (car form) 'unquote)
-    (fold
-     cons
-     acc
-     (car                               ; bc walk-sex-tree always
-                                        ; wraps its result
-      (walk-sex-tree (eval (cadr form)) (list)))))
-
-   ;; another special case - field access
-   ((and (symbol? (car form))
-         (char=? #\. (string-ref (symbol->string (car form)) 0)))
-    (cons (make-field-access form) acc))
-
-   ;; another special case - macro
-   ((macro? form)
-    (append (fold-right
-             walk-generic
-             (list)
-             (apply (get-macro (car form)) (cdr form)))
-            acc))
-
-   ;; toplevel, or a start of a regular list form
-   (else
-    (let ((new-acc (list)))
-      (cons (fold-right
-             walk-generic
-             new-acc
-             form)
-            acc)))))
-
-(define (normalize-fn-form form)
-  ;; (fn ret-type name arglist body) -> normal function
-  ;; (fn ret-type name arglist) -> prototype
-  (if (>= (length form) 5)
-      form
-      (cons 'prototype (cdr form))))
-
-(define (walk-function form static acc)
-  (if static
-      (append (walk-generic (list 'static (normalize-fn-form form))
-                            (list))
-              acc)
-      (append (walk-generic (normalize-fn-form (cdr form))
-                            (list))
-              acc)))
-
-(define (walk-struct form acc)
-  (let ((name (unkebabify (cadr form))))
-    (append (walk-generic form (list))
-          (cons `(typedef struct ,name ,name) acc))))
-
-(define (walk-extern form acc)
-  (case (cadr form)
-    ((fn)
-     (append
-      (list (cons 'extern (walk-function form #f (list))))
-      acc))
-    ((var)
-     (append
-      (list (cons 'extern (walk-generic (cdr form) (list))))
-      acc))
-    (else (error "Extern what?"))))
-
-(define (walk-public form acc)
-  (case (cadr form)
-    ((fn)
-     (walk-function form #f acc))
-    ((var)
-     (append (walk-generic (list 'static (cdr form)) (list)) acc))
-    ((define defmacro import include struct typedef union var)
-     ;; ignore here, used in generating public interface
-     (process-form (cdr form) acc))
-    (else
-     (error "Pub what?" (cadr form)))))
-
-(define (walk-sex-tree form acc)
-  (if (list? form)
-      (if (macro? form)
-          (fold-right (fn (walk-sex-tree x y))
-                      acc
-                      (list (apply (get-macro (car form)) (cdr form))))
-          (case (car form)
-            ((fn) (walk-function form #t acc))
-            ((extern) (walk-extern form acc))
-            ((pub) (walk-public form acc))
-            ((struct union) (walk-struct form acc))
-            ((unquote) (fold (fn (walk-sex-tree x y))
-                             acc
-                             (eval (cadr form))))
-            (else (append (walk-generic form (list)) acc))))
-      ;; only for unquote support
-      (list (list (atom-to-fmt-c form)))))
-
-(define (process-form form acc)
-  (case (car form)
-    ((chicken-define) (eval (cons 'define (cdr form))) acc)
-    ((defmacro) (defmacro (cdr form)) acc)
-    ((chicken-load)
-     (load (cadr form)) acc)
-    ((chicken-import)
-     (eval (cons 'import (cdr form))) acc)
-    ((import)
-     (append (process-raw-forms
-              (import-modules (cdr form)) (list))
-             acc))
-    (else
-     (walk-sex-tree form acc))))
-
-(define (process-raw-forms raw-forms acc)
-  "First processing pass"
-  (if (null? raw-forms)
-      (reverse acc)
-      (process-raw-forms (cdr raw-forms)
-                         (process-form (car raw-forms) acc))))
-
-;;; Second pass
-
-(define (process-sex-forms forms)
-  "Second processing pass.
-
-In this pass we do form-rearranging manipulations, like docstring extraction."
-  forms)
-
-;;; Aux functions
-
-(define (read-forms acc)
-  (let ((r (read)))
-    (if (eof-object? r) (reverse acc)
-        (read-forms (cons r acc)))))
-
-(define (emit-c forms)
-  "Final conversion to C"
-  (for-each (lambda (form)
-              (fmt #t (c-expr form) nl))
-            forms))
+        utils)
 
 ;;; Main function facilities
 
@@ -225,10 +32,21 @@ In this pass we do form-rearranging manipulations, like docstring extraction."
                       (required #f)
                       (value #f)
                       (single-char #\c))
-      (preprocess "Emit C code"
-                  (required #f)
-                  (value #f)
-                  (single-char #\E))
+      (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)
+              (single-char #\C))
       (public-interface "Get module's public interface"
                         (required #f)
                         (value #f))
@@ -236,7 +54,7 @@ In this pass we do form-rearranging manipulations, like docstring extraction."
             (required #f)
             (value #f)
             (single-char #\h))
-      (macro-expand "Emit macro-expanded Sex code"
+      (macro-expand "Emit macro-expanded semantically processed Sex code"
                     (required #f)
                     (value #f)
                     (single-char #\m))
@@ -244,7 +62,14 @@ In this pass we do form-rearranging manipulations, like docstring extraction."
                     (pad padding) "If -E or -m options are provided, defaults to stdout")
               (required #f)
               (value #t)
-              (single-char #\o)))))
+              (single-char #\o))
+      (line-directives
+       ,(fmt #f "How much #line information to emit: statement (default)," nl
+             (pad padding) "toplevel, or none. `statement' is what makes a debugger" nl
+             (pad padding) "land on the right source line; `none' is for reading -C" nl
+             (pad padding) "output by eye")
+       (required #f)
+       (value #t)))))
 
 (define (print-help)
   (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
@@ -260,11 +85,39 @@ In this pass we do form-rearranging manipulations, like docstring extraction."
     (if arg (cdr arg)
         default)))
 
+;;; Everything before the first `--' is ours to parse, everything after
+;;; is handed to the C compiler verbatim
+
+(define (separator? a)
+  (string=? a "--"))
+
+(define (args-before-separator argv)
+  (take-while (complement separator?) argv))
+
+(define (args-after-separator argv)
+  (let ((tail (drop-while (complement separator?) argv)))
+    (if (null? tail)
+        (list)
+        (cdr tail))))
+
 (define (get-rest-args args)
   (cdr (assoc '@ args)))
 
-(define (get-c-compiler-args args)
-  (filter (fn (string-prefix? "-" x)) (get-rest-args args)))
+(define (line-directives-arg args)
+  (let ((v (get-arg args 'line-directives "statement")))
+    (cond ((equal? v "statement") 'statement)
+          ((equal? v "toplevel") 'toplevel)
+          ((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)))
@@ -272,56 +125,71 @@ In this pass we do form-rearranging manipulations, like docstring extraction."
         'stdin
         (car rest-args))))
 
-(define (read-from-file file)
-  (with-directory file
-   (with-input-from-file (pathname-strip-directory file)
-     (fn (read-forms (list))))))
-
 (define (write-to-file-or-stdout output what)
   (if (eq? output 'default)
       (what)
       (with-output-to-file output
         (fn (what)))))
 
-(define (preprocess-or-macroexpand sex-forms output args)
-  (write-to-file-or-stdout
-   output
-   (lambda ()
-    (if (get-arg args 'macro-expand #f)
-        (map pp sex-forms)
-        (emit-c sex-forms)))))
+(define (emit-c-or-sex sex-forms output args)
+  (write-to-file-or-stdout output
+                           (lambda ()
+                             (if (get-arg args 'macro-expand #f)
+                                 (map pp sex-forms)
+                                 (emit-c sex-forms)))))
 
-(define (compile-to-file sex-forms output args)
+(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)))
-    (call-with-values
-        (lambda ()
-          (process compiler (append (list "-o" out-file "-std=c89" "-pedantic" "-x" "c")
-                                    (if (get-arg args 'compile-object #f)
-                                        (list "-c")
-                                        (list))
-                                    (list "-")  ; read stdin
-                                    (get-c-compiler-args args))))
-      (lambda (out-port in-port pid)
-        (with-output-to-port in-port
-          (lambda () (emit-c sex-forms)))
-        (close-output-port in-port)
-        (process-wait pid)))))
+                      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))
+      (with-output-to-file c-file
+        (lambda () (emit-c sex-forms)))
+      (let ((proc (process compiler (append (list "-o" out-file)
+                                            (if (get-arg args 'compile-object #f)
+                                                (list "-c")
+                                                (list))
+                                            (list c-file)
+                                            cc-args))))
+        (call-with-values (lambda () (process-wait proc))
+          (lambda (pid normal-exit? status)
+            (delete-file* c-file)
+            (if normal-exit? status 1)))))))
 
-(define (process-input input raw-forms)
-  (let ((current-dir (current-directory)))
-    (unless (eq? input 'stdin)
-      (set-working-directory input))
-    (prog1
-     (process-raw-forms raw-forms (list))
-     (change-directory current-dir))))
+(define (semantic-process-forms raw-forms input-source)
+  (if (eq? input-source 'stdin)
+      (semen-process raw-forms)
+      (with-directory input-source
+                      (semen-process raw-forms))))
+
+(define prelude
+  '((include inttypes.h)
+
+    (typedef u8 uint8-t)
+    (typedef i8 int8-t)
+    (typedef u16 uint16-t)
+    (typedef i16 int16-t)
+    (typedef u32 uint32-t)
+    (typedef i32 int32-t)
+    (typedef u64 uint64-t)
+    (typedef i64 int64-t)))
 
 (define (main)
-  (let* ((raw-args (command-line-arguments))
+  (let* ((argv (command-line-arguments))
+         (raw-args (args-before-separator argv))
+         (cc-args (args-after-separator argv))
          (args (getopt-long raw-args
                             opts-grammar))
          (output (get-arg args 'output 'default))
@@ -334,6 +202,14 @@ In this pass we do form-rearranging manipulations, like docstring extraction."
        (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")
 
@@ -345,16 +221,21 @@ In this pass we do form-rearranging manipulations, like docstring extraction."
          (return #f))
        (load-persistent-module-paths)
 
-       (let* ((raw-forms
-               (if (eq? input 'stdin)
-                   (read-forms (list))
-                   (read-from-file input)))
-              (sex-forms
-               (process-sex-forms
-                (process-input input raw-forms))))
+       ;; The file name in a #line directive now comes from the form's
+       ;; own recorded location, so imported modules report themselves
+       ;; rather than the unit that imported them
+       (sex-line-directives (line-directives-arg args))
+       (when (and (get-arg args 'emit-c #f)
+                  (not (get-arg args 'line-directives #f)))
+         (sex-line-directives 'none))
+
+       (let* ((raw-forms (append prelude (read-raw-forms input)))
+              (sex-forms (semantic-process-forms raw-forms input)))
          (if (or (get-arg args 'macro-expand #f)
-                 (get-arg args 'preprocess #f))
-             ;; Preprocess or macroexpand
-             (preprocess-or-macroexpand sex-forms output args)
-             ;; Compile file!
-             (compile-to-file sex-forms output args)))))))
+                 (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)))))))))

tests/Makefile

@@ -1 +1,50 @@
+CHICKEN_C = csc
 
+CSC_FLAGS += -K prefix -static
+MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
+
+MODULES = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
+SEX_OBJ = $(MODULES:%=%.o)
+
+TESTS = basic semen reader fmt-c-writer utils line-directives codegen args types
+TEST_SRCS = $(TESTS:%=%.scm)
+
+sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
+	$(CHICKEN_C) $(CSC_FLAGS) run.scm -o sex-tests -link sexc
+
+#------------------------------------------------------------------
+
+utils.o: utils.module.scm ../utils.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
+
+types.o: types.module.scm ../types.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types
+
+sex-macros.o: sex-macros.module.scm ../sex-macros.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
+
+reader.o: reader.module.scm ../reader.scm utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
+
+sex-modules.o: sex-modules.module.scm ../sex-modules.scm reader.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
+
+semen.o: semen.module.scm ../semen.scm sex-macros.o sex-modules.o types.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,types,utils
+
+sex-fmt-c.o: ../sex-fmt-c.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) ../sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
+
+fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
+
+sexc.o: sexc.module.scm types.o ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
+	$(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
+
+clean:
+	rm -f $(SEX_OBJ)
+	rm -f *.import.scm
+	rm -f *.link
+	rm -f sex-tests
+
+.PHONY: clean

tests/args.scm

@@ -0,0 +1,55 @@
+;;; Splitting the command line at `--'.
+;;;
+;;; getopt-long cannot do this: it consumes the separator and merges
+;;; everything after it into `@' alongside the input file. So sexc
+;;; splits the raw argv first, and only the head is parsed as options.
+;;; Everything else reaches the C compiler exactly as written --
+;;; including the words that do not start with a dash, which a previous
+;;; leading-dash heuristic used to drop.
+
+(import sexc)
+
+(define full '("foo.sex" "-o" "bar" "--" "-framework" "OpenGL" "-Wall"))
+
+(test-group "argument separator"
+
+  (test "options and input file stay with sexc"
+        '("foo.sex" "-o" "bar")
+        (args-before-separator full))
+
+  (test "the tail reaches the compiler verbatim"
+        '("-framework" "OpenGL" "-Wall")
+        (args-after-separator full))
+
+  ;; The case that motivated this: `OpenGL' has no leading dash and was
+  ;; silently dropped, leaving `-framework' to swallow whatever flag
+  ;; came next.
+  (test "a word without a dash survives"
+        '("-framework" "OpenGL")
+        (args-after-separator '("x.sex" "--" "-framework" "OpenGL")))
+
+  (test "no separator means nothing for the compiler"
+        '()
+        (args-after-separator '("foo.sex" "-o" "bar")))
+
+  (test "no separator leaves every argument with sexc"
+        '("foo.sex" "-o" "bar")
+        (args-before-separator '("foo.sex" "-o" "bar")))
+
+  (test "a trailing separator is allowed"
+        '()
+        (args-after-separator '("foo.sex" "--")))
+
+  (test "a leading separator leaves no input file"
+        '()
+        (args-before-separator '("--" "-lm")))
+
+  ;; Only the first `--' separates; a later one is an ordinary compiler
+  ;; argument (ld takes several).
+  (test "only the first separator counts"
+        '("-Wl,--as-needed" "--" "-lm")
+        (args-after-separator '("x.sex" "--" "-Wl,--as-needed" "--" "-lm")))
+
+  (test "an empty command line is handled"
+        '()
+        (args-before-separator '())))

tests/basic.scm

@@ -1,31 +1,51 @@
-;;; unkebabify
-(test '- (unkebabify '-))
-(test '-- (unkebabify '--))
-(test '-> (unkebabify '->))
-(test '-= (unkebabify '-=))
-(test 'kebab_case (unkebabify 'kebab-case))
-(test '_what_ (unkebabify '-what-))
-(test 'this->member (unkebabify 'this->member))
-(test '_this_->_member_ (unkebabify '-this-->-member-))
-(test '__->>> (unkebabify '--->>>))
+(import fmt-c-writer)
 
-;;; atom-to-fmt-c
-(test '%fun (atom-to-fmt-c 'fn))
-(test '%prototype (atom-to-fmt-c 'prototype))
-(test '%var (atom-to-fmt-c 'var))
-(test '%block-begin (atom-to-fmt-c 'begin))
-(test '%define (atom-to-fmt-c 'define))
-(test '%pointer (atom-to-fmt-c 'pointer))
-(test '%array (atom-to-fmt-c 'array))
-(test 'vector-ref (atom-to-fmt-c '@))
-(test '%include (atom-to-fmt-c 'include))
-(test '%cast (atom-to-fmt-c 'cast))
+(test-group "basic"
 
-;;; c89 stuff
-(test 'int (atom-to-fmt-c 'bool))
-(test 1 (atom-to-fmt-c 'true))
-(test 0 (atom-to-fmt-c 'false))
+  ;; unkebabify
+  (test '- (unkebabify '-))
+  (test '-- (unkebabify '--))
+  (test '-> (unkebabify '->))
+  (test '-= (unkebabify '-=))
+  (test 'kebab_case (unkebabify 'kebab-case))
+  (test '_what_ (unkebabify '-what-))
+  (test 'this->member (unkebabify 'this->member))
+  (test '_this_->_member_ (unkebabify '-this-->-member-))
+  (test '__->>> (unkebabify '--->>>))
 
-;;; make-field-access
-(test 'a.b (make-field-access '(.b a)))
-(test 'a.b.c (make-field-access '(.c a.b)))
+  ;; Non-ASCII identifiers must survive intact. The `regex' egg's
+  ;; string-substitute drops one trailing character per multi-byte
+  ;; character, which renames things silently -- the C still compiles,
+  ;; just under a different name than was written.
+  (test 'naïve_count (unkebabify 'naïve-count))
+  (test 'aï_b (unkebabify 'aï-b))
+  (test 'ïï (unkebabify 'ïï))
+
+  ;; atom-to-fmt-c
+  (test '%fun (atom-to-fmt-c 'fn))
+  (test '%prototype (atom-to-fmt-c 'prototype))
+  (test '%block-begin (atom-to-fmt-c 'do))
+  (test '%define (atom-to-fmt-c 'define))
+  (test '%pointer (atom-to-fmt-c 'pointer))
+  (test '%array (atom-to-fmt-c 'array))
+  (test 'vector-ref (atom-to-fmt-c '¤))
+  (test '%include (atom-to-fmt-c 'include))
+
+  ;; c89 stuff
+  (test 'int (atom-to-fmt-c 'bool))
+  (test 1 (atom-to-fmt-c 'true))
+  (test 0 (atom-to-fmt-c 'false))
+
+  ;; dot-access -> %. member-access directive (kebab-converted operands)
+  (test '(%. a b) (walk-expr '(dot-access a b)))
+  (test '(%. a b c) (walk-expr '(dot-access a b c)))
+  (test '(%. a_b c) (walk-expr '(dot-access a-b c)))
+
+  ;; comment -> %comment directive (rendered as /* ... */)
+  ;; The reader eats only the `;' that introduced the line, so ";;; Foo"
+  ;; arrives as ";; Foo"; and c-comment puts nothing between /* */ and
+  ;; the text. Both are handled on the way out.
+  (test '(%comment " hi ") (walk-expr '(comment " hi")))
+  (test '(%comment " hi ") (process-toplevel-form '(comment " hi")))
+  (test '(%comment " Foo ") (walk-expr '(comment ";; Foo")))
+  (test '(%comment " Foo ") (walk-expr '(comment ";;;   Foo   "))))

tests/codegen.scm

@@ -0,0 +1,262 @@
+;;; Codegen details that are easy to get subtly wrong, and that the
+;;; walk-* unit tests cannot see: they check the intermediate form we
+;;; hand to fmt-c, not the C that fmt-c renders from it.
+;;;
+;;; Both cases below were found by writing an OpenGL example, not by
+;;; the existing suite, because both need an operand shape that no
+;;; earlier test program happened to use.
+
+(import (chicken condition)
+        (chicken port)
+        (chicken string)
+        srfi-13
+        fmt-c-writer
+        reader
+        semen
+        utils)
+
+(define (sex->c source)
+  "Compile SOURCE, a string of Sex, and return the generated C."
+  (let ((forms (with-input-from-string source
+                 (lambda ()
+                   (parameterize ((current-source-file "codegen.sex"))
+                     (parse-all (current-input-port)))))))
+    (with-output-to-string
+      (lambda ()
+        (parameterize ((sex-line-directives 'none))
+          (emit-c (semen-process forms)))))))
+
+(define (emits? source fragment)
+  (and (string-contains (sex->c source) fragment) #t))
+
+(define (error-message source)
+  "Compile SOURCE and return the error text as the user sees it --
+message plus arguments, the way CHICKEN prints it -- or #f if SOURCE
+compiles."
+  (handle-exceptions e
+      (with-output-to-string
+        (lambda ()
+          (display ((condition-property-accessor 'exn 'message) e))
+          (for-each (lambda (a) (display " ") (write a))
+                    ((condition-property-accessor 'exn 'arguments) e))))
+    (begin (sex->c source) #f)))
+
+(define (reports? source fragment)
+  (let ((m (error-message source)))
+    (and m (string-contains m fragment) #t)))
+
+(define (in-fn body)
+  (string-append "(fn f ((a int) (b int)) void " body ")"))
+
+(test-group "codegen"
+
+  ;; c-switch handed its scrutinee straight to `cat', which only works
+  ;; when it is an atom. Anything else was displayed as a raw
+  ;; s-expression: `switch ((%. e type))'.
+  (test-group "switch scrutinee"
+    (test-assert "member access"
+      (emits? "(struct s ((type int))) (fn f ((e (struct s))) void (switch (. e type) (case 1 (g))))"
+              "switch (e.type)"))
+    (test-assert "call"
+      (emits? (in-fn "(switch (g a) (case 1 (h)))")
+              "switch (g(a))"))
+    (test-assert "arithmetic"
+      (emits? (in-fn "(switch (+ a b) (case 1 (h)))")
+              "switch (a + b)")))
+
+  ;; A cast binds tighter than every binary operator, so an operand
+  ;; that is itself a binary expression has to be parenthesised --
+  ;; otherwise the cast silently applies to the first operand only.
+  (test-group "cast precedence"
+    (test-assert "binary operand is parenthesised"
+      (emits? (in-fn "(var p (* void) (cast (* 2 (sizeof int)) (* void)))")
+              "(void *)(2 * sizeof(int))"))
+    (test-assert "subtraction operand is parenthesised"
+      (emits? (in-fn "(var f float (cast (- a b) float))")
+              "(float)(a - b)"))
+    ;; ...but exactly once. The operand used to parenthesise itself
+    ;; again inside the parens the cast had just added.
+    (test-assert "and not parenthesised twice"
+      (not (emits? (in-fn "(var f float (cast (- a b) float))")
+                   "(float)((a - b))")))
+    ;; Unary operands are already unary-expressions and must be left
+    ;; alone, or every existing cast in the tree gains noise.
+    (test-assert "identifier is left bare"
+      (emits? (in-fn "(var f float (cast a float))")
+              "(float)a"))
+    (test-assert "address-of is left bare"
+      (emits? (in-fn "(var p (* int) (cast (& a) (* int)))")
+              "(int *)&a"))
+    (test-assert "sizeof is left bare"
+      (emits? (in-fn "(var n int (cast (sizeof int) int))")
+              "(int)sizeof(int)")))
+
+  ;; A comment among a call's arguments used to become an argument,
+  ;; and c-apply put a comma on each side of it -- which does not
+  ;; compile. It is dropped, as in any other expression context.
+  (test-group "comments among arguments"
+    (test-assert "no stray comma"
+      (not (emits? (in-fn "(g 1 ;; c\n 2)") "*/,")))
+    (test-assert "the arguments survive"
+      (emits? (in-fn "(g 1 ;; c\n 2)") "g(1, 2)")))
+
+  ;; The reader leaves the `;'s that introduced each line, and a run of
+  ;; comment lines arrives as one form per line.
+  (test-group "comment rendering"
+    (test-assert "the markers are stripped"
+      (emits? "(fn f () void ;;; Foo\n (g))" "/* Foo */"))
+    (test-assert "so none survive into the C"
+      (not (emits? "(fn f () void ;;; Foo\n (g))" ";;")))
+    (test-assert "consecutive lines are packed into one comment"
+      (emits? "(fn f () void\n ;; first\n ;; second\n (g))"
+              "/* first\n second */"))
+    ;; Packing compares locations rather than just looking for adjacent
+    ;; comment forms, so a blank line still separates them.
+    (test-assert "a blank line keeps them apart"
+      (emits? "(fn f () void\n ;; first\n\n ;; second\n (g))" "/* first */")))
+
+  ;; A `;' comment is a form, so one written inside a construct with
+  ;; positional slots used to land in a slot and shift everything after
+  ;; it -- silently. In an `if' the comment became the then-arm and the
+  ;; then-arm became an `else if' condition, and it still compiled.
+  ;; Comments are now taken out of the slots and emitted just before the
+  ;; statement; comments in a body stay where they were written.
+  (test-group "comments in positional slots"
+    (test-assert "an if arm is not shifted"
+      (not (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "else if")))
+    (test-assert "and both arms survive"
+      (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "g(1)"))
+    (test-assert "the comment survives too"
+      (emits? (in-fn "(if 1 ;; kept here\n (g 1) (g 2))") "kept here"))
+    (test-assert "a for header is not shifted"
+      (emits? (in-fn "(for ;; c\n (var i int 0) (< i 2) (++ i) (g i))")
+              "for (int i = 0; i < 2; ++i)"))
+    (test-assert "a while condition is not shifted"
+      (emits? (in-fn "(while ;; c\n (< a b) (g 1))") "while (a < b)"))
+    (test-assert "a var is not shifted"
+      (emits? (in-fn "(var ;; c\n x int 5)") "int x = 5"))
+    (test-assert "a cast is not shifted"
+      (emits? (in-fn "(var y int (cast ;; c\n a int))") "(int)a"))
+    ;; Bodies are a statement sequence, so comments there stay put.
+    (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,
+  ;; so they used to fall through to the function-call path and emit
+  ;; `|\||(a, b)'. The writer renames them to heads fmt-c spells with
+  ;; a string.
+  (test-group "bitwise and logical operators"
+    (test-assert "bit-or"
+      (emits? (in-fn "(var x int (| a b))") "int x = a | b"))
+    (test-assert "logical or"
+      (emits? (in-fn "(var x int (|| a b))") "int x = a || b"))
+    (test-assert "or-assign"
+      (emits? (in-fn "(|= a b)") "a |= b"))
+    (test-assert "bit-and"
+      (emits? (in-fn "(var x int (& a b))") "int x = a & b"))
+    (test-assert "logical and"
+      (emits? (in-fn "(var x int (&& a b))") "int x = a && b"))
+
+    ;; Precedence too: the operator reaches fmt-c as a string it looks
+    ;; up, not as a symbol in its table
+    (test-assert "parenthesised where C needs it"
+      (emits? (in-fn "(var x int (& (| a b) a))") "(a | b) & a"))
+    (test-assert "and left alone where it does not"
+      (emits? (in-fn "(var x int (| a (& a b)))") "int x = a | a & b"))
+
+    ;; The spelling from before they could be written directly
+    (test-assert "c-or is still accepted"
+      (emits? (in-fn "(var x int (c-or a b))") "a || b"))
+    (test-assert "c-bit-or is still accepted"
+      (emits? (in-fn "(var x int (c-bit-or a b))") "a | b")))
+
+  ;; A `;' comment is a form. In a macro body `comment' is a no-op
+  ;; that swallows the comment itself. Inside a quasiquoted payload
+  ;; the same form is data, never evaluated, and reaches the writer
+  ;; intact
+  (test-group "comments in macros"
+    (test-assert "a comment in the payload reaches the C"
+      (emits? "(defmacro (m-kept) `(fn f () void\n ;; this survives\n (g)))\n(m-kept)"
+              "this survives"))
+    (test-assert "a comment about the macro does not"
+      (not (emits? "(defmacro (m-dropped)\n ;; this vanishes\n `(fn f () void (g)))\n(m-dropped)"
+                   "this vanishes")))
+    (test-assert "and the macro still expands"
+      (emits? "(defmacro (m-both)\n ;; about the macro\n `(fn f () void (g)))\n(m-both)"
+              "void f (void)")))
+
+  ;; Diagnostics name also the place. Every form carries a (file
+  ;; . line), so an error can cite it
+  (test-group "errors cite the source location"
+    (test-assert "unknown toplevel form"
+      (reports? "(include stdio.h)\n(wat 1 2)" "codegen.sex:2: unknown top level form"))
+    (test-assert "the offending form is shown too"
+      (reports? "(include stdio.h)\n(wat 1 2)" "(wat 1 2)"))
+    (test-assert "pub with nothing to define"
+      (reports? "(pub 1)" "codegen.sex:1:")))
+
+  ;; A nested pointer chain used to silently lose a level:
+  ;; (var p (* (* char))) emitted `char *p'
+  (test-group "malformed types are rejected"
+    (test-assert "nested pointer chain"
+      (reports? (in-fn "(var p (* (* char)))") "pointer chains are written flat"))
+    (test-assert "and names the line"
+      (reports? "(pub fn f () void\n  (var p (* (* char))))" "codegen.sex:2:"))
+    ;; A sublist that only groups has no `*' in it and must still work.
+    (test-assert "grouping sublist still accepted"
+      (emits? (in-fn "(var s (* (const struct suc)) 0)") "const struct suc * s"))
+    (test-assert "flat chain still accepted"
+      (emits? (in-fn "(var q (* * const char) 0)") "const char * * q")))
+
+  ;; A string as the first body form (or after the name of a struct,
+  ;; union or enum) is a docstring: it becomes a comment immediately
+  ;; before the declaration, not a statement inside it.
+  (test-group "docstrings"
+    (test-assert "appears before the function"
+      (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
+              "/* Greet NAME. */"))
+    (test-assert "and not inside the body as a statement"
+      (not (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
+                   "\"Greet NAME.\"")))
+    (test-assert "multiline keeps its paragraphs"
+      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
+              "Entry point."))
+    (test-assert "and the second paragraph too"
+      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
+              "ARGC and ARGV."))
+    (test-assert "a prototype with only a docstring stays a prototype"
+      (emits? "(fn helper ((a int)) int \"Forward.\")"
+              "helper (int a);"))
+    (test-assert "a string after the first statement is left alone"
+      (emits? "(fn f () void (g) \"not a docstring\")"
+              "\"not a docstring\""))
+    (test-assert "a struct docstring sits above the struct"
+      (emits? "(struct point \"A 2D point.\" ((x int) (y int)))"
+              "/* A 2D point. */"))
+    (test-assert "and an enum docstring too"
+      (emits? "(enum color \"RGB.\" (red green blue))"
+              "/* RGB. */"))))

tests/exit-code/Makefile

@@ -0,0 +1,26 @@
+# 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

tests/exit-code/hello.sex

@@ -0,0 +1,4 @@
+;;; 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))

tests/exit-code/nested-pointer.sex

@@ -0,0 +1,4 @@
+;;; 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))))

tests/fmt-c-writer.module.scm

@@ -0,0 +1,3 @@
+(module fmt-c-writer
+    *
+  "../fmt-c-writer.scm")

tests/fmt-c-writer.scm

@@ -0,0 +1,159 @@
+;;; Types
+(test-group "fmt-writer"
+
+  (test
+   '(const int)
+   (walk-type '(const int)))
+
+  (test
+   '(%array (const char) 512)
+   (walk-type '(¤ const char 512)))
+
+  (test
+   '(%array (float) 512)
+   (walk-type '(¤ (float) 512)))
+
+  (test
+   '(%array (const char) 512)
+   (walk-type '(¤ (const char) 512)))
+
+  (test
+   '(%array (const char))
+   (walk-type '(¤ const char)))
+
+  (test
+   '(%array (const char))
+   (walk-type '(¤ (const char))))
+
+  (test
+   '(%array float 8)
+   (walk-type '(¤ float 8)))
+
+  (test
+   "Pointer to const char"
+   '(const char *)
+   (walk-type '(* const char)))
+
+  (test
+   "Const pointer to const char"
+   '(const char * const)
+   (walk-type '(const * const char)))
+
+  (test
+   '(%fun void ((int) (float) (%array (struct what * const))))
+   (walk-type '(fn ((int) (float) (¤ (const * struct what))) void)))
+
+  (test
+   '(%fun void ((int) (%array float) (%array (struct what * const))))
+   (walk-type '(fn ((int) (¤ float) (¤ (const * struct what))) void)))
+
+  (test
+   '(%array (%fun void ((int) (%array float) (%array (struct what * const)))))
+   (walk-type '(¤ (fn ((int) (¤ float) (¤ (const * struct what))) void))))
+
+  ;; Type convert to C
+  (test
+   '(int)
+   (type-convert-to-c '(int)))
+
+  (test
+   '(* int)
+   (type-convert-to-c '(int *)))
+
+  (test
+   '(* const int)
+   (type-convert-to-c '(const int *)))
+
+  (test
+   '(const * const char)
+   (type-convert-to-c '(const char * const)))
+
+;;; Variable defs
+  (test
+   '(%var (%array float 8) a)
+   (walk-var '(var a (¤ float 8))))
+
+  (test
+   '(%var (int *) a (& n))
+   (walk-var '(var a (* int) (& n))))
+
+  (test
+   '(%var (const int *) a (& n))
+   (walk-var '(var a (* const int) (& n))))
+
+  (test
+   '(%var (struct suc) s)
+   (walk-var '(var s (struct suc))))
+
+  (test
+   '(%var (const struct suc *) s s1)
+   (walk-var '(var s (* const struct suc) s1)))
+
+  (test
+   '(%var (const struct suc *) s s1)
+   (walk-var '(var s (* (const struct suc)) s1)))
+
+  (test
+   '(%var (struct suc) s (hoge piyo))
+   (walk-var '(var s (struct suc) (hoge piyo))))
+
+  (test
+   '(%var (struct suc *) s (hoge piyo))
+   (walk-var '(var s (* struct suc) (hoge piyo))))
+
+;;; Fn defs
+  (test
+   '(%fun void puk ((int) (%array float 8)))
+   (walk-fn-def '(fn puk ((int) (¤ float 8)) void)))
+
+  (test
+   '(%fun int main ((int argc) ((%array (const char)) argv))
+          (return 0))
+   (walk-fn-def
+    '(fn main ((argc int) (argv (¤ const char))) int
+         (return 0))))
+  (test
+   '(%fun int quxu (((struct piq *) bar))
+          (return 0))
+   (walk-fn-def
+    '(fn quxu ((bar (* struct piq))) int
+         (return 0))))
+
+  (test
+   '(%fun int quxu (((struct piq *) bar) ((%array (struct tt *)) ploop))
+          (return 0))
+   (walk-fn-def
+    '(fn quxu ((bar (* struct piq)) (ploop (¤ * struct tt))) int
+         (return 0))))
+
+  ;; Structs
+  (test
+   '(struct no_kebab ((int a) (float f)))
+   (walk-struct '(struct no-kebab ((a int) (f float)))))
+
+  (test
+   '(struct settings ((u32 x y w h)
+                      ((%array (struct ((float r g b a))) 4) colors)))
+   (walk-struct
+    '(struct settings
+             ((x y w h u32)
+              (colors [¤ struct ((r g b a float)) 4])))))
+
+  (test
+   '(struct settings ((u32 x y w h)
+                      ((%array (struct color ((float r g b a))) 4) colors)))
+   (walk-struct
+    '(struct settings
+             ((x y w h u32)
+              (colors [¤ struct color ((r g b a float)) 4])))))
+
+  (test
+   '(struct mega_kebab ((int a)
+                        ((struct ((int year) (int month) (int day))) dob)
+                        ((%fun int ((int) (%array int))) min)))
+   (walk-struct '(struct mega-kebab
+                         ((a int)
+                          (dob (struct ((year int)
+                                        (month int)
+                                        (day int))))
+                          (min (fn ((int) (¤ int)) bool)))))))

tests/line-directives.scm

@@ -0,0 +1,242 @@
+;;; Source-line mapping.
+;;;
+;;; Every construct in the generated C must be attributed, through
+;;; #line directives, to the source line of the Sex form it came from.
+;;; That mapping is the whole basis of source-level debugging.
+;;;
+;;; It cannot be left to the C compiler's implicit line counting,
+;;; because a Sex form and its C rendering may or may not occupy the
+;;; same number of lines. A call written across four lines renders as
+;;; one C line; a one-line `for' renders as a braced block of
+;;; four. Either way every following line drifts, and the drift
+;;; accumulates over a function body.
+;;;
+;;; The tests below pin one construct per statement kind. Each carries
+;;; a unique numeric marker chosen so that it lands on the first C line
+;;; that construct emits; the marker is then located in the fixture (to
+;;; get the true source line) and in the C output (to get the line the
+;;; directives claim). The two must agree.
+
+(import (chicken port)
+        (chicken string)
+        srfi-1
+        srfi-13
+        fmt-c-writer
+        reader
+        semen
+        utils)
+
+;;; ------------------------------------------------------------------
+;;; Fixture. Line numbers are in the trailing comments; keep them
+;;; correct when editing. Markers are distinct 3-digit integers, and no
+;;; other literal in the fixture contains one as a substring.
+
+(define fixture-lines
+  '("(include stdio.h)"                   ;  1
+    ""                                    ;  2
+    "(struct pt"                          ;  3  multi-line toplevel
+    "  ((x int)"                          ;  4
+    "   (y int)))"                        ;  5
+    ""                                    ;  6
+    "(enum color (red green blue))"       ;  7
+    ""                                    ;  8
+    "(typedef byte u8)"                   ;  9
+    ""                                    ; 10
+    "(define MAXN 101)"                   ; 11
+    ""                                    ; 12
+    "(var gvar int 102)"                  ; 13
+    ""                                    ; 14
+    "(extern var evar int)"               ; 15
+    ""                                    ; 16
+    "(fn helper ((a int)) int)"           ; 17  prototype
+    ""                                    ; 18
+    "(pub fn main () int"                 ; 19
+    "  (var mvar int 103)"                ; 20
+    "  (var p (struct pt))"               ; 21
+    "  (var arr [int 4])"                 ; 22
+    "  (= (. p x) 104)"                   ; 23
+    "  (+= mvar 105)"                     ; 24
+    "  (++ mvar)"                         ; 25
+    "  (= [arr 0] 106)"                   ; 26
+    "  (putchar (+ 107"                   ; 27  form spanning 3 lines,
+    "             mvar"                   ; 28  emitted as one C line:
+    "             0))"                    ; 29  everything after drifts
+    "  (var aftercall int 108)"           ; 30
+    "  (if (< mvar 109)"                  ; 31
+    "      (putchar 110))"                ; 32
+    "  (if (< mvar 111)"                  ; 33
+    "      (putchar 112)"                 ; 34
+    "      (putchar 113))"                ; 35
+    "  (while (< mvar 114)"               ; 36
+    "    (++ mvar))"                      ; 37
+    "  (for (var i int 115)"              ; 38
+    "       (< i 116)"                    ; 39
+    "       (++ i)"                       ; 40
+    "    (continue))"                     ; 41
+    "  (switch 117"                       ; 42
+    "    (case 118"                       ; 43
+    "      (putchar 119)"                 ; 44
+    "      (break))"                      ; 45
+    "    (default"                        ; 46
+    "      (putchar 120)))"               ; 47
+    "  (do"                            ; 48
+    "    (var bvar int 121)"              ; 49
+    "    (putchar bvar))"                 ; 50
+    "  (goto done)"                       ; 51
+    "  (: done)"                          ; 52
+    "  (var svar u64 (sizeof (struct pt)))" ; 53
+    "  (var cvar int (cast mvar int))"    ; 54
+    "  (return 122))"                     ; 55
+    ))
+
+(define fixture (string-intersperse fixture-lines "\n"))
+
+;;; ------------------------------------------------------------------
+;;; Pipeline and #line accounting
+
+(define (compile-to-c source)
+  "Run reader -> semen -> writer on SOURCE, returning the generated C.
+parse-all is called directly rather than through read-raw-forms so the
+fixture can be given a file name: a location is (file . line), and the
+file is what makes an imported module report itself rather than the unit
+that imported it."
+  (let ((forms (with-input-from-string source
+                 (lambda ()
+                   (parameterize ((current-source-file "fixture.sex"))
+                     (parse-all (current-input-port)))))))
+    (with-output-to-string
+      (lambda () (emit-c (semen-process forms))))))
+
+(define (split-lines s)
+  (let loop ((i 0) (start 0) (acc (list)))
+    (cond
+     ((= i (string-length s))
+      (reverse (if (> i start) (cons (substring s start i) acc) acc)))
+     ((char=? (string-ref s i) #\newline)
+      (loop (+ i 1) (+ i 1) (cons (substring s start i) acc)))
+     (else (loop (+ i 1) start acc)))))
+
+(define (directive-line text)
+  "The N of a `#line N \"file\"' directive, or #f if TEXT is not one."
+  (let ((t (string-trim text)))
+    (and (string-prefix? "#line " t)
+         (string->number (car (string-split (substring t 6) " "))))))
+
+(define (directive-file text)
+  "The file name of a `#line N \"file\"' directive, or #f."
+  (let ((t (string-trim text)))
+    (and (string-prefix? "#line " t)
+         (let ((parts (string-split (substring t 6) " ")))
+           (and (pair? (cdr parts)) (cadr parts))))))
+
+(define (attributed-lines c-source)
+  "Pair every non-directive C line with the source line it is
+attributed to. `#line N' says the *next* physical line is N; each line
+after that is one more. Lines before the first directive get #f."
+  (let loop ((lines (split-lines c-source)) (cur #f) (acc (list)))
+    (if (null? lines)
+        (reverse acc)
+        (cond
+         ((directive-line (car lines))
+          => (lambda (n) (loop (cdr lines) n acc)))
+         (else
+          (loop (cdr lines)
+                (and cur (+ cur 1))
+                (cons (cons (car lines) cur) acc)))))))
+
+(define (sex-line token)
+  "1-based fixture line containing TOKEN."
+  (let loop ((lines fixture-lines) (n 1))
+    (cond ((null? lines) #f)
+          ((string-contains (car lines) token) n)
+          (else (loop (cdr lines) (+ n 1))))))
+
+(define (claimed-line attributed token)
+  "The source line the generated C attributes TOKEN to."
+  (let ((hit (find (lambda (p) (string-contains (car p) token)) attributed)))
+    (and hit (cdr hit))))
+
+;;; ------------------------------------------------------------------
+
+(define c-out (compile-to-c fixture))
+(define attributed (attributed-lines c-out))
+
+;;; MAPS checks a construct found under the same token on both sides.
+;;; MAPS/TOKENS is for constructs that are spelled differently in Sex
+;;; and in C (`(break)' -> `break;', `(: done)' -> `done:').
+(define-syntax maps
+  (syntax-rules ()
+    ((maps name token)
+     (test name (sex-line token) (claimed-line attributed token)))))
+
+(define-syntax maps/tokens
+  (syntax-rules ()
+    ((maps/tokens name sex-token c-token)
+     (test name (sex-line sex-token) (claimed-line attributed c-token)))))
+
+(test-group "line-directives"
+
+  ;; Toplevel forms
+  (test-group "toplevel"
+    (maps/tokens "include"        "(include stdio.h)" "#include")
+    (maps/tokens "struct"         "(struct pt"        "struct pt {")
+    (maps/tokens "enum"           "(enum color"       "enum color {")
+    (maps/tokens "typedef"        "(typedef byte u8)" "typedef u8 byte;")
+    (maps         "define"        "101")
+    (maps         "global var"    "102")
+    (maps/tokens "extern var"     "(extern var evar" "extern int evar")
+    (maps/tokens "prototype"      "(fn helper"       "int helper (int a)")
+    (maps/tokens "function"       "(pub fn main"     "int main (void)"))
+
+  ;; Declarations and expression statements
+  (test-group "statements"
+    (maps "var decl"              "103")
+    (maps "member assignment"     "104")
+    (maps "compound assignment"   "105")
+    (maps/tokens "increment"      "(++ mvar)" "++mvar;")
+    (maps "array assignment"      "106")
+
+    ;; The point of the whole exercise: a call spread over three source
+    ;; lines collapses to one C line, so the statement after it must be
+    ;; re-anchored or it is reported two lines too early. The call
+    ;; itself anchors to the line it *starts* on, which is where a
+    ;; debugger should report it.
+    (maps "multi-line call"       "107")
+    (maps "statement after it"    "108"))
+
+  ;; Control flow
+  (test-group "control flow"
+    (maps "if"                    "109")
+    (maps "if body"               "110")
+    (maps "if/else"               "111")
+    (maps "then branch"           "112")
+    (maps "else branch"           "113")
+    (maps "while"                 "114")
+    (maps "for"                   "115")
+    (maps/tokens "continue"       "(continue)" "continue;")
+    (maps "switch"                "117")
+    ;; The `case 118:' label line itself is deliberately not pinned.
+    ;; c-switch requires every clause to be a case/default form and
+    ;; rejects anything else, so no anchor can be placed between
+    ;; clauses. The clause *bodies* are anchored from inside, which is
+    ;; what matters -- a label is not a statement a debugger stops on.
+    (maps "case body"             "119")
+    (maps/tokens "break"          "(break)" "break;")
+    (maps "default body"          "120")
+    (maps "block"                 "121")
+    (maps/tokens "goto"           "(goto done)" "goto done;")
+    (maps/tokens "label"          "(: done)"    "done:")
+    (maps "return"                "122"))
+
+  ;; Expressions that are their own statement
+  (test-group "expressions"
+    (maps/tokens "sizeof" "(var svar" "sizeof")
+    (maps/tokens "cast"   "(var cvar" "(int)mvar"))
+
+  ;; A location is (file . line); every directive must name the file the
+  ;; form was read from.
+  (test-group "file name"
+    (test "every directive names the fixture"
+          (list "\"fixture.sex\"")
+          (delete-duplicates
+           (filter values (map directive-file (split-lines c-out)))))))

tests/modules/Makefile

@@ -0,0 +1,35 @@
+# Multi-module linking.
+#
+# Modules are only testable end to end, and nothing else in the suite
+# links more than one translation unit. Three things have to hold at
+# once: an imported `pub fn' comes out as a prototype with external
+# linkage, an imported `pub var' as an extern declaration, and the
+# 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.
+#
+# The public forms carry comments in their headers, which the reduction
+# to a prototype and to an extern both have to look past.
+
+SEXC ?= ../../sexc
+
+EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1
+
+check:
+	@$(SEXC) greet.sex -c -o greet.o
+	@$(SEXC) greet-app.sex -o greet-app -- greet.o
+	@if [ "`./greet-app`" = "`printf '$(EXPECTED)\n'`" ]; then \
+		echo "modules ok"; \
+	else \
+		echo "modules FAILED, got:"; ./greet-app; $(MAKE) clean; exit 1; \
+	fi
+	@$(MAKE) --no-print-directory clean
+
+clean:
+	@rm -f greet.o greet-app
+
+.PHONY: check clean

tests/modules/greet-app.sex

@@ -0,0 +1,29 @@
+;;; Uses the greet module. Build both, then link them:
+;;;
+;;;   ./sexc example/greet.sex -c -o greet.o
+;;;   ./sexc example/greet-app.sex -o greet-app -- greet.o
+;;;
+;;; `(import greet)' pastes greet's public declarations here: `greet'
+;;; 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)
+
+(import greet)
+
+(pub fn main () int
+  (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))

tests/modules/greet.sex

@@ -0,0 +1,40 @@
+;;; A module. Everything marked `pub' forms its public interface;
+;;; everything else is private to this file.
+;;;
+;;; Importing a module does not link it: it pastes the declarations, so
+;;; the compiled object still has to be handed to the C compiler. See
+;;; greet-app.sex.
+
+(include stdio.h)
+
+(pub var greet-count ;; a comment in the header of a public form is
+                     ;; not part of it: what the importer is given has
+                     ;; to be `extern int greet-count', not a form
+                     ;; counted off by one
+  int 0)
+
+(pub struct greeting
+  "A greeting to print."
+  ((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 ;; ...and here the prototype would lose its return type
+  ((name (* const char))) void
+  "Print a greeting for NAME."
+  (++ greet-count)
+  (printf "hello, %s\n" name))
+
+;;; Not `pub': invisible to importers, and static in the generated C.
+(fn unused-helper () void
+  (printf "private\n"))

tests/reader.module.scm

@@ -0,0 +1,3 @@
+(module reader
+    *
+  "../reader.scm")

tests/reader.scm

@@ -0,0 +1,102 @@
+(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)
+     (test result
+           (with-input-from-string string
+             (lambda () (read-raw-forms 'stdin)))))))
+
+(test-group "reader"
+  ;; []-syntax. For array types and array access expressions
+  (reader-test '((¤ * char)) "[* char]")
+  (reader-test '((¤ * * char const 512)) "[* * char const 512]")
+  (reader-test '((¤)) "[]")
+  (reader-test '((¤ (¤))) "[[]]")
+  (reader-test '((¤ (¤ const char))) "[[const char]]")
+
+  ;; leading `.' becomes the dot-access operator
+  (reader-test '((dot-access obj field)) "(. obj field)")
+  (reader-test '((dot-access obj method a b)) "(. obj method a b)")
+  (reader-test '((dot-access a b)) "(.  a  b)")
+  ;; nested leading dot
+  (reader-test '((foo (dot-access a b))) "(foo (. a b))")
+
+  ;; dotted pairs are preserved (only a *leading* dot is special)
+  (reader-test '((a . b)) "(a . b)")
+  (reader-test '((a b . c)) "(a b . c)")
+  (reader-test '((quote (a . b))) "'(a . b)")
+  ;; a `.'-prefixed symbol is an ordinary symbol, not dot-access
+  (reader-test '((.field obj)) "(.field obj)")
+
+  ;; `;' comments are preserved as (comment "...") forms
+  (reader-test '((comment " hi")) "; hi")
+  (reader-test '((comment ";; Prototypes")) ";;; Prototypes")
+  (reader-test '((foo (comment " c") bar)) "(foo ; c\n bar)")
+  ;; a trailing top-level comment is its own form
+  (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)")
+  ;; ...and the inner one may leave nothing behind: the end of the
+  ;; file, or the paren closing the list, is what the outer one then
+  ;; produces, and neither is an error
+  (feature-test '()      (x) "#+x #+y (a)")
+  (feature-test '((f))   (x) "(f #+x #+y 1)")
+  (feature-test '((f 2)) (x) "(f #+x #+y 1 2)")
+  (feature-test '((a))   (x) "(a) #+x #+y (b)")
+
+  ;; a comment between a guard and the form it guards describes the
+  ;; guard. Taking it for the guarded datum would leave the form itself
+  ;; unconditional
+  (feature-test '((a)) (x) "#+x ;; why\n (a)")
+  (feature-test '()    (y) "#+x ;; why\n (a)")
+  (feature-test '((b)) (y) "#+x ;; why\n (a) (b)")
+  ;; a comment after the guarded form is an ordinary form, and stays
+  (feature-test '((comment "; tail")) (y) "#+x (a) ;; tail")
+
+  ;; a feature the program was not given is simply absent
+  (feature-test '() () "#+anything (a)")
+)

tests/run.scm

@@ -1,12 +1,14 @@
-(declare (uses sexc))
-
 (import
-  (chicken process)
-  (chicken process-context)
-  srfi-1
   test)
 
 (include "basic.scm")
+(include "semen.scm")
+(include "reader.scm")
+(include "fmt-c-writer.scm")
+(include "utils.scm")
+(include "line-directives.scm")
+(include "codegen.scm")
+(include "args.scm")
 (include "types.scm")
 
 ;;; Should be the last in the test suite

tests/semen.module.scm

@@ -0,0 +1,2 @@
+(module semen *
+  "../semen.scm")

tests/semen.scm

@@ -0,0 +1,118 @@
+(import srfi-69
+        semen
+        types)
+
+(define print-str-fn
+  '(fn print-str ((s string)) void
+       (printf "%s" s)))
+
+(define sum-fn
+  '(pub fn sum ((a int) (b int)) float
+        (return (cast (+ a b) float))))
+
+(test-group "semen"
+  (test-assert (sex-fn? print-str-fn))
+  (test #f (sex-fn-public? print-str-fn))
+  (test 'void (sex-fn-return-type print-str-fn))
+  (test 'print-str (sex-fn-name print-str-fn))
+  (test '((s string)) (sex-fn-arglist print-str-fn))
+  (test '(fn print-str ((s string)) void) (sex-fn-prototype print-str-fn))
+  (test '((printf "%s" s)) (sex-fn-body print-str-fn))
+
+  (test-assert (sex-fn? sum-fn))
+  (test #t (sex-fn-public? sum-fn))
+  (test 'float (sex-fn-return-type sum-fn))
+  (test 'sum (sex-fn-name sum-fn))
+  (test '((a int) (b int)) (sex-fn-arglist sum-fn))
+  (test '(pub fn sum ((a int) (b int)) float) (sex-fn-prototype sum-fn))
+  (test '((return (cast (+ a b) float))) (sex-fn-body sum-fn))
+
+  (test-assert (sex-fn? '(extern fn foo () void)))
+  (test 'foo (sex-fn-name '(extern fn foo () void)))
+  (test #f (sex-fn? '(struct point ((x int)))))
+
+  (let ((sex-code
+         '((defmacro (sum-var name a b c)
+             `(var ,name ,(+ a b c)))
+
+           (sum-var v 1 2 3))))
+
+    (test '((var v 6)) (semen-process sex-code)))
+
+;;; Macro expansion
+
+  (define (form-identity form env)
+    form)
+
+  (test 'a (walk-form 'a form-identity (make-hash-table)))
+  (test '(a b c) (walk-form '(a b c) form-identity (make-hash-table)))
+
+  (test 'a (macro-expand 'a))
+  (test '(a b c) (macro-expand '(a b c)))
+
+  (let ((sex-code-macro
+         '((defmacro (x10 a)
+             `(* 10 ,a))
+
+           (fn foo ((a int) (b int)) void
+               (return (+ a (x10 b)))))))
+
+    (test '((fn foo ((a int) (b int)) void
+                (return (+ a (* 10 b)))))
+          (semen-process sex-code-macro)))
+
+;;; Docstrings are lifted out as comment forms sitting before the
+;;; declaration. A string later in a body is left alone.
+
+  (test '((comment "Greet NAME.")
+          (fn greet ((name (* char))) void
+              (printf "Hello %s!\n" name)))
+        (semen-process
+         '((fn greet ((name (* char))) void
+               "Greet NAME."
+               (printf "Hello %s!\n" name)))))
+
+  (test '((comment "Public entry.")
+          (pub fn main () int
+               (return 0)))
+        (semen-process
+         '((pub fn main () int
+                "Public entry."
+                (return 0)))))
+
+  ;; A prototype whose only "body" is a docstring stays a prototype
+  (test '((comment "Forward.")
+          (fn helper ((a int)) int))
+        (semen-process
+         '((fn helper ((a int)) int
+               "Forward."))))
+
+  (test '((fn f () void (g) "not a docstring"))
+        (semen-process
+         '((fn f () void (g) "not a docstring"))))
+
+  ;; `;' comments before the string are skipped when looking for it,
+  ;; and stay in the body
+  (test '((comment "Kept.")
+          (fn f () void (comment " note") (g)))
+        (semen-process
+         '((fn f () void (comment " note") "Kept." (g)))))
+
+  (test '((comment "A 2D point.")
+          (struct t-doc-pt ((x int) (y int))))
+        (semen-process
+         '((struct t-doc-pt "A 2D point." ((x int) (y int))))))
+
+  (test '((x int) (y int))
+        (get-fields 't-doc-pt))
+
+  (test '((comment "RGB.")
+          (enum t-doc-color (red green blue)))
+        (semen-process
+         '((enum t-doc-color "RGB." (red green blue)))))
+
+  (test '((comment "Either.")
+          (union t-doc-val ((i int) (f float))))
+        (semen-process
+         '((union t-doc-val "Either." ((i int) (f float))))))
+)

tests/sex-macros.module.scm

@@ -0,0 +1,3 @@
+(module sex-macros
+    *
+  "../sex-macros.scm")

tests/sex-modules.module.scm

@@ -0,0 +1,3 @@
+(module sex-modules
+    *
+  "../sex-modules.scm")

tests/sex-programs/comments.sex

@@ -0,0 +1,13 @@
+(input)
+(output "start" "end")
+(return 0)
+
+;;; A top-level comment, preserved into the generated C.
+(include stdio.h)
+
+;; Another top-level comment, right before the function.
+(pub fn main () int
+  ;; a comment in statement position
+  (puts "start")
+  (puts "end") ; a trailing comment after a statement
+  (return 0))

tests/sex-programs/feature-flags.sex

@@ -0,0 +1,25 @@
+(compilation "-f alpha -f beta,gamma --features=delta --no-platform-features")
+(input)
+(output "alpha" "beta" "gamma" "delta" "elsewhere")
+(return 0)
+
+;;; The flags naming the features, in every spelling sexc takes. This
+;;; is not pedantry about the command line: sextest reads the program
+;;; itself and prints the surviving forms to sexc, so a spelling it
+;;; does not recognise leaves the guards below resolved against the
+;;; wrong set -- quietly, since the test then checks the output of a
+;;; program it did not mean to compile.
+;;;
+;;; --no-platform-features is what makes `#-unix' true wherever this is
+;;; compiled, and it has to be honoured on both sides for that to hold.
+
+(include stdio.h)
+
+(pub fn main () int
+  #+alpha (puts "alpha")
+  #+beta (puts "beta")
+  #+gamma (puts "gamma")
+  #+delta (puts "delta")
+  #-unix (puts "elsewhere")
+  #+unix (puts "here")
+  (return 0))

tests/sex-programs/features.sex

@@ -0,0 +1,23 @@
+(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))

tests/sex-programs/hello-world.sex

@@ -0,0 +1,13 @@
+(input "Sextest")
+(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
+(return 255)
+
+(include stdio.h)
+
+(pub fn main ((argc int) (argv  [* const char])) int
+  (puts "Hello from Sex!")
+  (var name [char 512])
+  (puts "What is your name?")
+  (scanf "%s" (cast (& name) (* char)))
+  (printf "Hello, %s!\n" name)
+  (return 255))

tests/sex-programs/list-macros.sex

@@ -0,0 +1,48 @@
+(pub defmacro (list-T type)
+  (let ((list-type (cat 'list- type)))
+    `(struct ,list-type
+       ((value ,type)
+        (next (* struct ,list-type))))))
+
+(pub defmacro (make-list-T type is-public?)
+  (let ((list-type (list 'struct (cat 'list- type)))
+        (fn-name (cat 'make-list- type)))
+    `(,@(if is-public? '(pub) '()) fn ,fn-name () (* ,list-type)
+      (var list (* ,list-type) (cast  (malloc (sizeof ,list-type)) (* ,list-type)))
+      (= (-> list next) NULL)
+      (return list))))
+
+(pub defmacro (add-value-list-T type is-public?)
+  (let ((list-type (list 'struct (cat 'list- type)))
+        (fn-name (cat 'add-value-list- type)))
+    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list * ,list-type) (value ,type)) void
+      (while (!= (-> list next) NULL)
+        (= list (-> list next)))
+      (= (-> list next) (,(cat 'make-list- type)))
+      (= (-> list value) value))))
+
+(pub defmacro (length-list-T type is-public?)
+  (let ((fn-name (cat 'length-list- type))
+        (list-type (list 'struct (cat 'list- type))))
+    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list ,(cons '* list-type))) size-t
+      (var n size-t 0)
+      (while (!= (-> list next) NULL)
+        (= list (-> list next))
+        (++ n))
+      (return n))))
+
+(pub defmacro (is-empty-list-T type is-public?)
+  `(,@(if is-public? '(pub) '()) fn ,(cat 'is-empty-list- type)
+    ((list ,(list '* 'struct (cat 'list- type))))
+    bool
+    (return (== (-> list next) NULL))))
+
+(pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
+  (let ((list-var-2 (cat list-var '-2)))
+    `(do
+      (var ,list-var-2 (* ,list-type) ,list-var)
+      (var ,elt-var ,elt-type (-> ,list-var-2 value))
+      (while (!= (-> ,list-var-2 next) NULL)
+        ,what-do
+        (= ,list-var-2 (-> ,list-var-2 next))
+        (= ,elt-var (-> ,list-var-2 value))))))

tests/sex-programs/lists.sex

@@ -0,0 +1,50 @@
+(input)
+(output "Size of the list: 0"
+        "Size of the list: 2"
+        "3 4 "
+        "Size of the list: 2")
+(return 0)
+
+(include stdlib.h)
+(include stddef.h)
+(include stdio.h)
+
+(import list-macros)
+
+(struct foo
+  ((a-field float)
+   (b int)
+   (c (* const char))
+   (not (fn ((val bool)) bool))))
+
+(var f (struct foo))
+
+(list-T int)
+(make-list-T int #f)
+(add-value-list-T int #f)
+(length-list-T int #f)
+(is-empty-list-T int #f)
+
+(extern fn puk ((a int) (b float)) void)
+(pub fn baz () bool
+  (return true))
+
+(extern var i int)
+(var j int)
+(pub var k int)
+
+(pub fn main () int
+     (var l (* struct list-int) (make-list-int))
+     (printf "Size of the list: %lu\n" (length-list-int l))
+     (add-value-list-int l 3)
+     (add-value-list-int l 4)
+     (printf "Size of the list: %lu\n" (length-list-int l))
+     (list-for-each (struct list-int) l int v
+       (printf "%d " v))
+     (printf "\n")
+     (printf "Size of the list: %lu\n" (length-list-int l))
+     (return 0))
+
+(pub fn print-list ((l (* const struct list-int))) void
+     (list-for-each (const struct list-int) l int v (printf "%d " v))
+     (printf "\n"))

tests/sex-programs/serialize.sex

@@ -0,0 +1,37 @@
+(input)
+(output "box { w=3 h=4 label=wide }")
+(return 0)
+
+;;; A macro generating code from the type database: it is handed a
+;;; struct name, walks its fields with map-fields, and picks a printf
+;;; conversion per field with type-match. Exercises semen registering
+;;; the struct and the macro reading it back at expansion time.
+
+(include stdio.h)
+
+(defmacro (print-struct type-name)
+  (let ((printers
+         (map-fields type-name
+           (lambda (name type)
+             `(printf ,(string-append " " (symbol->string name) "="
+                                      (type-match type
+                                        (int            "%d")
+                                        ((* const char) "%s")
+                                        (else (error "print-struct: unsupported field type"
+                                                     name type))))
+                      (-> v ,name))))))
+    (if (not printers)
+        (error "print-struct: no such struct" type-name)
+        `(fn ,(cat 'print- type-name) ((v (* const struct ,type-name))) void
+           (printf ,(string-append (symbol->string type-name) " {"))
+           ,@printers
+           (printf " }\n")))))
+
+(struct box ((w int) (h int) (label (* const char))))
+
+(print-struct box)
+
+(pub fn main () int
+  (var b (struct box) #(3 4 "wide"))
+  (print-box (& b))
+  (return 0))

tests/sex-programs/unicode.sex

@@ -0,0 +1,24 @@
+(input)
+(output "café 日本語 🍺" "café1" "naïve: 3")
+(return 0)
+
+;;; Non-ASCII string literals and identifiers.
+;;;
+;;; Two things are pinned here. First, a character outside printable
+;;; ASCII must reach the C compiler as the UTF-8 bytes it was written
+;;; as. Octal escapes are used because C's \x escape swallows every
+;;; following hex digit: "café1" is the case that catches it, since a
+;;; hex escape would run "\xc3\xa9" into the "1" and produce a value out
+;;; of range for a char. Second, a kebab-case identifier containing
+;;; non-ASCII characters must survive unkebabify intact -- getting this
+;;; wrong truncates the name silently, and the program still compiles
+;;; and runs, just under a different name than the one written.
+
+(include stdio.h)
+
+(pub fn main () int
+  (puts "café 日本語 🍺")
+  (puts "café1")
+  (var naïve-count int 3)
+  (printf "naïve: %d\n" naïve-count)
+  (return 0))

tests/sexc.module.scm

@@ -0,0 +1,3 @@
+(module sexc
+    *
+  "../sexc.scm")

tests/types.module.scm

@@ -0,0 +1,15 @@
+(module types
+    (add-struct
+     add-union
+     add-enum
+     add-typedef
+     add-define
+
+     type-match
+     map-fields
+
+     get-type-info
+     get-tag-info
+     get-fields
+     get-underlying-type)
+  "../types.scm")

tests/types.scm

@@ -1 +1,174 @@
-(test "char *" (to-c-type '(%pointer char)))
+;;; The type database.
+;;;
+;;; Names here are prefixed so they cannot collide with the types the
+;;; other suites register: the database is one table in the linked
+;;; binary, and semen fills it in whenever a suite compiles a struct.
+
+(import types)
+
+(test-group "types"
+
+  (add-struct 't-point '(struct t-point ((x int) (y int))))
+  (test "fields come back as (name type)"
+        '((x int) (y int))
+        (get-fields 't-point))
+  (test "and the whole entry is tagged"
+        '(struct t-point ((x int) (y int)))
+        (get-type-info 't-point))
+
+  ;; Fields are written with the type last, so one entry can declare
+  ;; several names. They come back as one field each.
+  (add-struct 't-settings
+              '(pub struct t-settings ((x y w h u32) (title (* const char)))))
+  (test "names sharing a type are split apart"
+        '((x u32) (y u32) (w u32) (h u32) (title (* const char)))
+        (get-fields 't-settings))
+
+  (add-struct 't-commented '(struct t-commented ((comment " hi") (a int))))
+  (test "a comment among the fields is not a field"
+        '((a int))
+        (get-fields 't-commented))
+
+  (add-union 't-value '(union t-value ((i int) (f float))))
+  (test "unions have fields too"
+        '((i int) (f float))
+        (get-fields 't-value))
+
+  (add-enum 't-color '(enum t-color (red green blue)))
+  (test "enums keep their values"
+        '(enum t-color (red green blue))
+        (get-type-info 't-color))
+  (test "but have no fields"
+        #f
+        (get-fields 't-color))
+
+  (add-typedef 't-u8 '(typedef t-u8 uint8-t))
+  (test "a typedef resolves to its target"
+        'uint8-t
+        (get-underlying-type 't-u8))
+  (add-typedef 't-byte '(typedef t-byte t-u8))
+  (test "and chains are followed to the end"
+        'uint8-t
+        (get-underlying-type 't-byte))
+  (test "a struct is not a typedef"
+        #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))
+
+  ;; C keeps typedefs and ordinary identifiers apart, and the canonical way
+  ;; to declare a struct uses both names at once. Neither declaration
+  ;; may stand on the other.
+  (add-struct 't-node '(struct t-node ((next (* t-node)) (v int))))
+  (add-typedef 't-node '(typedef t-node (struct t-node)))
+  (test "a typedef of a struct's own name keeps the struct reachable"
+        '((next (* t-node)) (v int))
+        (get-fields 't-node))
+  (test "and the tag is there under its own name"
+        '(struct t-node ((next (* t-node)) (v int)))
+        (get-tag-info 't-node))
+  (add-struct 't-rect '(struct t-rect ((w int) (h int))))
+  (add-define 't-rect '(define t-rect 3))
+  (test "a define of a tag's name does not hide the fields"
+        '((w int) (h int))
+        (get-fields 't-rect))
+
+  ;; A type built over a struct is not that struct. Handing back the
+  ;; element's fields would have a macro write v->x for an array
+  (add-typedef 't-points '(typedef t-points (¤ t-point 4)))
+  (test "an array of a struct has no fields of its own"
+        #f
+        (get-fields 't-points))
+  (add-typedef 't-point-p '(typedef t-point-p (* t-point)))
+  (test "nor does a pointer to one"
+        #f
+        (get-fields 't-point-p))
+  (add-typedef 't-cb '(typedef t-cb (fn ((t-point)) void)))
+  (test "nor a function type over one"
+        #f
+        (get-fields 't-cb))
+
+  ;; 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"
+        '(define t-maxn (8))
+        (get-type-info 't-maxn))
+
+  ;; map-fields walks an aggregate, handing each field to a function.
+  (test "map-fields visits every field"
+        '((x int) (y int))
+        (map-fields 't-point (lambda (name type) (list name type))))
+  (test "and splits shared names apart too"
+        '(x y w h title)
+        (map-fields 't-settings (lambda (name type) name)))
+  ;; An enumerator's type is the enum itself.
+  (test "enum values are fields whose type is the enum"
+        '((red (enum t-color)) (green (enum t-color)) (blue (enum t-color)))
+        (map-fields 't-color (lambda (name type) (list name type))))
+  (test "a typedef has no fields to map"
+        #f
+        (map-fields 't-u8 (lambda (name type) name)))
+  (test "nor does an undeclared name"
+        #f
+        (map-fields 't-nothing (lambda (name type) name)))
+
+  ;; type-match compares whole types, since a type is a form.
+  (test "a bare type matches"      'yes (type-match 'int (int 'yes) (else 'no)))
+  (test "so does a compound one"   'yes (type-match '(* const char)
+                                                    (int 'no)
+                                                    ((* const char) 'yes)
+                                                    (else 'no)))
+  ;; The [int 10] of the docstring is Sex notation: the Sex reader turns
+  ;; brackets into a ¤ form, while CHICKEN reads them as plain parens.
+  ;; In a .scm file the array type has to be written out.
+  (test "and an array"             'yes (type-match '(¤ int 10)
+                                                    ((¤ int 10) 'yes)
+                                                    (else 'no)))
+  (test "else catches the rest"    'no  (type-match '(* void) (int 'yes) (else 'no)))
+  (test "a near miss does not match" 'no (type-match '(¤ int 20)
+                                                     ((¤ int 10) 'yes)
+                                                     (else 'no)))
+  (test "no clause matching and no else is #f"
+        #f
+        (type-match 'float (int 'yes)))
+
+  (test "an undeclared name has no entry"
+        #f
+        (get-type-info 't-never-declared))
+  (test "and no fields"
+        #f
+        (get-fields 't-never-declared)))

tests/utils.module.scm

@@ -0,0 +1,3 @@
+(module utils
+    *
+  "../utils.scm")

tests/utils.scm

@@ -0,0 +1,24 @@
+(import utils)
+
+(test-group "utils"
+
+  (test
+   '((1) (2) (3))
+   (list-split '(1 * 2 * 3) '*))
+
+  (test
+   '((1 2 3))
+   (list-split '(1 2 3) '*))
+
+  (test
+   '(() (1) (2) (3) ())
+   (list-split '(* 1 * 2 * 3 *) '*))
+
+  (test
+   '((const) (const struct something))
+   (list-split '(const * const struct something) '*))
+
+  (test
+   '(1 * 2 * 3)
+   (list-join '(1 2 3) '*))
+)

tools/sextest/Makefile

@@ -0,0 +1,23 @@
+CHICKEN_C = csc
+CSC_FLAGS += -K prefix -static
+MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
+
+ROOT = ../..
+
+# sextest reuses sexc's reader (and its utils dependency) instead of
+# duplicating the S-expression reader. The module wrappers here include
+# the shared sources from the project root.
+
+sextest: sextest.scm reader.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest -link reader,utils
+
+utils.o: utils.module.scm $(ROOT)/utils.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
+
+reader.o: reader.module.scm $(ROOT)/reader.scm utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
+
+clean:
+	rm -f *.o *.import.scm *.link sextest
+
+.PHONY: clean

tools/sextest/README.org

@@ -0,0 +1,26 @@
+* Sextest
+A tool for testing Sex compiler by using test programs.
+The tools compiles test programs, then runs with provided
+input, checking the output and return code.
+
+* Test format
+The test program is just a regular Sex program, which may contain
+additional toplevel forms, to define compilation parameters, input to
+the program, and expected output and return code. Default value for
+compilation, input and output is an empty strings. For the return code
+it is 0.
+
+* Example
+some-test.sex:
+#+begin_src
+(compilation "-- -O2")
+(input "")
+(output "Hello world!")
+(return 123)
+
+(include stdio.h)
+
+(pub fn main () int
+  (puts "Hello World!")
+  (return 123))
+#+end_src

tools/sextest/hello-sextest.sex

@@ -0,0 +1,13 @@
+(input "Sextest")
+(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
+(return 255)
+
+(include stdio.h)
+
+(pub fn main ((argc int) (argv  [* const char])) int
+  (puts "Hello from Sex!")
+  (var name [char 512])
+  (puts "What is your name?")
+  (scanf "%s" (cast (& name) (* char)))
+  (printf "Hello, %s!\n" name)
+  (return 255))

tools/sextest/reader.module.scm

@@ -0,0 +1,6 @@
+(module reader (read-from-file
+                read-raw-forms
+
+                current-features
+                platform-features)
+  "../../reader.scm")

tools/sextest/sextest.scm

@@ -0,0 +1,194 @@
+(import scheme
+        (scheme base)                   ; let-values
+        brev-separate
+        (chicken base)
+        (chicken file)
+        (chicken io)
+        (chicken pathname)
+        (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?
+
+(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))
+
+;;; The feature flags of 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.
+;;;
+;;; Returns the named features and whether the host's own are in play
+(define (compilation-features settings)
+  (let ((compilation (assoc 'compilation settings)))
+    (let loop ((flags (if compilation
+                          (string-split (cadr compilation))
+                          (list)))
+               (features (list))
+               (platform #t))
+      (define (add names rest)
+        (loop rest
+              (append features (map string->symbol (string-split names ",")))
+              platform))
+      (cond
+       ((null? flags) (values features platform))
+       ;; past `--' the flags are the C compiler's
+       ((string=? (car flags) "--") (values features platform))
+       ((string=? (car flags) "--no-platform-features")
+        (loop (cdr flags) features #f))
+       ((and (member (car flags) '("-f" "--features")) (pair? (cdr flags)))
+        (add (cadr flags) (cddr flags)))
+       ((string-prefix? "--features=" (car flags))
+        (add (substring (car flags) 11) (cdr flags)))
+       ((string-prefix? "-f" (car flags))
+        (add (substring (car flags) 2) (cdr flags)))
+       (else (loop (cdr flags) features platform))))))
+
+(define (process-file target-path)
+  (let ((first-pass (split-settings (read-raw-forms target-path))))
+    (let-values (((features platform?) (compilation-features (car first-pass))))
+      (if (and (null? features) platform?)
+          first-pass
+          (parameterize ((current-features
+                          (append (if platform? (platform-features) (list))
+                                  features)))
+            (split-settings (read-raw-forms target-path)))))))
+
+(define (compile src compilation 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.
+    (let* ((proc (process compiler (append (list "-o" compiled-file) flags)))
+           (sexc-stdin (process-input-port proc)))
+      (with-output-to-port sexc-stdin
+        (fn (map (fn (fmt #t x)) src)))
+      (close-output-port sexc-stdin)
+      (call-with-values
+          (fn (process-wait proc))
+        (lambda (pid exited retcode)
+          (if (= 0 retcode)
+              compiled-file
+              #f))))))
+
+(define (run-and-check file in out ret)
+  (let* ((proc (process file))
+         (out-port (process-output-port proc))   ; the program's stdout
+         (in-port  (process-input-port proc)))   ; the program's stdin
+    (let ()
+      (when in
+        (with-output-to-port in-port
+          (fn (map (fn (fmt #t x))
+                   (cdr in))))
+        (close-output-port in-port))
+      (let ((out-lines
+             (with-input-from-port out-port
+               (fn
+                (let loop ((line (read-line))
+                           (lines (list)))
+                  (if (eof-object? line)
+                      (reverse lines)
+                      (loop (read-line)
+                            (cons line lines)))))))
+            (ret-code
+             (call-with-values
+                 ;; TODO: what if the program hangs
+                 ;; we need some kind of timeout mechanism
+                 (fn
+                  (process-wait proc))
+               (lambda (pid exited retcode)
+                 retcode))))
+        (and
+         (if (not (= ret-code (cadr ret)))
+             (begin
+               (fmt #t "Retcode differs. Got " ret-code ", expected " (cadr ret) nl)
+               #f)
+             #t)
+
+         (if (not (equal? out-lines (cdr out)))
+             (begin
+               (fmt #t "Output differs. Got " out-lines " expected " (cdr out) nl)
+               #f)
+             #t))))))
+
+(define opts-grammar
+  `((sexc ,(fmt #f "Path to sexc compiler. Defaults to value of SEXC" nl
+                (pad 26) "environment variable, ot if it's empty, to sexc" nl )
+          (required #f)
+          (value #t))
+    (help "Show this help"
+          (required #f)
+          (value #f)
+          (single-char #\h))))
+
+(define (process-test-file sexc path)
+  (set-environment-variable! "SEX_MODULE_PATH"
+                             (normalize-pathname (make-absolute-pathname
+                                                  (current-directory)
+                                                  (pathname-directory path))))
+  (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)))
+    (if (not compiled-file)
+        (begin (fmt #t "Failed to compile " path nl)
+               #f)
+        (if (run-and-check
+             compiled-file
+             (assoc 'input settings)
+             (assoc 'output settings)
+             (assoc 'return settings))
+            (begin (fmt #t ".")
+                   #t)
+            (begin (fmt #t ",")
+                   #f)))))
+
+(define (main)
+  (let ((args (getopt-long (command-line-arguments)
+                           opts-grammar)))
+    (when (assoc 'help args)
+      (print-help)
+      (exit 0))
+    (when (null? (cdr (assoc '@ args)))
+      (fmt #t "Missing target file" nl)
+      (print-help)
+      (exit 1))
+    (unless
+        (foldl (lambda (a b) (and a b))
+               #t
+               (map (fn (process-test-file (assoc 'sexc args) x))
+                    (cdr (assoc '@ args))))
+      ;; TODO: add more verbose and human readable output and reporting
+      (fmt #t nl)
+      (exit 2))
+    (fmt #t nl)
+    (exit 0)))
+
+(main)

tools/sextest/utils.module.scm

@@ -0,0 +1,21 @@
+(module utils
+    (get-env-var
+     set-working-directory
+     to-absolute-pathname
+     comment-form?
+     strip-header-comments
+     list-split
+     list-join
+     recons
+     current-source-file
+     set-form-source!
+     form-source
+     form-file
+     form-line
+     copy-form-source!
+     stamp-form-source!
+     form-location
+     sex-error
+     with-directory
+     )
+  "../../utils.scm")

types.module.scm

@@ -0,0 +1,15 @@
+(module types
+    (add-struct
+     add-union
+     add-enum
+     add-typedef
+     add-define
+
+     type-match
+     map-fields
+
+     get-type-info
+     get-tag-info
+     get-fields
+     get-underlying-type)
+    "types.scm")

types.scm

@@ -0,0 +1,179 @@
+;;; The type database.
+;;;
+;;; Every named aggregate, typedef and define the semantic engine
+;;; walks past is recorded here, so that macros (or other forms) can
+;;; ask what a type is made of. That is what lets a macro generate
+;;; code from a struct's fields given nothing but its name.
+;;;
+;;; Entries are filled in as toplevel forms are processed, in order, so
+;;; a type has to be declared before the macro that asks about it.
+
+(import
+  scheme
+  (scheme base)
+  (chicken base)
+  srfi-1
+  srfi-69)
+
+;;; Two namespaces: `struct point' and a `point' typedef are separate
+;;; declarations. Tags -- struct, union and enum alike -- share the
+;;; second table between them
+(define +type-db+ (make-hash-table))    ; typedefs and defines
+(define +tag-db+ (make-hash-table))     ; struct, union and enums
+
+(define (strip-pub form)
+  (if (eq? (car form) 'pub) (cdr form) form))
+
+(define (comment-form? f)
+  (and (pair? f) (eq? (car f) 'comment)))
+
+;;; Fields are written with the type last and one or more names before
+;;; it, so ((x y int) (p (* char))) describes three fields. Flatten that
+;;; into one (name type) per field, which is what a caller wants.
+(define (normalize-fields fields)
+  (append-map
+   (lambda (field)
+     (if (comment-form? field)
+         (list)
+         (let ((type (last field))
+               (names (drop-right field 1)))
+           (map (lambda (name) (list name type)) names))))
+   (remove comment-form? fields)))
+
+;;; ([pub] struct name (fields ...) . attrs)
+(define (aggregate-fields form)
+  (let ((f (strip-pub form)))
+    (if (and (pair? (cddr f)) (list? (caddr f)))
+        (caddr f)
+        (list))))
+
+(define (add-struct name form)
+  (hash-table-set! +tag-db+ name
+                   (list 'struct name (normalize-fields (aggregate-fields form)))))
+
+(define (add-union name form)
+  (hash-table-set! +tag-db+ name
+                   (list 'union name (normalize-fields (aggregate-fields form)))))
+
+;;; ([pub] enum name (value ...))
+(define (add-enum name form)
+  (let ((f (strip-pub form)))
+    (hash-table-set! +tag-db+ name
+                     (list 'enum name (if (and (pair? (cddr f)) (list? (caddr f)))
+                                          (caddr f)
+                                          (list))))))
+
+;;; ([pub] typedef new-name target)
+(define (add-typedef name form)
+  (hash-table-set! +type-db+ name
+                   (list 'typedef name (last (strip-pub form)))))
+
+;;; (define name value ...) -- a C #define, kept so a macro can read a
+;;; compile-time constant rather than re-parse the source.
+(define (add-define name form)
+  (hash-table-set! +type-db+ name
+                   (list 'define name (cddr (strip-pub form)))))
+
+(define (get-tag-info name)
+  (hash-table-ref/default +tag-db+ name #f))
+
+;;; First look up the ordinary identifier, then tag of that id when
+;;; no ordinary one was declared, as C does
+(define (get-type-info name)
+  (or (hash-table-ref/default +type-db+ name #f)
+      (get-tag-info name)))
+
+;;; ((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)))
+    (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.
+(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 (target-tag target)
+  (cond
+   ((symbol? target) target)
+   ((and (pair? target)
+         (memq (car target) '(struct union enum))
+         (pair? (cdr target))
+         (symbol? (cadr target)))
+    (cadr target))
+   (else #f)))
+
+(define (resolve-type-info name)
+  (let ((info (resolve-ordinary-type-info name)))
+    (if (and info (memq (car info) '(struct union enum)))
+        info
+        (or (get-tag-info name) info))))
+
+(define (resolve-ordinary-type-info name)
+  (let ((info (get-type-info name)))
+    (and info
+         (if (eq? (car info) 'typedef)
+             (let ((tag (target-tag (get-underlying-type name))))
+               ;; A typedef target is written in type position, where
+               ;; `struct point' means the tag
+               (and tag (or (get-tag-info tag) (get-type-info tag))))
+             info))))
+
+;;; Type matcher macro
+;;; (type-match type
+;;;   (int ...)
+;;;   ((* const char) ...)
+;;;   ([int 10] ...)
+;;;   (else ...))
+;;;
+;;; A type is a form, not an atom, so this compares with equal? rather
+;;; than dispatching like `case'. Patterns are literal types and are not
+;;; evaluated; `else' is optional and the whole thing is #f when nothing
+;;; matches and there is no else.
+(define-syntax type-match
+  (syntax-rules (else)
+    ((_ type) #f)
+    ((_ type (else body ...)) (begin body ...))
+    ((_ type (pattern body ...) clause ...)
+     (if (equal? type 'pattern)
+         (begin body ...)
+         (type-match type clause ...)))))
+
+;;; Map function to each field/value of a structure/union/enum
+;;; For enums, field-type is the type of the enum (since C 23)
+;;; (map-fields type-name
+;;;     (lambda (field-name field-type) ...))
+;;;
+;;; Returns #f if nothing of that name was declared
+(define (map-fields struct-union-enum fn)
+  (let ((info (resolve-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.
+           ((enum)
+            (let ((type (list 'enum (cadr info))))
+              (map (lambda (value) (fn value type))
+                   (caddr info))))
+           (else #f)))))

utils.macros.scm

@@ -1,15 +0,0 @@
-(define-syntax prog1
-  (syntax-rules ()
-    ((prog1 form . forms)
-     (let ((res form))
-       (begin . forms)
-       res))))
-
-(define-syntax with-directory
-  (syntax-rules ()
-    ((with-directory path form . forms)
-     (let ((current-dir (current-directory)))
-       (set-working-directory path)
-       (prog1
-        (begin form . forms)
-        (change-directory current-dir))))))

utils.module.scm

@@ -0,0 +1,21 @@
+(module utils
+    (get-env-var
+     set-working-directory
+     to-absolute-pathname
+     comment-form?
+     strip-header-comments
+     list-split
+     list-join
+     recons
+     current-source-file
+     set-form-source!
+     form-source
+     form-file
+     form-line
+     copy-form-source!
+     stamp-form-source!
+     form-location
+     sex-error
+     with-directory
+     )
+  "utils.scm")

utils.scm

@@ -1,10 +1,27 @@
-(declare (unit utils))
-
-(include "utils.macros.scm")
-
 (import
+  scheme
+  (scheme base)                         ; make-parameter
+  (chicken base)
   (chicken pathname)
-  (chicken process-context))
+  (chicken process-context)
+  srfi-1
+  srfi-69)
+
+(define-syntax prog1
+  (syntax-rules ()
+    ((prog1 form . forms)
+     (let ((res form))
+       (begin . forms)
+       res))))
+
+(define-syntax with-directory
+  (syntax-rules ()
+    ((with-directory path form . forms)
+     (let ((current-dir (current-directory)))
+       (set-working-directory path)
+       (prog1
+        (begin form . forms)
+        (change-directory current-dir))))))
 
 (define (get-env-var name)
   (get-environment-variable name))
@@ -17,3 +34,117 @@
         (make-absolute-pathname
          (current-directory)
          (pathname-directory file))))))
+
+(define (to-absolute-pathname pathname)
+  (if (absolute-pathname? pathname)
+      pathname
+      (make-absolute-pathname
+       (current-directory)
+       pathname)))
+
+(define (comment-form? form)
+  (and (pair? form) (eq? (car form) 'comment)))
+
+;;; Remove the comment forms from the first COUNT elements of FORM --
+;;; its header -- so that the positional accessors reading it are not
+;;; shifted by one
+(define (strip-header-comments form count)
+  ;; This always rebuilds the list, so the location has to be carried
+  ;; over explicitly -- otherwise every form loses it
+  (copy-form-source!
+   form
+   (let loop ((rest form) (kept 0) (acc (list)))
+     (cond
+      ((null? rest) (reverse acc))
+      ((= kept count) (append (reverse acc) rest))
+      ((comment-form? (car rest)) (loop (cdr rest) kept acc))
+      (else (loop (cdr rest) (+ kept 1) (cons (car rest) acc)))))))
+
+(define (list-split src-list split-elt)
+  ;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6))
+  (fold (lambda (elt acc)
+          (if (eq? elt split-elt)
+              (append acc (list (list)))
+              (append (drop-right acc 1)
+                      (list (append (last acc) (list elt))))))
+        (list (list))
+        src-list))
+
+(define (list-join lists join-by)
+  (drop-right
+   (fold (lambda (elt acc)
+           (append acc (list elt) (list join-by)))
+         (list)
+         lists)
+   1))
+
+;;; Reconstruct form
+(define (recons old-cons new-car new-cdr)
+  (if (and (eq? new-car (car old-cons))
+           (eq? new-cdr (cdr old-cons)))
+      old-cons
+      ;; A rebuilt cell is still the same source form, so it keeps the
+      ;; same location
+      (copy-form-source! old-cons (cons new-car new-cdr))))
+
+;;; Source-location map.
+;;; Our hand-written reader records the source location of each form
+;;; here, keyed by the form's cons cell (eq?). This replaces CHICKEN's
+;;; read-with-source-info / get-line-number, which only works when forms
+;;; are produced by the built-in `read'.
+;;;
+;;; A location is (file . line). The file matters because imported
+;;; modules paste their public forms into the current unit: those forms
+;;; originate in another file and must be reported as such
+(define +form-sources+ (make-hash-table eq?))
+
+;;; The file `parse-all' is currently reading. Bound by the reader
+(define current-source-file (make-parameter "<unknown>"))
+
+(define (set-form-source! form file line)
+  (hash-table-set! +form-sources+ form (cons file line)))
+
+(define (form-source form)
+  (hash-table-ref/default +form-sources+ form #f))
+
+(define (form-file form)
+  (let ((src (form-source form)))
+    (and src (car src))))
+
+(define (form-line form)
+  (let ((src (form-source form)))
+    (and src (cdr src))))
+
+(define (copy-form-source! from to)
+  "Give TO the location of FROM, if FROM has one. Returns TO, so it can
+wrap a form-building expression."
+  (let ((src (form-source from)))
+    (when (and src (pair? to))
+      (hash-table-set! +form-sources+ to src)))
+  to)
+
+;;; Diagnostics
+;;;
+;;; Every form carries a location now, so an error can say where the
+;;; wrong code was written
+(define (form-location form)
+  "\"file:line: \" for FORM, or \"\" when it has none"
+  (let ((src (form-source form)))
+    (if src
+        (string-append (car src) ":" (number->string (cdr src)) ": ")
+        "")))
+
+(define (sex-error form message . args)
+  "Signal an error about FORM, prefixed with where it was written."
+  (apply error (string-append (form-location form) message) args))
+
+(define (stamp-form-source! form src)
+  "Give FORM and every subform that has none the location SRC. Used for
+macro expansions, which inherit the location of the call site the way a
+cpp macro does. Forms that already have a location keep it."
+  (when (and src (pair? form))
+    (unless (form-source form)
+      (hash-table-set! +form-sources+ form src))
+    (stamp-form-source! (car form) src)
+    (stamp-form-source! (cdr form) src))
+  form)