implement compound and designated literals support

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

.gitea/workflows/build.yaml

@@ -57,20 +57,11 @@ jobs:
           hash -r
           csc -version
 
-      - name: Install eggs
-        run: |
-          set -eu
-          mkdir -p .eggs
-          repo="$(chicken-install -repository)"
-          echo "CHICKEN_INSTALL_REPOSITORY=${PWD}/.eggs" >> "$GITHUB_ENV"
-          echo "CHICKEN_REPOSITORY_PATH=${PWD}/.eggs:${repo}" >> "$GITHUB_ENV"
-          export CHICKEN_INSTALL_REPOSITORY="${PWD}/.eggs"
-          export CHICKEN_REPOSITORY_PATH="${PWD}/.eggs:${repo}"
-          # shellcheck disable=SC2046
-          chicken-install $(cat dependencies.txt)
+      - name: Install dependencies
+        run: make deps
 
       - name: Build sexc
-        run: make sexc && ./sexc --help
+        run: make && ./sexc --help
 
       - name: Run tests
-        run: make run-tests
+        run: make check

Makefile

@@ -34,24 +34,27 @@ DEPSLOCK = eggs.lock
 EGGS_DIR := $(abspath .eggs)
 
 # Compiler's own repository (types.db, chicken.*), ignoring ambient venv vars.
-SYSTEM_CHICKEN_REPO := $(shell env -u CHICKEN_INSTALL_REPOSITORY -u CHICKEN_REPOSITORY_PATH -u CHICKEN_EGG_CACHE -u CHICKEN_INSTALL_PREFIX $(CHICKEN_INSTALL) -repository 2>/dev/null)
+SYSTEM_CHICKEN_REPO := $(shell env \
+	-u CHICKEN_INSTALL_REPOSITORY -u CHICKEN_REPOSITORY_PATH \
+	-u CHICKEN_EGG_CACHE -u CHICKEN_INSTALL_PREFIX \
+	$(CHICKEN_INSTALL) -repository 2>/dev/null)
 CHICKEN_ABI := $(notdir $(SYSTEM_CHICKEN_REPO))
 EGGS_STAMP := $(EGGS_DIR)/.installed-$(CHICKEN_ABI)
 
-export CHICKEN_EGG_CACHE := $(EGGS_DIR)/cache
-export CHICKEN_INSTALL_REPOSITORY := $(EGGS_DIR)
-export CHICKEN_INSTALL_PREFIX := $(EGGS_DIR)
+# Try project-local chicken repository first. In case it doesn't exist (packaging for distros),
+# system-wide repository will be used.
+unexport CHICKEN_INSTALL_REPOSITORY
+unexport CHICKEN_EGG_CACHE
+unexport CHICKEN_INSTALL_PREFIX
 export CHICKEN_REPOSITORY_PATH := $(EGGS_DIR):$(SYSTEM_CHICKEN_REPO)
 
 all: sexc
 
