implement compound and designated literals support

Lambdas rotted because there wasn't any test for them, and after
return type moved to the end, lambdas stayed assumning it in the
front. We fix this and add test program

.gitea/workflows/build.yaml

@@ -0,0 +1,67 @@
+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
+
+      - name: Install dependencies
+        run: make deps
+
+      - name: Build sexc
+        run: make && ./sexc --help
+
+      - name: Run tests
+        run: make check

.github/workflows/build.yaml

@@ -1,55 +0,0 @@
-name: Sex CI
-
-on:
-  push:
-    branches: [ main ]
-  pull_request:
-    branches: [ main ]
-
-jobs:
-  build-linux:
-
-    runs-on: ubuntu-latest
-
-    steps:
-    - uses: actions/checkout@v3
-    - name: Install chicken
-      run: |
-        wget -N https://code.call-cc.org/releases/6.0.0/chicken-6.0.0.tar.gz
-        tar zxf chicken-6.0.0.tar.gz
-        sudo apt install -y make
-        make -C chicken-6.0.0 PLATFORM=linux
-        sudo make -C chicken-6.0.0 PLATFORM=linux install
-    - name: Install dependencies
-      # FIXME: [project-local deps]: use venv or something
-      # run: make deps
-      run: sudo chicken-install $(cat dependencies.txt)
-    - name: Make sure that sexc builds
-      # FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
-      # Without it there will be `Error: cannot load extension: fmt`.
-      run: make sexc && ./sexc --help
-    - name: Run tests
-      # FIXME: [project-local deps]: use local deps or build with -static
-      # run: make run-tests
-      run: make sex-tests && ./sex-tests
-
-  build-macos:
-
-    runs-on: macos-15
-
-    steps:
-    - uses: actions/checkout@v3
-    - name: Install chicken
-      run: brew install chicken make
-    - name: Install dependencies
-      # FIXME: [project-local deps]: use venv or something
-      # run: make deps
-      run: chicken-install $(cat dependencies.txt)
-    - name: Make sure that sexc builds
-      # FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
-      # Without it there will be `Error: cannot load extension: fmt`.
-      run: make sexc && ./sexc --help
-    - name: Run tests
-      # FIXME: [project-local deps]: use local deps or build with -static
-      # run: make run-tests
-      run: make sex-tests && ./sex-tests

.gitignore

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

Makefile

@@ -1,4 +1,6 @@
-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.
@@ -12,12 +14,42 @@ CSC_FLAGS += -K prefix -static
 #     error.
 # -c: Stop after compilation to object files. This one is obvious.
 
+# GNU directory variables. Command line overrides, e.g.
+#   make prefix=$(HOME)/.local install
+#   make DESTDIR=/tmp/stage prefix=/usr install
+prefix = /usr/local
+exec_prefix = $(prefix)
+bindir = $(exec_prefix)/bin
+INSTALL = install
+INSTALL_PROGRAM = $(INSTALL)
+
 MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
 
 # Order matters, since module check correctness on compilation
-MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
+MODULES = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
 OBJ = $(MODULES:%=%.o)
 
+DEPSFILE = dependencies.txt
+DEPSLOCK = eggs.lock
+EGGS_DIR := $(abspath .eggs)
+
+# Compiler's own repository (types.db, chicken.*), ignoring ambient venv vars.
+SYSTEM_CHICKEN_REPO := $(shell env \
+	-u CHICKEN_INSTALL_REPOSITORY -u CHICKEN_REPOSITORY_PATH \
+	-u CHICKEN_EGG_CACHE -u CHICKEN_INSTALL_PREFIX \
+	$(CHICKEN_INSTALL) -repository 2>/dev/null)
+CHICKEN_ABI := $(notdir $(SYSTEM_CHICKEN_REPO))
+EGGS_STAMP := $(EGGS_DIR)/.installed-$(CHICKEN_ABI)
+
+# Try project-local chicken repository first. In case it doesn't exist (packaging for distros),
+# system-wide repository will be used.
+unexport CHICKEN_INSTALL_REPOSITORY
+unexport CHICKEN_EGG_CACHE
+unexport CHICKEN_INSTALL_PREFIX
+export CHICKEN_REPOSITORY_PATH := $(EGGS_DIR):$(SYSTEM_CHICKEN_REPO)
+
+all: sexc
+
 sexc: $(OBJ) main.scm
 	$(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc
         # otherwise csc hangs, probably because it tries to compile to sexc.o first
@@ -28,6 +60,9 @@ sexc: $(OBJ) main.scm
 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
 
@@ -37,8 +72,8 @@ reader.o: reader.module.scm reader.scm utils.o
 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 utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,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
@@ -46,8 +81,8 @@ sex-fmt-c.o: sex-fmt-c.scm
 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 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,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:
@@ -58,15 +93,64 @@ sextest:
 	$(MAKE) -C ./tools/sextest sextest
 	cp ./tools/sextest/sextest .
 
-SEX_TEST_PROGRAMS = hello-world lists comments unicode
+SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \
+                    feature-flags lambdas compound-literals
 
-run-tests: sexc sex-tests sextest
-	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex)
+# 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_STAMP) deps-update: export CHICKEN_EGG_CACHE := $(EGGS_DIR)/cache
+$(EGGS_STAMP) deps-update: export CHICKEN_INSTALL_REPOSITORY := $(EGGS_DIR)
+$(EGGS_STAMP) deps-update: export CHICKEN_INSTALL_PREFIX := $(EGGS_DIR)
+$(EGGS_STAMP) deps-update: export CHICKEN_REPOSITORY_PATH := $(EGGS_DIR):$(SYSTEM_CHICKEN_REPO)
+
+$(EGGS_STAMP): $(DEPSLOCK)
+	mkdir -p $(CHICKEN_EGG_CACHE)
+	$(CHICKEN_INSTALL) -force -from-list $(DEPSLOCK)
+	touch $@
+
+deps: $(EGGS_STAMP)
+
+deps-update: $(DEPSFILE) deps-clean
+	mkdir -p $(CHICKEN_EGG_CACHE)
+	$(CHICKEN_INSTALL) -force $$(cat $(DEPSFILE))
+	# Local repo only: a system path here would leak distro eggs into the lock.
+	CHICKEN_REPOSITORY_PATH=$(EGGS_DIR) $(CHICKEN_STATUS) -list | sort > $(DEPSLOCK).tmp
+	mv $(DEPSLOCK).tmp $(DEPSLOCK)
+	touch $(EGGS_STAMP)
 
 clean:
 	rm -f $(OBJ) main.o
 	rm -f *.import.scm
 	rm -f *.link
 	rm -f sexc sex-tests sextest
