build the triangle on Linux too

<OpenGL/gl3.h> does not exist there and -framework is not a gcc flag,
so the documented build line failed with no hint why. #+macosx picks
the header now, and both build lines are in the file -- pkg-config
carries the flags on either platform, apart from Apple's GL framework,
which has no pkg-config file to carry.

.gitignore

@@ -3,3 +3,5 @@
 *.link
 sexc
 sex-tests
+sextest
+tools/sextest/sextest

Makefile

@@ -15,7 +15,7 @@ CSC_FLAGS += -K prefix -static
 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)
 
 sexc: $(OBJ) main.scm
@@ -28,6 +28,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 +40,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 +49,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 +61,24 @@ 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
+
+# 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
 
 run-tests: sexc sex-tests sextest
-	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex)
+	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules && $(MAKE) check-exit-code
 
 clean:
 	rm -f $(OBJ) main.o
 	rm -f *.import.scm
 	rm -f *.link
 	rm -f sexc sex-tests sextest
+	$(MAKE) -C ./tests/modules clean
 
-.PHONY: clean run-tests sex-tests sextest
+.PHONY: clean run-tests sex-tests sextest check-modules check-exit-code

Readme.org

@@ -31,13 +31,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 +109,39 @@ Module's public interface consists of everything declared
 ~pub~. Structures, function, macros, types, variables can be
 public.
 
+** Read-time feature expressions
+Sex is able to use ~#+~ and ~#-~ for conditional compilation: the form that
+follows is kept only when the feature expression is true, and otherwise
+is read and thrown away.
+
+#+begin_src scheme
+#+macosx (include OpenGL/gl3.h)
+#-macosx (include GL/gl.h)
+
+#+(and unix (not macosx)) (define HAVE-EPOLL 1)
+#+end_src
+
+An expression is a feature name, or ~and~, ~or~ and ~not~ of them.
+
+This is read time, not compile time. What does not apply never reaches macro
+expansion, the type database or the generated C.
+
+The features are the host's ~(software-version)~, ~(software-type)~
+and ~(machine-type)~, e.g. ~macosx unix arm64~ or ~linux unix
+x86-64~. ~--features~ adds to them:
+
+#+begin_src shell
+sexc prog.sex -f debug,with-sdl
+sexc prog.sex --features=debug --features=with-sdl
+#+end_src
+
+A feature is never taken away. The host's features can be disabled,
+e.g. for checking output for other platform:
+
+#+begin_src shell
+sexc example/sdl3-triangle.sex -C --no-platform-features --features=linux,unix,x86-64
+#+end_src
+
 ** Syntactic macros
 Sex has support for syntactic macros. Macro definitions look like
 functions: they have a name, an argument list and a body. Macro should
@@ -145,6 +186,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.

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

