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

@@ -61,14 +61,18 @@ sextest:
 	$(MAKE) -C ./tools/sextest sextest
 	cp ./tools/sextest/sextest .
 
-SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize
+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) && $(MAKE) check-modules
+	./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
@@ -77,4 +81,4 @@ clean:
 	rm -f sexc sex-tests sextest
 	$(MAKE) -C ./tests/modules clean
 
-.PHONY: clean run-tests sex-tests sextest check-modules
+.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

example/sdl3-triangle.sex

@@ -8,13 +8,29 @@
 ;;; 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:
+;;; 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.
 
-(define GL-SILENCE-DEPRECATION 1)       ; OpenGL is deprecated on macOS
+#+macosx (define GL-SILENCE-DEPRECATION 1) ; OpenGL is deprecated on macOS
 
 (include SDL3/SDL.h)
-(include OpenGL/gl3.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)

fmt-c-writer.scm

@@ -382,10 +382,17 @@ forms, and what remains."
 
 (define (walk-enum form)
   (match form
+    ;; Naming one without defining it: `(var m (enum mood))', the same
+    ;; shape walk-struct accepts for `(struct foo)'. Guarded, and
+    ;; before the anonymous case, since `(enum (red green))' is also a
+    ;; two-element form
+    (('enum (? symbol? name))
+     `(enum ,(atom-to-fmt-c name)))
     (('enum (values ...))
      `(enum ,(map atom-to-fmt-c values)))
     (('enum name (values ...))
-     `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
+     `(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
@@ -410,6 +417,7 @@ forms, and what remains."
 
          ('struct . _)
          ('union . _)
+         ('enum . _)
 
          ('typedef . _))
      ;; ignore here, used in generating public interface
@@ -423,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

@@ -93,17 +93,9 @@
     (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."

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)))
+           (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-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-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)
@@ -75,7 +83,7 @@
        ;; A variable becomes an `extern' declaration
        ((var)
         (cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc))
-       ((define defmacro import include struct typedef union)
+       ((define defmacro enum import include struct typedef union)
         (cons (copy-form-source! form (cdr form)) acc))
        (else (sex-error form "pub must be followed by a definition" form))))
     (else acc)))

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,15 +139,22 @@
                                  (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)))
+                      output))
         ;; The generated C goes to a temporary .c file rather than the
-    ;; compiler's stdin
-    (let ((c-file (create-temporary-file "c")))
+        ;; compiler's stdin. It is removed however we leave -- emit-c
+        ;; can throw, and used to leave the file behind when it did
+        (c-file (create-temporary-file "c")))
+    ;; An unhandled error ends the process without unwinding, so the
+    ;; cleanup cannot be left to dynamic-wind
+    (handle-exceptions exn
+        (begin (delete-file* c-file) (abort exn))
       (with-output-to-file c-file
         (lambda () (emit-c sex-forms)))
       (let ((proc (process compiler (append (list "-o" out-file)
@@ -135,9 +164,9 @@
                                             (list c-file)
                                             cc-args))))
         (call-with-values (lambda () (process-wait proc))
-          (lambda status
+          (lambda (pid normal-exit? status)
             (delete-file* c-file)
-            (apply values status)))))))
+            (if normal-exit? status 1)))))))
 
 (define (semantic-process-forms raw-forms input-source)
   (if (eq? input-source 'stdin)
@@ -173,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")
 
@@ -198,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/codegen.scm

@@ -141,6 +141,28 @@ compiles."
     (test-assert "a comment in a body stays in the body"
       (emits? (in-fn "(while (< a b) ;; inside\n (g 1))")
               "while (a < b) {")))
+
+  (test-group "pub enum"
+    (test-assert "is emitted"
+      (emits? "(pub enum color (red green blue))" "enum color"))
+    (test-assert "with its values"
+      (emits? "(pub enum color (red green blue))" "red"))
+    (test-assert "and a non-pub enum still is too"
+      (emits? "(enum color (red green blue))" "enum color"))
+    ;; Naming an enum as a type, rather than defining it, had no
+    ;; walk-enum clause and died with `(match) no matching pattern'
+    (test-assert "and it can then be used as a type"
+      (emits? "(enum color (red green blue)) (fn f () void (var m (enum color) red))"
+              "enum color m = red"))
+    (test-assert "a malformed enum is rejected with its location"
+      (reports? "(enum)" "codegen.sex:1:"))
+    ;; c-type handed the declarator's name to c-enum as the enum tag,
+    ;; so this emitted `enum m { up, down }' with no variable at all
+    (test-assert "an anonymous enum keeps the variable"
+      (emits? "(fn f () void (var e (enum (up down)) up))" "} e = up"))
+    (test-assert "and a named definition keeps both"
+      (emits? "(fn f () void (var n (enum named (a b)) a))" "enum named{")))
+
   ;; `|', `||' and `|=' read as ordinary symbols -- our own reader has
   ;; no |symbol| syntax for them to collide with -- but fmt-c cannot
   ;; dispatch on a symbol whose name it cannot write in Scheme source,

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

@@ -7,10 +7,14 @@
 # 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
+EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1
 
 check:
 	@$(SEXC) greet.sex -c -o greet.o

tests/modules/greet-app.sex

@@ -7,6 +7,9 @@
 ;;; 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)
 
@@ -16,4 +19,11 @@
   (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

@@ -9,6 +9,20 @@
 
 (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))

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/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/types.module.scm

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

@@ -54,6 +54,42 @@
         #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"

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,18 +7,19 @@
         (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)))
+(define (split-settings contents)
   (foldl (lambda (acc elt)
            (case (car elt)
              ((compilation input output return)
@@ -30,13 +31,39 @@
                (car acc)
                (append (cdr acc) (list elt))))))
          (cons (list) (list))
-           contents)))
+         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)

types.scm

@@ -76,21 +76,44 @@
 ;;; ((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 (get-type-info name)))
+  (let ((info (resolve-type-info name)))
     (and info
          (memq (car info) '(struct union))
          (caddr info))))
 
-;;; Follow a typedef chain to the name it ultimately stands for. #f if
-;;; NAME is not a typedef.
+;;; 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) (get-underlying-type target))
-               target)))))
+                  (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
@@ -119,15 +142,16 @@
 ;;;
 ;;; Returns #f if nothing of that name was declared
 (define (map-fields struct-union-enum fn)
-  (let ((info (get-type-info struct-union-enum)))
+  (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.
+           ;; 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 struct-union-enum)))
+            (let ((type (list 'enum (cadr info))))
               (map (lambda (value) (fn value type))
                    (caddr info))))
            (else #f)))))