+	$(MAKE) -C ./tests clean
+	$(MAKE) -C ./tests/modules clean
+	$(MAKE) -C ./tools/sextest clean
 
-.PHONY: clean run-tests sex-tests sextest
+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

@@ -12,16 +12,49 @@ Sex is statically typed, compiled general purpose language.
 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
+** Development
+#+begin_src sh
+  make deps
+  make
+#+end_src
 
-~chicken-install `cat dependencies.txt`~
+~make deps~ installs pinned eggs from ~eggs.lock~ into a project-local
+~.eggs/~ repository. ~dependencies.txt~ is the unpinned request list.
+To refresh ~eggs.lock~ after changing it:
 
-** Compilation
-~make~
+#+begin_src sh
+  make deps-update
+#+end_src
+
+** Packaging for system package managers
+- Depend ~sex~ package on Chicken-6 (with ~libchicken.a~) and all eggs from ~dependencies.txt~.
+- Compile and install with ~make~ (usually no other arguments required).
+- Move resulting ~sexc~ binary to the appropriate place.
+
+** 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
@@ -31,13 +64,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
- -C, --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 semantically processed Sex code
-                          (sort of IR). May be useful for debugging
  -o, --output=ARG         Write output to file. Default file name is a.out.
                           If -E or -m options are provided, defaults to stdout
+ --line-directives=ARG    How much #line information to emit: statement (default),
+                          toplevel, or none. `statement' is what makes a debugger
+                          land on the right source line; `none' is for reading -C
+                          output by eye
 #+end_src
 ** Compiling Hello World
 #+begin_src shell