@@ -175,7 +175,7 @@ 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
@@ -281,7 +281,7 @@ forms, and what remains."
     (('fn arglist ret-type)
      `(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
     (('fn . _)
-     (assert #f "Malformed function type form"))
+     (sex-error form "malformed function type" form))
 
     ;; Special case: nested structs/unions
     ((or ('struct . _)
@@ -291,11 +291,26 @@ forms, and what remains."
     (else
      (type-convert-to-c form))))
 
+(define (has-pointer-star? form)
+  (and (pair? 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 (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))
   (if (atom? type) (atom-to-fmt-c type)
       (flatten
        (tree-map atom-to-fmt-c
@@ -363,14 +378,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 +401,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 +417,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 +431,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
@@ -160,7 +164,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 +176,46 @@
      ((char=? c #\() (list->vector (read-list port close-paren)))
      ((char=? c #\|) (skip-block-comment port 1) (next-token port))
      ((char=? c #\;) (read-datum port) (next-token port)) ; datum comment
+     ((char=? c #\+) (read-conditional port #t))
+     ((char=? c #\-) (read-conditional port #f))
      (else (error "Unsupported # syntax" c)))))
 
+;;; Feature expressions
+;;;
+;;;   #+linux   (include GL/gl.h)      kept on Linux
+;;;   #-macosx  (foo)                  kept only on other than macOS
+;;;   #+(and unix (not macosx)) (bar)  and / or / not combine them
+;;;
+(define (platform-features)
+  (list (software-version) (software-type) (machine-type)))
+
+;;; The host's features are the default, so anything reading Sex sees
+;;; what the compiler would. sexc rebinds this to add --features
+(define current-features (make-parameter (platform-features)))
+
+(define (feature-true? test)
+  (cond
+   ((symbol? test) (and (memq test (current-features)) #t))
+   ((pair? test)
+    (case (car test)
+      ((and) (every feature-true? (cdr test)))
+      ((or) (any feature-true? (cdr test)))
+      ((not)
+       (if (and (pair? (cdr test)) (null? (cddr test)))
+           (not (feature-true? (cadr test)))
+           (error "Feature expression `not' takes exactly one operand" test)))
+      (else (error "Unknown operator in feature expression" (car test)))))
+   (else (error "Malformed feature expression" test))))
+
+;;; The #-/#+ preceded datum is always read -- there is no other way
+;;; to know where it ends -- and then either returned or dropped
+(define (read-conditional port keep-when)
+  (let ((keep (eq? keep-when (feature-true? (read-datum port)))))
+    (if keep
+        (read-datum port)
+        (begin (read-datum port)
+               (next-token port)))))
+
 ;;; #t / #true / #f / #false. `val' is the boolean; consume any
 ;;; trailing name characters and validate
 (define (read-bool port val)

semen.scm

@@ -9,6 +9,7 @@
   fmt
   sex-macros
   sex-modules
+  types
   matchable                         ; pattern matching
   srfi-1                            ; list routines
   srfi-69                           ; hash tables
@@ -72,7 +73,10 @@
          ('pub 'var . _)
          ('extern 'var . _)) (process-global-var sex-form acc))
     (('include _) (cons sex-form acc))
-    (('define . _) (cons sex-form acc))
+    ((or ('define name . _)
+         ('pub 'define name . _))
+     (add-define name sex-form)
+     (cons sex-form acc))
     (('comment . _) (cons sex-form acc))
 
     (('import . modules)
@@ -83,22 +87,15 @@
 
     ((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-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."
@@ -204,13 +201,26 @@
      ;; we'll need them for TODO: closures support
      (process-fn (copy-form-source! form `(fn ,ret-type ,name ,arglist ,@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)
+  (register-aggregate! sex-struct)
   (cons sex-struct 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))
 

sex-fmt-c.scm

@@ -640,16 +640,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 ", ") "))"))
@@ -743,7 +749,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 " "))))

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-fields get-underlying-type
+                         type-match map-fields))
            ,@body)))
 
 (define (get-macro name)

sex-modules.scm

@@ -14,6 +14,10 @@
 
 (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 +33,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)
@@ -68,13 +76,16 @@
   (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)
+       ;; A function is reduced to a prototype and keeps its `pub', so
+       ;; the importing unit declares it with external linkage
+       ((fn)
+        (cons (copy-form-source! form (take form 5)) acc))
+       ;; A variable becomes an `extern' declaration
+       ((var)
+        (cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc))
+       ((define defmacro enum import include struct typedef union)
         (cons (copy-form-source! form (cdr form)) acc))
-       (else (error "Pub what? " (cadr form)))))
+       (else (sex-error form "pub must be followed by a definition" form))))
     (else acc)))
 
 (define (load-persistent-module-paths)

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)
@@ -172,6 +202,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 +235,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,8 +38,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
 
 clean:
 	rm -f $(SEX_OBJ)

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,42 @@
     (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"))))

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

@@ -0,0 +1,32 @@
+# 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.
+
+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,32 @@
+;;; 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 int 0)
+
+(pub struct greeting ((text (* const char)) (times int)))
+
+(pub enum mood (cheerful grumpy))
+
+(pub typedef greeting-t (struct greeting))
+
+;;; Compile-time reflection across the module boundary: both the macro
+;;; and the struct it asks about are exported, and the importing unit
+;;; has to know the struct's fields to expand this.
+(pub defmacro (describe-fields type)
+  `(do ,@(map-fields type
+           (lambda (name field-type)
+             `(printf "%s " ,(symbol->string name))))))
+
+(pub fn greet ((name (* const char))) void
+  (++ greet-count)
+  (printf "hello, %s\n" name))
+
+;;; 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,41 @@
   (reader-test '((a b) (comment " t")) "(a b) ; t")
   ;; a `;' inside a string is not a comment
   (reader-test '("a;b") "\"a;b\"")
+
+  ;; #+ / #- feature expressions. What does not apply is read and
+  ;; dropped, so it never reaches the compiler at all
+  (feature-test '((a)) (linux) "#+linux (a)")
+  (feature-test '()    (macosx) "#+linux (a)")
+  (feature-test '()    (linux) "#-linux (a)")
+  (feature-test '((a)) (macosx) "#-linux (a)")
+  ;; the guarded datum can be anything, not only a list
+  (feature-test '(42) (x) "#+x 42")
+  (feature-test '("s") (x) "#+x \"s\"")
+
+  ;; and / or / not
+  (feature-test '((a)) (unix linux) "#+(and unix linux) (a)")
+  (feature-test '()    (unix) "#+(and unix linux) (a)")
+  (feature-test '((a)) (unix) "#+(or linux unix) (a)")
+  (feature-test '()    (bsd)  "#+(or linux unix) (a)")
+  (feature-test '((a)) (unix) "#+(and unix (not macosx)) (a)")
+  (feature-test '()    (unix macosx) "#+(and unix (not macosx)) (a)")
+  ;; (and) is true and (or) is false, as they are in CL
+  (feature-test '((a)) () "#+(and) (a)")
+  (feature-test '()    () "#+(or) (a)")
+
+  ;; a guard inside a form, including as the last element -- dropping
+  ;; continues with the next token, so the closing paren still arrives
+  (feature-test '((f 1 3)) (a) "(f #+a 1 #-a 2 3)")
+  (feature-test '((f 2 3)) (b) "(f #+a 1 #-a 2 3)")
+  (feature-test '((f 1))   (a) "(f #+a 1 #+b 2)")
+  (feature-test '((f))     (b) "(f #+a 1)")
+  ;; ...and as the last form in the file
+  (feature-test '((a)) (x) "(a) #+y (b)")
+
+  ;; guards nest
+  (feature-test '((a)) (x y) "#+x #+y (a)")
+  (feature-test '((b)) (x) "#+x #+y (a) (b)")
+
+  ;; a feature the program was not given is simply absent
+  (feature-test '() () "#+anything (a)")
 )

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/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/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,14 @@
+(module types
+    (add-struct
+     add-union
+     add-enum
+     add-typedef
+     add-define
+
+     type-match
+     map-fields
+
+     get-type-info
+     get-fields
+     get-underlying-type)
+  "../types.scm")

tests/types.scm

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

@@ -7,36 +7,63 @@
         (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)
+;;; --features from the (compilation ...) form, which we have to honour
+;;; ourselves: the program is read here and printed back out for sexc,
+;;; so #+ and #- are resolved on this side
+(define (compilation-features settings)
+  (let ((compilation (assoc 'compilation settings)))
+    (if compilation
+        (append-map (lambda (flag)
+                      (if (string-prefix? "--features=" flag)
+                          (map string->symbol
+                               (string-split (substring flag 11) ","))
+                          (list)))
+                    (string-split (cadr compilation)))
+        (list))))
+
+(define (process-file target-path)
+  (let* ((first-pass (split-settings (read-raw-forms target-path)))
+         (features (compilation-features (car first-pass))))
+    (if (null? features)
+        first-pass
+        (parameterize ((current-features (append (platform-features) features)))
+          (split-settings (read-raw-forms target-path))))))
+
+(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 +137,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

@@ -12,6 +12,8 @@
      form-line
      copy-form-source!
      stamp-form-source!
+     form-location
+     sex-error
      with-directory
      )
   "../../utils.scm")

types.module.scm

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

types.scm

@@ -0,0 +1,157 @@
+;;; 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)
+
+(define +type-db+ (make-hash-table))
+
+(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! +type-db+ name
+                   (list 'struct name (normalize-fields (aggregate-fields form)))))
+
+(define (add-union name form)
+  (hash-table-set! +type-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! +type-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-type-info name)
+  (hash-table-ref/default +type-db+ name #f))
+
+;;; ((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 (resolve-type-info name)
+  (let ((info (get-type-info name)))
+    (and info
+         (if (eq? (car info) 'typedef)
+             (let* ((target (get-underlying-type name))
+                    (tag (cond ((symbol? target) target)
+                               ((and (pair? target)
+                                     (pair? (cdr target))
+                                     (symbol? (cadr target)))
+                                (cadr target))
+                               (else #f))))
+               (and tag (get-type-info tag)))
+             info))))
+
+;;; 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

@@ -12,6 +12,8 @@
      form-line
      copy-form-source!
      stamp-form-source!
+     form-location
+     sex-error
      with-directory
      )
   "utils.scm")

utils.scm

@@ -105,6 +105,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