-sexc: $(EGGS_STAMP) $(OBJ) main.scm
+sexc: $(OBJ) main.scm
 	$(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc
         # otherwise csc hangs, probably because it tries to compile to sexc.o first
 	mv sexc-tmp sexc
 
-$(OBJ): $(EGGS_STAMP)
-
 #------------------------------------------------------------------
 
 utils.o: utils.module.scm utils.scm
@@ -82,15 +85,16 @@ sexc.o: sexc.module.scm types.o sexc.scm fmt-c-writer.o sex-macros.o sex-modules
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,types,utils
 
 # Unit testing
-sex-tests: $(EGGS_STAMP)
+sex-tests:
 	$(MAKE) -C ./tests sex-tests
 	cp ./tests/sex-tests ./
 
-sextest: $(EGGS_STAMP)
+sextest:
 	$(MAKE) -C ./tools/sextest sextest
 	cp ./tools/sextest/sextest .
 
-SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features
+SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \
+                    feature-flags lambdas compound-literals
 
 # Multi-module linking is checked end to end; see tests/modules/Makefile.
 check-modules: sexc
@@ -100,7 +104,7 @@ check-modules: sexc
 check-exit-code: sexc
 	@$(MAKE) --no-print-directory -C ./tests/exit-code check SEXC=../../sexc
 
-run-tests: sexc sex-tests sextest
+check run-tests: sexc sex-tests sextest
 	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules && $(MAKE) check-exit-code
 
 install: all installdirs
@@ -115,9 +119,11 @@ installdirs:
 uninstall:
 	rm -f $(DESTDIR)$(bindir)/sexc
 
-# eggs.lock is the pin file (chicken-status -list). Install from it;
-# do not float versions on a normal build. Regenerating the lock:
-#   make deps-update
+$(EGGS_STAMP) deps-update: export CHICKEN_EGG_CACHE := $(EGGS_DIR)/cache
+$(EGGS_STAMP) deps-update: export CHICKEN_INSTALL_REPOSITORY := $(EGGS_DIR)
+$(EGGS_STAMP) deps-update: export CHICKEN_INSTALL_PREFIX := $(EGGS_DIR)
+$(EGGS_STAMP) deps-update: export CHICKEN_REPOSITORY_PATH := $(EGGS_DIR):$(SYSTEM_CHICKEN_REPO)
+
 $(EGGS_STAMP): $(DEPSLOCK)
 	mkdir -p $(CHICKEN_EGG_CACHE)
 	$(CHICKEN_INSTALL) -force -from-list $(DEPSLOCK)
@@ -125,10 +131,10 @@ $(EGGS_STAMP): $(DEPSLOCK)
 
 deps: $(EGGS_STAMP)
 
-deps-update: $(DEPSFILE)
-	rm -rf $(EGGS_DIR)
+deps-update: $(DEPSFILE) deps-clean
 	mkdir -p $(CHICKEN_EGG_CACHE)
 	$(CHICKEN_INSTALL) -force $$(cat $(DEPSFILE))
+	# Local repo only: a system path here would leak distro eggs into the lock.
 	CHICKEN_REPOSITORY_PATH=$(EGGS_DIR) $(CHICKEN_STATUS) -list | sort > $(DEPSLOCK).tmp
 	mv $(DEPSLOCK).tmp $(DEPSLOCK)
 	touch $(EGGS_STAMP)
@@ -145,5 +151,6 @@ clean:
 deps-clean:
 	rm -rf $(EGGS_DIR)
 
-.PHONY: all check run-tests check-modules check-exit-code install install-strip installdirs
-	uninstall deps deps-update clean depsclean sex-tests sextest
+.PHONY: all check run-tests check-modules check-exit-code \
+        install install-strip installdirs uninstall \
+        deps deps-update deps-clean clean sex-tests sextest

Readme.org

@@ -12,22 +12,25 @@ Sex is statically typed, compiled general purpose language.
 First, get yourself a Chicken, then, some Chicken deps. You also will
 need a C compiler.
 
-Eggs are installed into a project-local ~.eggs/~ repository; they do not
-touch the Chicken system repository.
-
-** Compilation
+** Development
 #+begin_src sh
+  make deps
   make
 #+end_src
 
-That installs pinned eggs from ~eggs.lock~ into ~.eggs/~ if needed, then
-builds ~sexc~. ~dependencies.txt~ is the unpinned request list. To
-refresh ~eggs.lock~ after changing it:
+~make deps~ installs pinned eggs from ~eggs.lock~ into a project-local
+~.eggs/~ repository. ~dependencies.txt~ is the unpinned request list.
+To refresh ~eggs.lock~ after changing it:
 
 #+begin_src sh
   make deps-update
 #+end_src
 
+** Packaging for system package managers
+- Depend ~sex~ package on Chicken-6 (with ~libchicken.a~) and all eggs from ~dependencies.txt~.
+- Compile and install with ~make~ (usually no other arguments required).
+- Move resulting ~sexc~ binary to the appropriate place.
+
 ** Static compilation
 The default ~CSC_FLAGS~ include ~-static~, so ~sexc~ does not need
 ~.eggs~ at runtime and ~make install~ stays relocatable. Chicken must
@@ -172,6 +175,38 @@ e.g. for checking output for other platform:
 sexc example/sdl3-triangle.sex -C --no-platform-features --features=linux,unix,x86-64
 #+end_src
 
+** Aggregate initializers and compound literals
+~#(...)~ is a brace initializer. On its own it has no type and takes one
+from where it is written:
+
+#+begin_src scheme
+(var p (struct point) #(1 2))
+#+end_src
+
+A ~:~ inside one ends a type and makes the whole thing a compound
+literal --- an unnamed object of that type, usable anywhere an
+expression is:
+
+#+begin_src scheme
+(var q (struct point) #(struct point : 3 4))
+(var a (* int) #([int 3] : 10 20 30))
+(draw-line ui #(struct point : 0 0) end)
+(var p (* struct point) (& #(struct point : 9 9)))  ; an lvalue, so `&' works
+#+end_src
+
+The type is written as bare words, the way it is everywhere else in the
+language; ~:~ is what ends it.
+
+A leading ~.~ names a field, so initializers may be designated, given in
+any order, and mixed with positional ones:
+
+#+begin_src scheme
+(var r (struct named) #(struct named : .n 7 .first-name "zoe"))
+#+end_src
+
+A compound literal written inside a block lives until the end of that
+block and no longer, so returning its address is a dangling pointer.
+
 ** Syntactic macros
 Sex has support for syntactic macros. Macro definitions look like
 functions: they have a name, an argument list and a body. Macro should

example/lambdas.sex

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

fmt-c-writer.scm

@@ -120,10 +120,6 @@ forms, and what remains."
     ((|\||) 'bit-or)
     ((|\|\||) '%or)
     ((|\|=|) 'bit-or=)
-    ;; uh things we do for c89 compatibility
-    ((bool) 'int)
-    ((true) 1)
-    ((false) 0)
     (else
      (if (symbol? atom)
          (unkebabify atom)
@@ -135,9 +131,6 @@ forms, and what remains."
       (car type)
       type))
 
-(define (comment-form? f)
-  (and (pair? f) (eq? (car f) 'comment)))
-
 ;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
 (define (strip-comment-marker text)
   (string-trim-both (string-trim text #\;)))
@@ -179,9 +172,7 @@ forms, and what remains."
 
 (define (walk-expr form)
   (match form
-    ((? vector?)
-     (list->vector
-      (walk-expr (vector->list form))))
+    ((? vector?) (walk-initializer (vector->list form)))
     ((? atom?)
      (atom-to-fmt-c form))
     ;; (comment "text") -> /* text */. `%comment' is the fmt-c directive.
@@ -241,6 +232,48 @@ forms, and what remains."
     ;; Drop comments so they will not generate additional comma
     (else (map walk-expr (remove comment-form? form)))))
 
+;;; #(a b c) is a brace initializer. A `:' inside one ends a type and
+;;; turns the whole thing into a C99 compound literal:
+;;; #(struct point : 1 2) is (struct point){1, 2}, and the type is
+;;; written as bare words, the way it is everywhere else in the
+;;; language. `:' is the separator because it is the one thing that can
+;;; be neither a type word nor an expression -- a named form would be a
+;;; C identifier, and so shadowable (see issue #36).
+(define (walk-initializer elements)
+  (let ((parts (list-split (remove comment-form? elements) ':)))
+    (if (null? (cdr parts))
+        (list->vector (walk-designators (car parts)))
+        (cons* '%compound
+               (walk-type (maybe-unwrap-type (car parts)))
+               (walk-designators (cadr parts))))))
+
+;;; `.field value' is a designated initializer; anything else is
+;;; positional. C lets the two be mixed, and nothing here stops it. A
+;;; leading `.' cannot begin a C identifier, so a field name needs no
+;;; keyword to introduce it and cannot collide with one.
+(define (walk-designators elements)
+  (let loop ((es elements) (acc (list)))
+    (match es
+      (() (reverse acc))
+      (((? designator? d))
+       (sex-error elements "designated initializer without a value" d))
+      (((? designator? d) value . rest)
+       (loop rest
+             (cons (list '%designate
+                         (atom-to-fmt-c (designator-field d))
+                         (walk-expr value))
+                   acc)))
+      ((e . rest) (loop rest (cons (walk-expr e) acc))))))
+
+(define (designator? x)
+  (and (symbol? x)
+       (let ((s (symbol->string x)))
+         (and (> (string-length s) 1)
+              (char=? #\. (string-ref s 0))))))
+
+(define (designator-field d)
+  (string->symbol (substring (symbol->string d) 1)))
+
 (define (walk-var form)
   ;; (var a int) -> (%var int a)
   ;; (var a (const int) 32) -> (%var (const int) a 32)
@@ -279,7 +312,7 @@ forms, and what remains."
          ;; it's a strong semantic cue
          `(%array ,(walk-type (maybe-unwrap-type array-type)))))
     (('fn arglist ret-type)
-     `(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
+     `(%fun ,(walk-type ret-type) ,(walk-arg-types arglist)))
     (('fn . _)
      (sex-error form "malformed function type" form))
 
@@ -291,8 +324,13 @@ forms, and what remains."
     (else
      (type-convert-to-c form))))
 
+;;; An array or a function type
+(define (structured-type? form)
+  (and (pair? form) (memq (car form) '(¤ fn))))
+
 (define (has-pointer-star? form)
   (and (pair? form)
+       (not (structured-type? form))
        (or (memq '* form)
            (any has-pointer-star? (filter pair? form)))))
 
@@ -304,6 +342,10 @@ forms, and what remains."
   (and (pair? type)
        (any has-pointer-star? (filter pair? type))))
 
+(define (nested-structured-type type)
+  (and (pair? type)
+       (find structured-type? (filter pair? type))))
+
 (define (type-convert-to-c type)
   ;; Our pointers to C pointers
   ;; int -> int
@@ -311,6 +353,12 @@ forms, and what remains."
   ;; const * const char -> const char * const
   (when (nested-pointer? type)
     (sex-error type "pointer chains are written flat, as (* * T), not nested" type))
+  (let ((inner (nested-structured-type type)))
+    (when inner
+      (if (eq? (car inner) 'fn)
+          ;; (fn ...) is spelled as the pointer it already is in C
+          (sex-error type "a fn type is a function pointer already: write (fn ...), not (* (fn ...))" type)
+          (sex-error type "a pointer to an array is not supported" type))))
   (if (atom? type) (atom-to-fmt-c type)
       (flatten
        (tree-map atom-to-fmt-c
@@ -334,29 +382,42 @@ forms, and what remains."
     ((¤ * const volatile struct union) #t)
     (else #f)))
 
+;;; Does the parameter name itself?
+;;; (f1 float) does
+;;; (float), (const char) and (¤ float 4) do not
+(define (named-arg? arg)
+  (and (pair? arg)
+       (pair? (cdr arg))                ; 1 element args are always type
+       (not (eq? (car arg) '¤))
+       (not (is-probably-type arg))))
+
+;;; The type of one parameter
+(define (arg-type arg)
+  (if (named-arg? arg)
+      (walk-type (maybe-unwrap-type (cdr arg)))
+      ;; A lone type may arrive wrapped in parens of its own, and those
+      ;; are not part of it: ((* const char))
+      ;; Plain names e.g. (int) are left as is
+      (walk-type (if (and (pair? arg) (null? (cdr arg)) (pair? (car arg)))
+                     (car arg)
+                     arg))))
+
 (define (walk-arglist form)
   ;; E.g.:
   ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
   ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
-  (map (fn
-        (match x
-          (('¤ . _) (walk-type x))
-
-          ;; yeah shitty, but I don't know yet how to determine if the
-          ;; first entry is part of the type and not an argument name
-          ;; :(
-          ((? is-probably-type) (walk-type x))
-
-          ;; 1 element args are always type
-          ((_) (walk-type x))
-
-          ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
-                                (list (walk-type var))))))
+  (map (lambda (arg)
+         (if (named-arg? arg)
+             (list (arg-type arg) (walk-type (car arg)))
+             (arg-type arg)))
        (remove comment-form? form)))
 
+(define (walk-arg-types form)
+  (map arg-type (remove comment-form? form)))
+
 (define (walk-function form)
-  ;; (fn ret-type name arglist body) -> normal function
-  ;; (fn ret-type name arglist) -> prototype
+  ;; (fn name arglist ret-type body) -> normal function
+  ;; (fn name arglist ret-type) -> prototype
   (if (>= (length form) 5)
       (walk-fn-def form)
       (cons '%prototype (cdr (walk-fn-def form)))))

reader.scm

@@ -115,6 +115,21 @@
      ((eq? tok dot-token) (error "Unexpected ."))
      (else tok))))
 
+;;; A token that stands for a datum
+(define (datum-token? tok)
+  (not (or (eof-object? tok)
+           (eq? tok close-paren)
+           (eq? tok close-bracket)
+           (eq? tok dot-token))))
+
+;;; next-token, sans the comments
+(define (next-code-token port)
+  (let loop ()
+    (let ((tok (next-token port)))
+      (if (comment-form? tok)
+          (loop)
+          tok))))
+
 ;;; Read list elements up to close-paren or close-bracket,
 ;;; honoring dotted-pair notation (a b . c)
 (define (read-list port closer)
@@ -208,13 +223,24 @@
    (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
+;;; to know where it ends -- and then either returned or dropped. What
+;;; follows a dropped datum is read in its place: `#+x #+y (a) (b)'
+;;; with only x is (b).
+;;;
+;;; That next thing may be nothing: the end of the file, or the
+;;; paren closing the list we are in
 (define (read-conditional port keep-when)
-  (let ((keep (eq? keep-when (feature-true? (read-datum port)))))
-    (if keep
-        (read-datum port)
-        (begin (read-datum port)
-               (next-token port)))))
+  (let* ((test (next-code-token port))
+         (keep (begin
+                 (unless (datum-token? test)
+                   (error "Unexpected end of input in feature expression"))
+                 (eq? keep-when (feature-true? test))))
+         (guarded (next-code-token port)))
+    (cond
+     (keep guarded)
+     ;; A datum was dropped, so the next one stands in for it
+     ((datum-token? guarded) (next-token port))
+     (else guarded))))
 
 ;;; #t / #true / #f / #false. `val' is the boolean; consume any
 ;;; trailing name characters and validate

semen.scm

@@ -72,7 +72,7 @@
     ((or ('var . _)
          ('pub 'var . _)
          ('extern 'var . _)) (process-global-var sex-form acc))
-    (('include _) (cons sex-form acc))
+    (('include . includes) (process-includes sex-form includes acc))
     ((or ('define name . _)
          ('pub 'define name . _))
      (add-define name sex-form)
@@ -92,6 +92,17 @@
 
     (else (sex-error sex-form "unknown top level form" sex-form))))
 
+(define (process-includes sex-form includes acc)
+  ;; consume (include ...) form and add to acc
+  ;; (include <inc>) for each include
+  (let process ((includes includes)
+                (acc acc))
+    (if (null? includes)
+        acc
+        (process (cdr includes)
+                 (cons (copy-form-source! sex-form `(include ,(car includes)))
+                       acc)))))
+
 (define (process-imports module-public-forms acc)
   ;; consume (import ...) form and process imports so
   ;; data types end up in types db
@@ -140,30 +151,79 @@
   (cons (copy-form-source! form `(typedef ,target ,new-type)) acc))
 
 ;;; Fn processing
+;;;
+;;; A string as the first body form is a docstring. In the generated
+;;; C code it will be placed as a C commentary just before the function
+;;; definition (actually that works for all blocky things: enum, struct, union as well).
 
-(define (comment-form? f)
-  (and (pair? f) (eq? (car f) 'comment)))
+(define (fn-header-length fn-form)
+  (if (memq (first fn-form) '(pub extern)) 5 4))
+
+(define (fn-core form)
+  ;; The (fn name args rettype . body) list, without pub/extern
+  (if (memq (first form) '(pub extern))
+      (cdr form)
+      form))
+
+(define (take-leading-docstring forms)
+  ;; If FORMS starts with a string, possibly after comment forms, return
+  ;; that string and FORMS without it. Otherwise #f and FORMS unchanged
+  (let loop ((fs forms) (prefix (list)))
+    (match fs
+      (() (values #f forms))
+      (((and cmt ('comment . _)) . rest)
+       (loop rest (cons cmt prefix)))
+      (((? string? doc) . rest)
+       (values doc (append (reverse prefix) rest)))
+      (_ (values #f forms)))))
+
+(define (extract-fn-docstring fn-form)
+  (let ((lift
+         (lambda (proto body)
+           (let-values (((doc rest) (take-leading-docstring body)))
+             (if doc
+                 (values doc (copy-form-source! fn-form (append proto rest)))
+                 (values #f fn-form))))))
+    (match fn-form
+      (('pub 'fn name args ret . body)
+       (lift `(pub fn ,name ,args ,ret) body))
+      (('extern 'fn name args ret . body)
+       (lift `(extern fn ,name ,args ,ret) body))
+      (('fn name args ret . body)
+       (lift `(fn ,name ,args ,ret) body))
+      (_ (values #f fn-form)))))
+
+(define (extract-aggregate-docstring form)
+  ;; A string immediately after the name is the docstring; comments
+  ;; between name and fields are not skipped, they already confuse the
+  ;; writer
+  (match form
+    (('pub (and kind (or 'struct 'union 'enum))
+           (? symbol? name) (? string? doc) . rest)
+     (values doc (copy-form-source! form `(pub ,kind ,name ,@rest))))
+    (((and kind (or 'struct 'union 'enum))
+      (? symbol? name) (? string? doc) . rest)
+     (values doc (copy-form-source! form `(,kind ,name ,@rest))))
+    (_ (values #f form))))
+
+(define (with-docstring doc form acc)
+  ;; acc is newest-first; FORM is consed last so the final reverse
+  ;; emits the comment immediately before the declaration
+  (cons form
+        (if doc
+            (cons (list 'comment doc) acc)
+            acc)))
 
 (define (strip-fn-header-comments fn-form)
-  ;; Remove comment forms from the function header
-  ;; ([pub|extern] fn name arglist rettype) so the positional accessors
-  ;; below are not shifted. Comments in the body are left in place as
-  ;; ordinary statements and preserved into the generated C.
-  (let ((header-count (if (memq (car fn-form) '(pub extern)) 5 4)))
-    ;; This always rebuilds the list, so the location has to be carried
-    ;; over explicitly -- otherwise every function loses it
-    (copy-form-source!
-     fn-form
-     (let loop ((form fn-form) (kept 0) (acc (list)))
-       (cond
-        ((null? form) (reverse acc))
-        ((= kept header-count) (append (reverse acc) form))
-        ((comment-form? (car form)) (loop (cdr form) kept acc))
-        (else (loop (cdr form) (+ kept 1) (cons (car form) acc))))))))
+  ;; ([pub|extern] fn name arglist rettype). Comments in the body are
+  ;; left in place as ordinary statements and preserved into the
+  ;; generated C.
+  (strip-header-comments fn-form (fn-header-length fn-form)))
 
 (define (process-fn sex-fn-raw acc)
-  (let* ((sex-fn (strip-fn-header-comments sex-fn-raw))
-         (expanded (macro-expand sex-fn))
+  (let-values (((doc sex-fn)
+                (extract-fn-docstring (strip-fn-header-comments sex-fn-raw))))
+    (let* ((expanded (macro-expand sex-fn))
            (env (make-hash-table))
            (processed
             (walk-form
@@ -174,9 +234,8 @@
                (set! (hash-table-ref env :lambda-counter) 0)
                (set! (hash-table-ref env :lambda-aux-code) (list))
                env))))
-
-    (cons processed
-          (append (hash-table-ref env :lambda-aux-code) acc))))
+      (with-docstring doc processed
+                      (append (hash-table-ref env :lambda-aux-code) acc)))))
 
 (define (fn-walker form env)
   (if (eq? 'lambda (car form))
@@ -196,10 +255,10 @@
 
 (define (make-aux-lambda-struct name form)
   (match form
-    (('lambda ret-type arglist captures . body)
+    (('lambda arglist ret-type captures . body)
      ;; Captures are ignored for now, but
      ;; we'll need them for TODO: closures support
-     (process-fn (copy-form-source! form `(fn ,ret-type ,name ,arglist ,@body))
+     (process-fn (copy-form-source! form `(fn ,name ,arglist ,ret-type ,@body))
                  (list)))
     (else (sex-error form "malformed lambda" form))))
 
@@ -207,8 +266,9 @@
 
 ;;; 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))
+  (let-values (((doc form) (extract-aggregate-docstring sex-struct)))
+    (register-aggregate! form)
+    (with-docstring doc form acc)))
 
 (define (register-aggregate! form)
   (let* ((f (if (eq? (car form) 'pub) (cdr form) form))
@@ -233,45 +293,36 @@
   "The `form` must be toplevel.
 Returns #f if the form is not a function, returns the form otherwise"
   (match form
-    ((fn . _) form)
-    ((pub fn . _) form)
+    ((or ('fn . _)
+         ('pub 'fn . _)
+         ('extern 'fn . _)) form)
     (else #f)))
 
 (define (sex-fn-public? fn-form)
-  (eq? (car fn-form) 'pub))
-
-(define (sex-fn-return-type fn-form)
-  (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (third fn-form)
-      (second fn-form)))
+  (eq? (first fn-form) 'pub))
 
 (define (sex-fn-name fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (fourth fn-form)
-      (third fn-form)))
+  (second (fn-core fn-form)))
 
 (define (sex-fn-arglist fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (fifth fn-form)
-      (fourth fn-form)))
+  (third (fn-core fn-form)))
+
+(define (sex-fn-return-type fn-form)
+  (assert (sex-fn? fn-form)
+          (fmt #f "Form " fn-form " is not a function"))
+  (fourth (fn-core fn-form)))
 
 (define (sex-fn-prototype fn-form)
   "Returns all except body"
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (take fn-form 5)
-      (take fn-form 4)))
+  (take fn-form (fn-header-length fn-form)))
 
 (define (sex-fn-body fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (if (sex-fn-public? fn-form)
-      (drop fn-form 5)
-      (drop fn-form 4)))
+  (drop fn-form (fn-header-length fn-form)))

sex-fmt-c.scm

@@ -14,6 +14,7 @@
      c-in-expr c-in-stmt c-in-test
      c-paren c-maybe-paren c-type c-literal? c-literal char->c-char
      c-struct c-union c-class c-enum c-typedef c-cast
+     c-braced-list c-compound c-designate
      c-expr c-expr/sexp c-apply c-op c-indent c-current-indent-string
      c-wrap-stmt c-open-brace c-close-brace
      c-block c-braced-block c-begin
@@ -277,6 +278,8 @@
               ((%comment) ((apply c-comment (cdr x)) st))
               ((:) ((apply c-label (cdr x)) st))
               ((%cast) ((apply c-cast (cdr x)) st))
+              ((%compound) ((apply c-compound (cdr x)) st))
+              ((%designate) ((apply c-designate (cdr x)) st))
               ((+ - & * / % ! ~ ^ && < > <= >= == != << >>
                   = *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
                ((apply c-op x) st))
@@ -306,17 +309,7 @@
                  ((apply c-op "-=" (cdr x)) st))
                 (else ((c-apply x) st))))))
            ((vector? x)
-            ((c-wrap-stmt
-              (fmt-try-fit
-               (fmt-let 'no-wrap? #t
-                        (cat "{" (fmt-join c-expr (vector->list x) ", ") "}"))
-               (lambda (st)
-                 (let* ((col (fmt-col st))
-                        (sep (string-append "," (make-nl-space col))))
-                   ((cat "{" (fmt-join c-expr (vector->list x) sep)
-                         "}" nl)
-                    st)))))
-             st))
+            ((c-wrap-stmt (c-braced-list (vector->list x))) st))
            (else
             ((c-literal x) st))))))
 
@@ -737,8 +730,11 @@
            (cat (c-type (cadr type) #f)
                 " (*" (or name "") ")("
                 (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
+          ;; MODIFIED FROM UPSTREAM fmt-c: a nameless declarator -- an
+          ;; array parameter of a function type, where C has no room
+          ;; for a name -- arrives as #f, and upstream printed it
           ((%array)
-           (let ((name (cat name "[" (if (pair? (cddr type))
+           (let ((name (cat (or name "") "[" (if (pair? (cddr type))
                                                  (c-expr (caddr type))
                                                  "")
                             "]")))
@@ -773,8 +769,11 @@
            (cat (c-type (cadr type) #f)
                 " (*" (or name "") ")("
                 (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
+          ;; MODIFIED FROM UPSTREAM fmt-c: a nameless declarator -- an
+          ;; array parameter of a function type, where C has no room
+          ;; for a name -- arrives as #f, and upstream printed it
           ((%array)
-           (let ((name (cat name "[" (if (pair? (cddr type))
+           (let ((name (cat (or name "") "[" (if (pair? (cddr type))
                                                  (c-expr (caddr type))
                                                  "")
                             "]")))
@@ -826,6 +825,25 @@
              (cat "(" (c-with-op 'paren (c-expr expr)) ")")
              (c-expr expr))))
 
+  ;; { a, b, c } -- on one line if it fits, one element per line if not.
+  (define (c-braced-list ls)
+    (fmt-try-fit
+     (fmt-let 'no-wrap? #t (cat "{" (fmt-join c-expr ls ", ") "}"))
+     (lambda (st)
+       (let* ((col (fmt-col st))
+              (sep (string-append "," (make-nl-space col))))
+         ((cat "{" (fmt-join c-expr ls sep) "}" nl) st)))))
+
+  ;; (T){ ... } -- a C99 compound literal, not a cast: the result is an
+  ;; unnamed object and an lvalue, so `&' on it is legal. At block scope
+  ;; it lives until the end of the enclosing block and no longer.
+  (define (c-compound type . init)
+    (cat "(" (c-type type) ")" (c-braced-list init)))
+
+  ;; .field = value, inside a braced list
+  (define (c-designate field value)
+    (cat "." (c-expr field) " = " (c-expr value)))
+
   (define (c-typedef type alias . o)
     (c-wrap-stmt
      (cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " "))))

sex-macros.scm

@@ -26,8 +26,8 @@
            (import scheme
                    (scheme base)
                    (only sex-macros cat comment)
-                   (only types get-type-info get-fields get-underlying-type
-                         type-match map-fields))
+                   (only types get-type-info get-tag-info get-fields
+                         get-underlying-type type-match map-fields))
            ,@body)))
 
 (define (get-macro name)

sex-modules.scm

@@ -8,6 +8,7 @@
   (chicken process-context)
   (chicken string)
   fmt
+  matchable
   reader
   srfi-1
   utils)
@@ -71,22 +72,35 @@
      (list)
      raw-forms)))
 
+(define (public-fn-interface raw-form)
+  ;; (pub fn name args ret . body) -> prototype, keeping a docstring so
+  ;; the importer can emit it above the declaration
+  (let ((form (strip-header-comments raw-form 5)))
+    (match form
+      (('pub 'fn name args ret)
+       form)
+      (('pub 'fn name args ret ('comment . _) . rest)
+       (public-fn-interface `(pub fn ,name ,args ,ret ,@rest)))
+      (('pub 'fn name args ret (? string? doc) . _)
+       `(pub fn ,name ,args ,ret ,doc))
+      (('pub 'fn name args ret . _)
+       `(pub fn ,name ,args ,ret)))))
+
 ;;; TODO: use semen facilities to analyze modules
 (define (process-public-interface-form form acc)
-  (case (car form)
-    ((pub)
-     (case (cadr form)
-       ;; 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)
+  (match form
+    ;; Reduced to a prototype, still `pub', so the importer declares it
+    ;; with external linkage
+    (('pub 'fn . _)
+     (cons (copy-form-source! form (public-fn-interface form)) acc))
+    (('pub 'var . _)
+     (match-let ((('pub 'var name type . _) (strip-header-comments form 4)))
+       (cons (copy-form-source! form `(extern var ,name ,type)) acc)))
+    (('pub (or 'define 'defmacro 'enum 'import 'include 'struct 'typedef 'union) . _)
      (cons (copy-form-source! form (cdr form)) acc))
-       (else (sex-error form "pub must be followed by a definition" form))))
-    (else acc)))
+    (('pub . _)
+     (sex-error form "pub must be followed by a definition" form))
+    (_ acc)))
 
 (define (load-persistent-module-paths)
   (let ((sex-module-path-env-var

sexc.scm

@@ -176,6 +176,7 @@ status, which is ours to pass on."
 
 (define prelude
   '((include inttypes.h)
+    (include stdbool.h)
 
     (typedef u8 uint8-t)
     (typedef i8 int8-t)

tests/basic.scm

@@ -31,10 +31,10 @@
   (test 'vector-ref (atom-to-fmt-c '¤))
   (test '%include (atom-to-fmt-c 'include))
 
-  ;; c89 stuff
-  (test 'int (atom-to-fmt-c 'bool))
-  (test 1 (atom-to-fmt-c 'true))
-  (test 0 (atom-to-fmt-c 'false))
+  ;; C99 onwards, true C spellings for bool
+  (test 'bool (atom-to-fmt-c 'bool))
+  (test 'true (atom-to-fmt-c 'true))
+  (test 'false (atom-to-fmt-c 'false))
 
   ;; dot-access -> %. member-access directive (kebab-converted operands)
   (test '(%. a b) (walk-expr '(dot-access a b)))

tests/codegen.scm

@@ -230,4 +230,33 @@ compiles."
     (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"))))
+      (emits? (in-fn "(var q (* * const char) 0)") "const char * * q")))
+
+  ;; A string as the first body form (or after the name of a struct,
+  ;; union or enum) is a docstring: it becomes a comment immediately
+  ;; before the declaration, not a statement inside it.
+  (test-group "docstrings"
+    (test-assert "appears before the function"
+      (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
+              "/* Greet NAME. */"))
+    (test-assert "and not inside the body as a statement"
+      (not (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
+                   "\"Greet NAME.\"")))
+    (test-assert "multiline keeps its paragraphs"
+      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
+              "Entry point."))
+    (test-assert "and the second paragraph too"
+      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
+              "ARGC and ARGV."))
+    (test-assert "a prototype with only a docstring stays a prototype"
+      (emits? "(fn helper ((a int)) int \"Forward.\")"
+              "helper (int a);"))
+    (test-assert "a string after the first statement is left alone"
+      (emits? "(fn f () void (g) \"not a docstring\")"
+              "\"not a docstring\""))
+    (test-assert "a struct docstring sits above the struct"
+      (emits? "(struct point \"A 2D point.\" ((x int) (y int)))"
+              "/* A 2D point. */"))
+    (test-assert "and an enum docstring too"
+      (emits? "(enum color \"RGB.\" (red green blue))"
+              "/* RGB. */"))))

tests/fmt-c-writer.scm

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

tests/modules/Makefile

@@ -11,6 +11,9 @@
 # It also checks what only a second translation unit can check: that an
 # imported type reaches the type database, by expanding a macro that
 # reads the imported struct's fields.
+#
+# The public forms carry comments in their headers, which the reduction
+# to a prototype and to an extern both have to look past.
 
 SEXC ?= ../../sexc
 

tests/modules/greet.sex

@@ -7,9 +7,15 @@
 
 (include stdio.h)
 
-(pub var greet-count int 0)
+(pub var greet-count ;; a comment in the header of a public form is
+                     ;; not part of it: what the importer is given has
+                     ;; to be `extern int greet-count', not a form
+                     ;; counted off by one
+  int 0)
 
-(pub struct greeting ((text (* const char)) (times int)))
+(pub struct greeting
+  "A greeting to print."
+  ((text (* const char)) (times int)))
 
 (pub enum mood (cheerful grumpy))
 
@@ -23,7 +29,9 @@
            (lambda (name field-type)
              `(printf "%s " ,(symbol->string name))))))
 
-(pub fn greet ((name (* const char))) void
+(pub fn greet ;; ...and here the prototype would lose its return type
+  ((name (* const char))) void
+  "Print a greeting for NAME."
   (++ greet-count)
   (printf "hello, %s\n" name))
 

tests/reader.scm

@@ -80,6 +80,22 @@
   ;; guards nest
   (feature-test '((a)) (x y) "#+x #+y (a)")
   (feature-test '((b)) (x) "#+x #+y (a) (b)")
+  ;; ...and the inner one may leave nothing behind: the end of the
+  ;; file, or the paren closing the list, is what the outer one then
+  ;; produces, and neither is an error
+  (feature-test '()      (x) "#+x #+y (a)")
+  (feature-test '((f))   (x) "(f #+x #+y 1)")
+  (feature-test '((f 2)) (x) "(f #+x #+y 1 2)")
+  (feature-test '((a))   (x) "(a) #+x #+y (b)")
+
+  ;; a comment between a guard and the form it guards describes the
+  ;; guard. Taking it for the guarded datum would leave the form itself
+  ;; unconditional
+  (feature-test '((a)) (x) "#+x ;; why\n (a)")
+  (feature-test '()    (y) "#+x ;; why\n (a)")
+  (feature-test '((b)) (y) "#+x ;; why\n (a) (b)")
+  ;; a comment after the guarded form is an ordinary form, and stays
+  (feature-test '((comment "; tail")) (y) "#+x (a) ;; tail")
 
   ;; a feature the program was not given is simply absent
   (feature-test '() () "#+anything (a)")

tests/semen.scm

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

tests/sex-programs/compound-literals.sex

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

tests/sex-programs/feature-flags.sex

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

tests/sex-programs/lambdas.sex

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

tests/types.module.scm

@@ -9,6 +9,7 @@
      map-fields
 
      get-type-info
+     get-tag-info
      get-fields
      get-underlying-type)
   "../types.scm")

tests/types.scm

@@ -79,6 +79,38 @@
         #f
         (get-fields 't-u8))
 
+  ;; C keeps typedefs and ordinary identifiers apart, and the canonical way
+  ;; to declare a struct uses both names at once. Neither declaration
+  ;; may stand on the other.
+  (add-struct 't-node '(struct t-node ((next (* t-node)) (v int))))
+  (add-typedef 't-node '(typedef t-node (struct t-node)))
+  (test "a typedef of a struct's own name keeps the struct reachable"
+        '((next (* t-node)) (v int))
+        (get-fields 't-node))
+  (test "and the tag is there under its own name"
+        '(struct t-node ((next (* t-node)) (v int)))
+        (get-tag-info 't-node))
+  (add-struct 't-rect '(struct t-rect ((w int) (h int))))
+  (add-define 't-rect '(define t-rect 3))
+  (test "a define of a tag's name does not hide the fields"
+        '((w int) (h int))
+        (get-fields 't-rect))
+
+  ;; A type built over a struct is not that struct. Handing back the
+  ;; element's fields would have a macro write v->x for an array
+  (add-typedef 't-points '(typedef t-points (¤ t-point 4)))
+  (test "an array of a struct has no fields of its own"
+        #f
+        (get-fields 't-points))
+  (add-typedef 't-point-p '(typedef t-point-p (* t-point)))
+  (test "nor does a pointer to one"
+        #f
+        (get-fields 't-point-p))
+  (add-typedef 't-cb '(typedef t-cb (fn ((t-point)) void)))
+  (test "nor a function type over one"
+        #f
+        (get-fields 't-cb))
+
   ;; A typedef can be written to lead back to itself. Resolving it must
   ;; stop rather than spin
   (add-typedef 't-loop-a '(typedef t-loop-a t-loop-b))

tools/sextest/sextest.scm

@@ -1,4 +1,5 @@
 (import scheme
+        (scheme base)                   ; let-values
         brev-separate
         (chicken base)
         (chicken file)
@@ -33,27 +34,45 @@
          (cons (list) (list))
          contents))
 
-;;; --features from the (compilation ...) form, which we have to honour
-;;; ourselves: the program is read here and printed back out for sexc,
-;;; so #+ and #- are resolved on this side
+;;; The feature flags of the (compilation ...) form, which we have to
+;;; honour ourselves: the program is read here and printed back out for
+;;; sexc, so #+ and #- are resolved on this side.
+;;;
+;;; Returns the named features and whether the host's own are in play
 (define (compilation-features settings)
   (let ((compilation (assoc 'compilation settings)))
-    (if compilation
-        (append-map (lambda (flag)
-                      (if (string-prefix? "--features=" flag)
-                          (map string->symbol
-                               (string-split (substring flag 11) ","))
+    (let loop ((flags (if compilation
+                          (string-split (cadr compilation))
                           (list)))
-                    (string-split (cadr compilation)))
-        (list))))
+               (features (list))
+               (platform #t))
+      (define (add names rest)
+        (loop rest
+              (append features (map string->symbol (string-split names ",")))
+              platform))
+      (cond
+       ((null? flags) (values features platform))
+       ;; past `--' the flags are the C compiler's
+       ((string=? (car flags) "--") (values features platform))
+       ((string=? (car flags) "--no-platform-features")
+        (loop (cdr flags) features #f))
+       ((and (member (car flags) '("-f" "--features")) (pair? (cdr flags)))
+        (add (cadr flags) (cddr flags)))
+       ((string-prefix? "--features=" (car flags))
+        (add (substring (car flags) 11) (cdr flags)))
+       ((string-prefix? "-f" (car flags))
+        (add (substring (car flags) 2) (cdr flags)))
+       (else (loop (cdr flags) features platform))))))
 
 (define (process-file target-path)
-  (let* ((first-pass (split-settings (read-raw-forms target-path)))
-         (features (compilation-features (car first-pass))))
-    (if (null? features)
+  (let ((first-pass (split-settings (read-raw-forms target-path))))
+    (let-values (((features platform?) (compilation-features (car first-pass))))
+      (if (and (null? features) platform?)
           first-pass
-        (parameterize ((current-features (append (platform-features) features)))
-          (split-settings (read-raw-forms target-path))))))
+          (parameterize ((current-features
+                          (append (if platform? (platform-features) (list))
+                                  features)))
+            (split-settings (read-raw-forms target-path)))))))
 
 (define (compile src compilation sexc)
   (let ((compiler (or

tools/sextest/utils.module.scm

@@ -2,6 +2,8 @@
     (get-env-var
      set-working-directory
      to-absolute-pathname
+     comment-form?
+     strip-header-comments
      list-split
      list-join
      recons

types.module.scm

@@ -9,6 +9,7 @@
      map-fields
 
      get-type-info
+     get-tag-info
      get-fields
      get-underlying-type)
     "types.scm")

types.scm

@@ -15,7 +15,11 @@
   srfi-1
   srfi-69)
 
-(define +type-db+ (make-hash-table))
+;;; Two namespaces: `struct point' and a `point' typedef are separate
+;;; declarations. Tags -- struct, union and enum alike -- share the
+;;; second table between them
+(define +type-db+ (make-hash-table))    ; typedefs and defines
+(define +tag-db+ (make-hash-table))     ; struct, union and enums
 
 (define (strip-pub form)
   (if (eq? (car form) 'pub) (cdr form) form))
@@ -44,17 +48,17 @@
         (list))))
 
 (define (add-struct name form)
-  (hash-table-set! +type-db+ name
+  (hash-table-set! +tag-db+ name
                    (list 'struct name (normalize-fields (aggregate-fields form)))))
 
 (define (add-union name form)
-  (hash-table-set! +type-db+ name
+  (hash-table-set! +tag-db+ name
                    (list 'union name (normalize-fields (aggregate-fields form)))))
 
 ;;; ([pub] enum name (value ...))
 (define (add-enum name form)
   (let ((f (strip-pub form)))
-    (hash-table-set! +type-db+ name
+    (hash-table-set! +tag-db+ name
                      (list 'enum name (if (and (pair? (cddr f)) (list? (caddr f)))
                                           (caddr f)
                                           (list))))))
@@ -70,8 +74,14 @@
   (hash-table-set! +type-db+ name
                    (list 'define name (cddr (strip-pub form)))))
 
+(define (get-tag-info name)
+  (hash-table-ref/default +tag-db+ name #f))
+
+;;; First look up the ordinary identifier, then tag of that id when
+;;; no ordinary one was declared, as C does
 (define (get-type-info name)
-  (hash-table-ref/default +type-db+ name #f))
+  (or (hash-table-ref/default +type-db+ name #f)
+      (get-tag-info name)))
 
 ;;; ((name type) ...) for a struct or union, #f for anything else --
 ;;; including a name that was never declared. Callers give the better
@@ -100,19 +110,31 @@
 
 ;;; 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)
+;;; NAME's own info
+(define (target-tag target)
+  (cond
+   ((symbol? target) target)
    ((and (pair? target)
+         (memq (car target) '(struct union enum))
          (pair? (cdr target))
          (symbol? (cadr target)))
     (cadr target))
-                               (else #f))))
-               (and tag (get-type-info tag)))
+   (else #f)))
+
+(define (resolve-type-info name)
+  (let ((info (resolve-ordinary-type-info name)))
+    (if (and info (memq (car info) '(struct union enum)))
+        info
+        (or (get-tag-info name) info))))
+
+(define (resolve-ordinary-type-info name)
+  (let ((info (get-type-info name)))
+    (and info
+         (if (eq? (car info) 'typedef)
+             (let ((tag (target-tag (get-underlying-type name))))
+               ;; A typedef target is written in type position, where
+               ;; `struct point' means the tag
+               (and tag (or (get-tag-info tag) (get-type-info tag))))
              info))))
 
 ;;; Type matcher macro

utils.module.scm

@@ -2,6 +2,8 @@
     (get-env-var
      set-working-directory
      to-absolute-pathname
+     comment-form?
+     strip-header-comments
      list-split
      list-join
      recons

utils.scm

@@ -42,6 +42,24 @@
        (current-directory)
        pathname)))
 
+(define (comment-form? form)
+  (and (pair? form) (eq? (car form) 'comment)))
+
+;;; Remove the comment forms from the first COUNT elements of FORM --
+;;; its header -- so that the positional accessors reading it are not
+;;; shifted by one
+(define (strip-header-comments form count)
+  ;; This always rebuilds the list, so the location has to be carried
+  ;; over explicitly -- otherwise every form loses it
+  (copy-form-source!
+   form
+   (let loop ((rest form) (kept 0) (acc (list)))
+     (cond
+      ((null? rest) (reverse acc))
+      ((= kept count) (append (reverse acc) rest))
+      ((comment-form? (car rest)) (loop (cdr rest) kept acc))
+      (else (loop (cdr rest) (+ kept 1) (cons (car rest) acc)))))))
+
 (define (list-split src-list split-elt)
   ;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6))
   (fold (lambda (elt acc)