@@ -101,6 +142,71 @@ 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
+
+** Aggregate initializers and compound literals
+~#(...)~ is a brace initializer. On its own it has no type and takes one
+from where it is written:
+
+#+begin_src scheme
+(var p (struct point) #(1 2))
+#+end_src
+
+A ~:~ inside one ends a type and makes the whole thing a compound
+literal --- an unnamed object of that type, usable anywhere an
+expression is:
+
+#+begin_src scheme
+(var q (struct point) #(struct point : 3 4))
+(var a (* int) #([int 3] : 10 20 30))
+(draw-line ui #(struct point : 0 0) end)
+(var p (* struct point) (& #(struct point : 9 9)))  ; an lvalue, so `&' works
+#+end_src
+
+The type is written as bare words, the way it is everywhere else in the
+language; ~:~ is what ends it.
+
+A leading ~.~ names a field, so initializers may be designated, given in
+any order, and mixed with positional ones:
+
+#+begin_src scheme
+(var r (struct named) #(struct named : .n 7 .first-name "zoe"))
+#+end_src
+
+A compound literal written inside a block lives until the end of that
+block and no longer, so returning its address is a dangling pointer.
+
 ** 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
@@ -145,6 +251,12 @@ return Sex code.
   ...)
 #+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.

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/lambdas.sex

@@ -6,14 +6,14 @@
 (pub fn main () int
   (var a int 10)
   (var b int 20)
-  (var (fn ((int) (int)) int) sum-fn sum)
+  (var sum-fn (fn ((int) (int)) int) sum)
 
-  (var (fn ((int) (int)) int) sum-lambda
+  (var sum-lambda (fn ((int) (int)) int)
 
        (lambda ((a int) (b int)) int ()
          (return (+ a b))))
 
-  (var (fn ((int)) int) sum-lambda-2
+  (var sum-lambda-2 (fn ((int)) int)
 
        (lambda ((a int)) int ()
          (return (+ a 20))))
@@ -28,9 +28,9 @@
                                             (return (+ a b 100)))
                                           a b))
 
-  (var (fn ((int)) int) l-1
+  (var l-1 (fn ((int)) int)
        (lambda ((a int)) int ()
-         (var (fn ((int)) int) l-2
+         (var l-2 (fn ((int)) int)
               (lambda ((a int)) int ()
                 (return (+ 60 a))))
          (return (+ 600 (l-2 a)))))

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))

fmt-c-writer.scm

@@ -120,10 +120,6 @@ forms, and what remains."
     ((|\||) 'bit-or)
     ((|\|\||) '%or)
     ((|\|=|) 'bit-or=)
-    ;; uh things we do for c89 compatibility
-    ((bool) 'int)
-    ((true) 1)
-    ((false) 0)
     (else
      (if (symbol? atom)
          (unkebabify atom)
@@ -135,9 +131,6 @@ forms, and what remains."
       (car type)
       type))
 
-(define (comment-form? f)
-  (and (pair? f) (eq? (car f) 'comment)))
-
 ;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
 (define (strip-comment-marker text)
   (string-trim-both (string-trim text #\;)))
@@ -175,13 +168,11 @@ forms, and what remains."
 (define (walk-generic-toplevel form)
   (cond ((atom? form) (atom-to-fmt-c form))
         ((list? form) (map walk-generic-toplevel form))
-        (else (error "Malformed form " form))))
+        (else (sex-error form "malformed form" form))))
 
 (define (walk-expr form)
   (match form
-    ((? vector?)
-     (list->vector
-      (walk-expr (vector->list form))))
+    ((? vector?) (walk-initializer (vector->list form)))
     ((? atom?)
      (atom-to-fmt-c form))
     ;; (comment "text") -> /* text */. `%comment' is the fmt-c directive.
@@ -241,6 +232,48 @@ forms, and what remains."
     ;; Drop comments so they will not generate additional comma
     (else (map walk-expr (remove comment-form? form)))))
 
+;;; #(a b c) is a brace initializer. A `:' inside one ends a type and
+;;; turns the whole thing into a C99 compound literal:
+;;; #(struct point : 1 2) is (struct point){1, 2}, and the type is
+;;; written as bare words, the way it is everywhere else in the
+;;; language. `:' is the separator because it is the one thing that can
+;;; be neither a type word nor an expression -- a named form would be a
+;;; C identifier, and so shadowable (see issue #36).
+(define (walk-initializer elements)
+  (let ((parts (list-split (remove comment-form? elements) ':)))
+    (if (null? (cdr parts))
+        (list->vector (walk-designators (car parts)))
+        (cons* '%compound
+               (walk-type (maybe-unwrap-type (car parts)))
+               (walk-designators (cadr parts))))))
+
+;;; `.field value' is a designated initializer; anything else is
+;;; positional. C lets the two be mixed, and nothing here stops it. A
+;;; leading `.' cannot begin a C identifier, so a field name needs no
+;;; keyword to introduce it and cannot collide with one.
+(define (walk-designators elements)
+  (let loop ((es elements) (acc (list)))
+    (match es
+      (() (reverse acc))
+      (((? designator? d))
+       (sex-error elements "designated initializer without a value" d))
+      (((? designator? d) value . rest)
+       (loop rest
+             (cons (list '%designate
+                         (atom-to-fmt-c (designator-field d))
+                         (walk-expr value))
+                   acc)))
+      ((e . rest) (loop rest (cons (walk-expr e) acc))))))
+
+(define (designator? x)
+  (and (symbol? x)
+       (let ((s (symbol->string x)))
+         (and (> (string-length s) 1)
+              (char=? #\. (string-ref s 0))))))
+
+(define (designator-field d)
+  (string->symbol (substring (symbol->string d) 1)))
+
 (define (walk-var form)
   ;; (var a int) -> (%var int a)
   ;; (var a (const int) 32) -> (%var (const int) a 32)
@@ -279,9 +312,9 @@ forms, and what remains."
          ;; it's a strong semantic cue
          `(%array ,(walk-type (maybe-unwrap-type array-type)))))
     (('fn arglist ret-type)
-     `(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
+     `(%fun ,(walk-type ret-type) ,(walk-arg-types arglist)))
     (('fn . _)
-     (assert #f "Malformed function type form"))
+     (sex-error form "malformed function type" form))
 
     ;; Special case: nested structs/unions
     ((or ('struct . _)
@@ -291,11 +324,41 @@ forms, and what remains."
     (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
@@ -319,29 +382,42 @@ forms, and what remains."
     ((¤ * 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 (fn
-        (match x
-          (('¤ . _) (walk-type x))
-
-          ;; yeah shitty, but I don't know yet how to determine if the
-          ;; first entry is part of the type and not an argument name
-          ;; :(
-          ((? is-probably-type) (walk-type x))
-
-          ;; 1 element args are always type
-          ((_) (walk-type x))
-
-          ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
-                                (list (walk-type var))))))
+  (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
+  ;; (fn name arglist ret-type body) -> normal function
+  ;; (fn name arglist ret-type) -> prototype
   (if (>= (length form) 5)
       (walk-fn-def form)
       (cons '%prototype (cdr (walk-fn-def form)))))
@@ -363,14 +439,21 @@ forms, and what remains."
      `(,type ,(atom-to-fmt-c name)
              ,(process-struct-fields fields)
              . ,(tree-map atom-to-fmt-c attrs)))
-    (else (error "Malformed aggregate definition " form))))
+    (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)))))
+     `(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
@@ -379,7 +462,7 @@ forms, and what remains."
      (list 'extern (walk-function form)))
     (('var . _)
      (list 'extern (walk-var form)))
-    (else (error "Extern what?"))))
+    (else (sex-error form "extern must be followed by fn or var" form))))
 
 (define (walk-public form)
   (match form
@@ -395,12 +478,13 @@ forms, and what remains."
 
          ('struct . _)
          ('union . _)
+         ('enum . _)
 
          ('typedef . _))
      ;; ignore here, used in generating public interface
      (process-toplevel-form form))
     (else
-     (error "Pub what?" (cadr form)))))
+     (sex-error form "pub must be followed by a definition" form))))
 
 (define (process-toplevel-form form)
   (match form
@@ -408,7 +492,10 @@ forms, and what remains."
     (('fn . _) (list 'static (walk-function form)))
     (('var . _) (list 'static (walk-var form)))
     (('extern . rest) (walk-extern rest))
-    (('pub . rest) (walk-public 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))

reader.module.scm

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

reader.scm

@@ -7,6 +7,8 @@
 ;;;   - 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.
 
@@ -15,6 +17,8 @@
   (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
@@ -111,6 +115,21 @@
      ((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)
@@ -160,7 +179,8 @@
    ((string->number s) => identity)
    (else (string->symbol s))))
 
-;;; #-dispatch: booleans, characters, vectors, block/datum comments
+;;; #-dispatch: booleans, characters, vectors, block/datum comments,
+;;; feature expressions
 (define (read-hash port)
   (let ((c (get-ch port)))
     (cond
@@ -171,8 +191,57 @@
      ((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)

semen.scm

@@ -9,6 +9,7 @@
   fmt
   sex-macros
   sex-modules
+  types
   matchable                         ; pattern matching
   srfi-1                            ; list routines
   srfi-69                           ; hash tables
@@ -71,8 +72,11 @@
     ((or ('var . _)
          ('pub 'var . _)
          ('extern 'var . _)) (process-global-var sex-form acc))
-    (('include _) (cons sex-form acc))
-    (('define . _) (cons sex-form acc))
+    (('include . includes) (process-includes sex-form includes acc))
+    ((or ('define name . _)
+         ('pub 'define name . _))
+     (add-define name sex-form)
+     (cons sex-form acc))
     (('comment . _) (cons sex-form acc))
 
     (('import . modules)
@@ -83,22 +87,26 @@
 
     ((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 (assert #f (fmt #f "Unknown top level form " sex-form)))))
+    (else (sex-error sex-form "unknown top level form" sex-form))))
+
+(define (process-includes sex-form includes acc)
+  ;; consume (include ...) form and add to acc
+  ;; (include <inc>) for each include
+  (let process ((includes includes)
+                (acc acc))
+    (if (null? includes)
+        acc
+        (process (cdr includes)
+                 (cons (copy-form-source! sex-form `(include ,(car includes)))
+                       acc)))))
 
 (define (process-imports module-public-forms acc)
-  ;; Recursively process imports: register public macros, cons all
-  ;; other public things to our acc
-  (if (null? module-public-forms) acc
-      (match (car module-public-forms)
-        (('defmacro . rest)
-         (defmacro rest)
-         (process-imports (cdr module-public-forms) acc))
-        (else
-         (process-imports (cdr module-public-forms)
-                          (cons (car module-public-forms)
-                                acc))))))
+  ;; 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."
@@ -143,43 +151,91 @@
   (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 (comment-form? f)
-  (and (pair? f) (eq? (car f) 'comment)))
+(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)
-  ;; Remove comment forms from the function header
-  ;; ([pub|extern] fn name arglist rettype) so the positional accessors
-  ;; below are not shifted. Comments in the body are left in place as
-  ;; ordinary statements and preserved into the generated C.
-  (let ((header-count (if (memq (car fn-form) '(pub extern)) 5 4)))
-    ;; This always rebuilds the list, so the location has to be carried
-    ;; over explicitly -- otherwise every function loses it
-    (copy-form-source!
-     fn-form
-     (let loop ((form fn-form) (kept 0) (acc (list)))
-       (cond
-        ((null? form) (reverse acc))
-        ((= kept header-count) (append (reverse acc) form))
-        ((comment-form? (car form)) (loop (cdr form) kept acc))
-        (else (loop (cdr form) (+ kept 1) (cons (car form) acc))))))))
+  ;; ([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* ((sex-fn (strip-fn-header-comments sex-fn-raw))
-         (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))))
-
-    (cons processed
-          (append (hash-table-ref env :lambda-aux-code) 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))
@@ -199,17 +255,31 @@
 
 (define (make-aux-lambda-struct name form)
   (match form
-    (('lambda ret-type arglist captures . body)
+    (('lambda arglist ret-type 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))
+     (process-fn (copy-form-source! form `(fn ,name ,arglist ,ret-type ,@body))
                  (list)))
-    (else (assert #f (fmt #f "Malformed lambda " form)))))
+    (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)
-  (cons 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))
@@ -223,45 +293,36 @@
   "The `form` must be toplevel.
 Returns #f if the form is not a function, returns the form otherwise"
   (match form
-    ((fn . _) form)
-    ((pub fn . _) form)
+    ((or ('fn . _)
+         ('pub 'fn . _)
+         ('extern 'fn . _)) form)
     (else #f)))
 
 (define (sex-fn-public? fn-form)
-  (eq? (car fn-form) 'pub))
-
-(define (sex-fn-return-type fn-form)
-  (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (third fn-form)
-      (second 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"))
-  (if (sex-fn-public? fn-form)
-      (fourth fn-form)
-      (third fn-form)))
+  (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"))
-  (if (sex-fn-public? fn-form)
-      (fifth fn-form)
-      (fourth fn-form)))
+  (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"))
-  (if (sex-fn-public? fn-form)
-      (take fn-form 5)
-      (take fn-form 4)))
+  (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"))
-  (if (sex-fn-public? fn-form)
-      (drop fn-form 5)
-      (drop fn-form 4)))
+  (drop fn-form (fn-header-length fn-form)))

sex-fmt-c.scm

@@ -14,6 +14,7 @@
      c-in-expr c-in-stmt c-in-test
      c-paren c-maybe-paren c-type c-literal? c-literal char->c-char
      c-struct c-union c-class c-enum c-typedef c-cast
+     c-braced-list c-compound c-designate
      c-expr c-expr/sexp c-apply c-op c-indent c-current-indent-string
      c-wrap-stmt c-open-brace c-close-brace
      c-block c-braced-block c-begin
@@ -277,6 +278,8 @@
               ((%comment) ((apply c-comment (cdr x)) st))
               ((:) ((apply c-label (cdr x)) st))
               ((%cast) ((apply c-cast (cdr x)) st))
+              ((%compound) ((apply c-compound (cdr x)) st))
+              ((%designate) ((apply c-designate (cdr x)) st))
               ((+ - & * / % ! ~ ^ && < > <= >= == != << >>
                   = *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
                ((apply c-op x) st))
@@ -306,17 +309,7 @@
                  ((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))
+            ((c-wrap-stmt (c-braced-list (vector->list x))) st))
            (else
             ((c-literal x) st))))))
 
@@ -640,16 +633,22 @@
   (define (c-union . args) (apply c-struct/aux "union" args))
   (define (c-class . args) (apply c-struct/aux "class" args))
 
+  ;; MODIFIED FROM UPSTREAM fmt-c: an enum may also be named without
+  ;; being defined -- `enum color m;' -- exactly as c-struct/aux
+  ;; already allows `struct point p;'. Upstream assumed a value list
+  ;; was always present and mapped over whatever stood in its place.
   (define (c-enum x . o)
     (define (c-enum-one x)
       (if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x)))
     (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
-           (vals (if name (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))))))))
+           (vals (if name (if (null? o) #f (car o)) x)))
+      (if vals
+          (c-wrap-stmt
+           (cat
+            (c-braced-block
+             (if name (cat "enum " name) (dsp "enum"))
+             (c-in-expr (apply c-begin (map c-enum-one vals))))))
+          (c-wrap-stmt (cat "enum " name)))))
 
   (define (c-attribute . args)
     (cat "__attribute__ ((" (fmt-join c-expr args ", ") "))"))
@@ -731,10 +730,13 @@
            (cat (c-type (cadr type) #f)
                 " (*" (or name "") ")("
                 (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
+          ;; MODIFIED FROM UPSTREAM fmt-c: a nameless declarator -- an
+          ;; array parameter of a function type, where C has no room
+          ;; for a name -- arrives as #f, and upstream printed it
           ((%array)
-           (let ((name (cat name "[" (if (pair? (cddr type))
-                                         (c-expr (caddr type))
-                                         "")
+           (let ((name (cat (or name "") "[" (if (pair? (cddr type))
+                                                 (c-expr (caddr type))
+                                                 "")
                             "]")))
              (c-type (cadr type) name)))
           ((%pointer *)
@@ -743,7 +745,13 @@
                      (if (and (pair? (cadr type)) (eq? '%array (caadr type)))
                          (c-paren name)
                          name))))
-          ((enum) (apply c-enum name (cdr type)))
+          ;; MODIFIED FROM UPSTREAM fmt-c: upstream passed the
+          ;; declarator's name to c-enum as the enum's tag, so
+          ;; `(var m (enum color))' emitted `enum m {...}' and lost the
+          ;; variable. Enums are laid out like structs: the type, then
+          ;; the name being declared.
+          ((enum)
+           (cat (apply c-enum (cdr type)) (if name (cat " " name) "")))
           ((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 " "))))
@@ -761,10 +769,13 @@
            (cat (c-type (cadr type) #f)
                 " (*" (or name "") ")("
                 (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
+          ;; MODIFIED FROM UPSTREAM fmt-c: a nameless declarator -- an
+          ;; array parameter of a function type, where C has no room
+          ;; for a name -- arrives as #f, and upstream printed it
           ((%array)
-           (let ((name (cat name "[" (if (pair? (cddr type))
-                                         (c-expr (caddr type))
-                                         "")
+           (let ((name (cat (or name "") "[" (if (pair? (cddr type))
+                                                 (c-expr (caddr type))
+                                                 "")
                             "]")))
              (c-type (cadr type) name)))
           ((%pointer *)
@@ -814,6 +825,25 @@
              (cat "(" (c-with-op 'paren (c-expr expr)) ")")
              (c-expr expr))))
 
+  ;; { a, b, c } -- on one line if it fits, one element per line if not.
+  (define (c-braced-list ls)
+    (fmt-try-fit
+     (fmt-let 'no-wrap? #t (cat "{" (fmt-join c-expr ls ", ") "}"))
+     (lambda (st)
+       (let* ((col (fmt-col st))
+              (sep (string-append "," (make-nl-space col))))
+         ((cat "{" (fmt-join c-expr ls sep) "}" nl) st)))))
+
+  ;; (T){ ... } -- a C99 compound literal, not a cast: the result is an
+  ;; unnamed object and an lvalue, so `&' on it is legal. At block scope
+  ;; it lives until the end of the enclosing block and no longer.
+  (define (c-compound type . init)
+    (cat "(" (c-type type) ")" (c-braced-list init)))
+
+  ;; .field = value, inside a braced list
+  (define (c-designate field value)
+    (cat "." (c-expr field) " = " (c-expr value)))
+
   (define (c-typedef type alias . o)
     (c-wrap-stmt
      (cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " "))))

sex-macros.module.scm

@@ -1,6 +1,7 @@
 (module sex-macros
     (register-macro
      cat
+     comment
      get-macro
      macro?
      apply-macro

sex-macros.scm

@@ -11,11 +11,23 @@
 (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
-                   (only sex-macros cat))
+                   (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)

sex-modules.scm

@@ -8,12 +8,17 @@
   (chicken process-context)
   (chicken string)
   fmt
+  matchable
   reader
   srfi-1
   utils)
 
 (define +persistent-module-paths+ (list))
 
+;;; for guarding against multiple imports (sort of mandatory #pragma
+;;; once)
+(define +imported-modules+ (list))
+
 (define (get-modules-public-forms module-list)
   ;; Module list is a list of symbols
   ;; How Sex handles modules:
@@ -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,19 +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 (copy-form-source! form (take (cdr form) 4)) acc))
-       ((define defmacro import include struct typedef union var)
-        (cons (copy-form-source! form (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

sexc.scm

@@ -2,12 +2,14 @@
         (scheme base)                   ; call/cc
         brev-separate
         (chicken base)
+        (chicken condition)             ; handle-exceptions
         (chicken file)
         (chicken plist)
         (chicken pretty-print)
         (chicken process)
         (chicken process-context)
         (chicken port)
+        (chicken string)                ; string-split
         fmt
         fmt-c-writer
         getopt-long
@@ -30,6 +32,17 @@
                       (required #f)
                       (value #f)
                       (single-char #\c))
+      (features ,(fmt #f "Comma-separated feature names, added to the host's own" nl
+                      (pad padding) "for #+ and #- feature expressions. May be given" nl
+                      (pad padding) "more than once")
+                (required #f)
+                (value #t)
+                (single-char #\f))
+      (no-platform-features
+       ,(fmt #f "Leave out the host's own features. With --features," nl
+             (pad padding) "this reads a file the way another platform would")
+       (required #f)
+       (value #f))
       (emit-c "Emit C code"
               (required #f)
               (value #f)
@@ -97,6 +110,15 @@
           ((equal? v "none") 'none)
           (else (error "--line-directives must be statement, toplevel or none, got" v)))))
 
+
+
+;;; --features may be given more than once, and each may name several.
+;;; Collect all of them
+(define (cli-features args)
+  (append-map (lambda (entry)
+                (map string->symbol (string-split (cdr entry) ",")))
+              (filter (lambda (entry) (eq? (car entry) 'features)) args)))
+
 (define (get-input-file args)
   (let ((rest-args (get-rest-args args)))
     (if (null? rest-args)
@@ -117,26 +139,34 @@
                                  (emit-c sex-forms)))))
 
 (define (compile-to-file sex-forms output args cc-args)
+  "Hand the generated C to the C compiler. Returns the compiler's exit
+status, which is ours to pass on."
   (let ((compiler (or (get-arg args 'c-compiler #f)
                       (get-env-var "SEX_CC")
                       "cc"))
         (out-file (if (eq? output 'default)
                       "a.out"
-                      output)))
-    ;; `process' hands back one record. Its port accessors are named
-    ;; from the *child's* point of view, so `process-input-port' is the
-    ;; port we write to: the C compiler's stdin.
-    (let* ((proc (process compiler (append (list "-o" out-file "-x" "c")
-                                           (if (get-arg args 'compile-object #f)
-                                               (list "-c")
-                                               (list))
-                                           (list "-")  ; read stdin
-                                           cc-args)))
-           (cc-stdin (process-input-port proc)))
-      (with-output-to-port cc-stdin
+                      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)))
-      (close-output-port cc-stdin)
-      (process-wait proc))))
+      (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 (semantic-process-forms raw-forms input-source)
   (if (eq? input-source 'stdin)
@@ -146,6 +176,7 @@
 
 (define prelude
   '((include inttypes.h)
+    (include stdbool.h)
 
     (typedef u8 uint8-t)
     (typedef i8 int8-t)
@@ -172,6 +203,14 @@
        (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")
 
@@ -197,5 +236,7 @@
                  (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!
-             (compile-to-file sex-forms output args cc-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

@@ -3,10 +3,10 @@ CHICKEN_C = csc
 CSC_FLAGS += -K prefix -static
 MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
 
-MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
+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
+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)
@@ -17,6 +17,9 @@ sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
 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
 
@@ -26,8 +29,8 @@ reader.o: reader.module.scm ../reader.scm utils.o
 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 utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,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
@@ -35,11 +38,13 @@ sex-fmt-c.o: ../sex-fmt-c.scm
 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 ../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,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/basic.scm

@@ -31,10 +31,10 @@
   (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))
+  ;; C99 onwards, true C spellings for bool
+  (test 'bool (atom-to-fmt-c 'bool))
+  (test 'true (atom-to-fmt-c 'true))
+  (test 'false (atom-to-fmt-c 'false))
 
   ;; dot-access -> %. member-access directive (kebab-converted operands)
   (test '(%. a b) (walk-expr '(dot-access a b)))

tests/codegen.scm

@@ -6,7 +6,8 @@
 ;;; the existing suite, because both need an operand shape that no
 ;;; earlier test program happened to use.
 
-(import (chicken port)
+(import (chicken condition)
+        (chicken port)
         (chicken string)
         srfi-13
         fmt-c-writer
@@ -28,6 +29,22 @@
 (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 ")"))
 
@@ -124,6 +141,28 @@
     (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,
@@ -153,4 +192,71 @@
     (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"))))
+      (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.scm

@@ -101,6 +101,39 @@
    '(%var (struct suc *) s (hoge piyo))
    (walk-var '(var s (* struct suc) (hoge piyo))))
 
+;;; Initializers and compound literals
+  (test "a bare initializer is unchanged"
+   '#(1 2)
+   (walk-expr '#(1 2)))
+
+  (test "`:' ends the type and makes it a compound literal"
+   '(%compound (struct point) 3 4)
+   (walk-expr '#(struct point : 3 4)))
+
+  (test "the type is bare words, as everywhere else"
+   '(%compound (const char *) 65)
+   (walk-expr '#(* const char : 65)))
+
+  (test "and may be an array type"
+   '(%compound (%array int 3) 10 20 30)
+   (walk-expr '#(¤ int 3 : 10 20 30)))
+
+  (test "a grouped type is unwrapped the way a declaration's is"
+   '(%compound (%array int 3) 10)
+   (walk-expr '#((¤ int 3) : 10)))
+
+  (test "`.field value' is a designated initializer, kebab and all"
+   '(%compound (struct named) (%designate n 7) (%designate first_name "zoe"))
+   (walk-expr '#(struct named : .n 7 .first-name "zoe")))
+
+  (test "positional and designated may be mixed"
+   '(%compound (struct point) 1 (%designate y 5))
+   (walk-expr '#(struct point : 1 .y 5)))
+
+  (test "designators work in an untyped initializer too"
+   '#((%designate y 5))
+   (walk-expr '#(.y 5)))
+
 ;;; Fn defs
   (test
    '(%fun void puk ((int) (%array float 8)))
@@ -150,7 +183,7 @@
   (test
    '(struct mega_kebab ((int a)
                         ((struct ((int year) (int month) (int day))) dob)
-                        ((%fun int ((int) (%array int))) min)))
+                        ((%fun bool ((int) (%array int))) min)))
    (walk-struct '(struct mega-kebab
                          ((a int)
                           (dob (struct ((year int)

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.scm

@@ -1,6 +1,14 @@
 (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)
@@ -38,4 +46,57 @@
   (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

@@ -9,6 +9,7 @@
 (include "line-directives.scm")
 (include "codegen.scm")
 (include "args.scm")
+(include "types.scm")
 
 ;;; Should be the last in the test suite
 (test-exit)

tests/semen.scm

@@ -1,30 +1,35 @@
 (import srfi-69
-        semen)
+        semen
+        types)
 
 (define print-str-fn
-  '(fn void print-str ((string s))
+  '(fn print-str ((s string)) void
        (printf "%s" s)))
 
 (define sum-fn
-  '(pub fn float sum ((int a) (int b))
-        (return (cast float (+ a b)))))
+  '(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 '((string s)) (sex-fn-arglist print-str-fn))
-  (test '(fn void print-str ((string s))) (sex-fn-prototype 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 '((int a) (int b)) (sex-fn-arglist sum-fn))
-  (test '(pub fn float sum ((int a) (int b))) (sex-fn-prototype sum-fn))
-  (test '((return (cast float (+ a b)))) (sex-fn-body 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)
@@ -49,9 +54,78 @@
          '((defmacro (x10 a)
              `(* 10 ,a))
 
-           (fn void foo ((int a) (int b))
+           (fn foo ((a int) (b int)) void
                (return (+ a (x10 b)))))))
 
-    (test '((fn void foo ((int a) (int b))
+    (test '((fn foo ((a int) (b int)) void
                 (return (+ a (* 10 b)))))
-          (semen-process sex-code-macro))))
+          (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))))))
+
+  ;; Includes
+  (test '((include stdio.h))
+        (semen-process
+         '((include stdio.h))))
+  (test '((include stdio.h)
+          (include stdlib.h))
+        (semen-process
+         '((include stdio.h
+                    stdlib.h))))
+  (test '()
+        (semen-process
+         '((include))))
+)

tests/sex-programs/compound-literals.sex

@@ -0,0 +1,49 @@
+(input)
+(output "plain 1 2"
+        "literal 3 4"
+        "designated zoe 7"
+        "through a pointer 9"
+        "array 10 20 30"
+        "argument 6"
+        "mixed 1 5")
+(return 0)
+
+;;; `:' inside #(...) ends a type and makes the rest a C99 compound
+;;; literal. Without one, #(...) is the brace initializer it always was.
+
+(include stdio.h)
+
+(struct point ((x int) (y int)))
+(struct named ((first-name (* const char)) (n int)))
+
+(fn sum ((p (struct point))) int
+  (return (+ (. p x) (. p y))))
+
+(pub fn main () int
+  ;; unchanged: a bare initializer has no type of its own
+  (var p (struct point) #(1 2))
+  (printf "plain %d %d\n" (. p x) (. p y))
+
+  (var q (struct point) #(struct point : 3 4))
+  (printf "literal %d %d\n" (. q x) (. q y))
+
+  ;; designated, out of declaration order, and kebab-cased
+  (var r (struct named) #(struct named : .n 7 .first-name "zoe"))
+  (printf "designated %s %d\n" (. r first-name) (. r n))
+
+  ;; a compound literal is an lvalue, so its address can be taken --
+  ;; until the end of the enclosing block, and no longer
+  (var pp (* struct point) (& #(struct point : 9 9)))
+  (printf "through a pointer %d\n" (-> pp x))
+
+  ;; an array literal decays the way an array does
+  (var a (* int) #([int 3] : 10 20 30))
+  (printf "array %d %d %d\n" (¤ a 0) (¤ a 1) (¤ a 2))
+
+  (printf "argument %d\n" (sum #(struct point : 2 4)))
+
+  ;; positional and designated may be mixed, as in C
+  (var m (struct point) #(struct point : 1 .y 5))
+  (printf "mixed %d %d\n" (. m x) (. m y))
+
+  (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/lambdas.sex

@@ -0,0 +1,44 @@
+(input)
+(output "Named fn through a pointer: 30"
+        "Lambda through a pointer: 30"
+        "Lambda called in place: 130"
+        "Nested lambdas: 666")
+(return 0)
+
+;;; Lambdas are lifted into toplevel functions by semen, so what this
+;;; really checks is that the lifted `fn' comes out in the argument
+;;; order the writer expects -- (fn name arglist ret-type . body).
+
+(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 sum-fn (fn ((int) (int)) int) sum)
+  (printf "Named fn through a pointer: %d\n" (sum-fn a b))
+
+  (var sum-lambda (fn ((int) (int)) int)
+       (lambda ((a int) (b int)) int ()
+         (return (+ a b))))
+  (printf "Lambda through a pointer: %d\n" (sum-lambda a b))
+
+  (printf "Lambda called in place: %d\n"
+          ((lambda ((a int) (b int)) int ()
+             (return (+ a b 100)))
+           a b))
+
+  ;; A lambda inside a lambda: the inner one is lifted out of a
+  ;; function that is itself being lifted
+  (var outer (fn ((int)) int)
+       (lambda ((x int)) int ()
+         (var inner (fn ((int)) int)
+              (lambda ((y int)) int ()
+                (return (+ 60 y))))
+         (return (+ 600 (inner x)))))
+  (printf "Nested lambdas: %d\n" (outer 6))
+
+  (return 0))

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/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

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

tools/sextest/reader.module.scm

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

tools/sextest/sextest.scm

@@ -1,4 +1,5 @@
 (import scheme
+        (scheme base)                   ; let-values
         brev-separate
         (chicken base)
         (chicken file)
@@ -7,36 +8,81 @@
         (chicken port)
         (chicken process)
         (chicken process-context)
+        (chicken string)                ; string-split
         fmt
         getopt-long
         reader                          ; read-raw-forms, shared with sexc
-        srfi-1)
+        srfi-1
+        srfi-13)                        ; string-prefix?
 
 (define (print-help)
   (fmt #t "Usage: sextest [options] filename" nl
        "Options:" nl
        (usage opts-grammar) nl))
 
-(define (process-file target-path)
-  (let ((contents (read-raw-forms target-path)))
-    (foldl (lambda (acc elt)
-             (case (car elt)
-               ((compilation input output return)
-                (cons
-                 (append (car acc) (list elt))
-                 (cdr acc)))
-               (else
-                (cons
-                 (car acc)
-                 (append (cdr acc) (list elt))))))
-           (cons (list) (list))
-           contents)))
+(define (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))
 
-(define (compile src flags sexc)
+;;; 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.
@@ -110,7 +156,7 @@
   (let* ((settings-and-src (process-file path))
          (settings (car settings-and-src))
          (src (cdr settings-and-src))
-         (compiled-file (compile src (assoc 'compile settings) sexc)))
+         (compiled-file (compile src (assoc 'compilation settings) sexc)))
     (if (not compiled-file)
         (begin (fmt #t "Failed to compile " path nl)
                #f)

tools/sextest/utils.module.scm

@@ -2,6 +2,8 @@
     (get-env-var
      set-working-directory
      to-absolute-pathname
+     comment-form?
+     strip-header-comments
      list-split
      list-join
      recons
@@ -12,6 +14,8 @@
      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.module.scm

@@ -2,6 +2,8 @@
     (get-env-var
      set-working-directory
      to-absolute-pathname
+     comment-form?
+     strip-header-comments
      list-split
      list-join
      recons
@@ -12,6 +14,8 @@
      form-line
      copy-form-source!
      stamp-form-source!
+     form-location
+     sex-error
      with-directory
      )
   "utils.scm")

utils.scm

@@ -42,6 +42,24 @@
        (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)
@@ -105,6 +123,21 @@ wrap a form-building expression."
       (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