Make Sex templates more pleasant syntactically

No more unquotes to instantiate templates.
Also no need to pass quoted substitution lists, just use them as
regular lisp macros.

.gitea/workflows/build.yaml

@@ -1,67 +0,0 @@
-name: Sex CI
-
-on:
-  push:
-    branches: [main]
-  pull_request:
-    branches: [main]
-  workflow_dispatch:
-
-jobs:
-  build-linux:
-    runs-on: ubuntu-latest
-    steps:
-      - name: Fetch repository
-        env:
-          GITEA_TOKEN: ${{ secrets.GITEA_TOKEN }}
-        run: |
-          set -eu
-          git config --global --add safe.directory "$PWD"
-          git init
-          git remote add origin "${GITHUB_SERVER_URL%/}/${GITHUB_REPOSITORY}.git"
-          git -c http.extraHeader="Authorization: token ${GITEA_TOKEN}" \
-            fetch --depth 1 origin "${GITHUB_SHA}"
-          git checkout --force FETCH_HEAD
-
-      - name: Install toolchain
-        run: |
-          set -eu
-          if [ "$(id -u)" -eq 0 ]; then
-            apt-get update
-            apt-get install -y --no-install-recommends build-essential git wget ca-certificates
-          else
-            sudo apt-get update
-            sudo apt-get install -y --no-install-recommends build-essential git wget ca-certificates
-          fi
-
-      - name: Install Chicken
-        env:
-          CHICKEN_VERSION: "6.0.0"
-          CHICKEN_SHA256: 92835552b1b687ad26737e429b5aba36510bf429f8816ec0f6d336c8cb41f443
-        run: |
-          set -eu
-          tarball="chicken-${CHICKEN_VERSION}.tar.gz"
-          wget -N "https://code.call-cc.org/releases/${CHICKEN_VERSION}/${tarball}"
-          echo "${CHICKEN_SHA256}  ${tarball}" | sha256sum -c
-          tar zxf "${tarball}"
-          (
-            cd "chicken-${CHICKEN_VERSION}"
-            ./configure --prefix=/usr/local
-            make -j"$(nproc)"
-            if [ "$(id -u)" -eq 0 ]; then
-              make install
-            else
-              sudo make install
-            fi
-          )
-          hash -r
-          csc -version
-
-      - name: Install dependencies
-        run: make deps
-
-      - name: Build sexc
-        run: make && ./sexc --help
-
-      - name: Run tests
-        run: make check

.gitignore

@@ -1,14 +0,0 @@
-# Project-local Chicken egg repository
-/.eggs
-
-# Compilation artifacts
-*.o
-*.import.scm
-*.link
-sexc
-sex-tests
-sextest
-tools/sextest/sextest
-
-# Scrapped design docs, kept for reference
-/attic

Makefile

@@ -1,175 +1,19 @@
-CHICKEN_C ?= csc
-CHICKEN_INSTALL ?= chicken-install
-CHICKEN_STATUS ?= chicken-status
-CSC_FLAGS += -K prefix -static
-# What and why:
-# -emit-all-import-libraries: Emit import-libraries for all defined modules.
-#    Used to generate .import.scm files so compiler would know how to use the modules.
-#    Without it, csc fails with "cannot import from undefined module" error.
-# -module-registration: Always  generate  module registration code, even when
-#    import libraries are emitted. Enables us to import from our modules at run time.
-#    Used in macros, where we inject `(import (only sex-macros cat))' before the macro body.
-#    Without it, sexc compiles scuccessfully, but is unable to process macros, failing with
-#    "during expansion of (import ...) - cannot import from undefined module: sex-macros"
-#     error.
-# -c: Stop after compilation to object files. This one is obvious.
+CHICKEN_C = csc
 
-# GNU directory variables. Command line overrides, e.g.
-#   make prefix=$(HOME)/.local install
-#   make DESTDIR=/tmp/stage prefix=/usr install
-prefix = /usr/local
-exec_prefix = $(prefix)
-bindir = $(exec_prefix)/bin
-INSTALL = install
-INSTALL_PROGRAM = $(INSTALL)
-
-MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
-
-# Order matters, since module check correctness on compilation
-MODULES = utils types infer sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
+MODULES = sexc templates main
 OBJ = $(MODULES:%=%.o)
 
-DEPSFILE = dependencies.txt
-DEPSLOCK = eggs.lock
-EGGS_DIR := $(abspath .eggs)
+# chicken flags
+CFLAGS = -compile-syntax
 
-# Compiler's own repository (types.db, chicken.*), ignoring ambient venv vars.
-SYSTEM_CHICKEN_REPO := $(shell env \
-	-u CHICKEN_INSTALL_REPOSITORY -u CHICKEN_REPOSITORY_PATH \
-	-u CHICKEN_EGG_CACHE -u CHICKEN_INSTALL_PREFIX \
-	$(CHICKEN_INSTALL) -repository 2>/dev/null)
-CHICKEN_ABI := $(notdir $(SYSTEM_CHICKEN_REPO))
-EGGS_STAMP := $(EGGS_DIR)/.installed-$(CHICKEN_ABI)
+sexc: $(OBJ)
+	$(CHICKEN_C) $^ -o $@
 
-# 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)
+main.o: main.scm
+	$(CHICKEN_C) $< -c -o $@
 
-all: sexc
-
-sexc: $(OBJ) main.scm
-	$(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc
-        # otherwise csc hangs, probably because it tries to compile to sexc.o first
-	mv sexc-tmp sexc
-
-#------------------------------------------------------------------
-
-utils.o: utils.module.scm utils.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
-
-types.o: types.module.scm types.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types
-
-infer.o: infer.module.scm infer.scm types.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) infer.module.scm -o infer.o -unit infer -link types,utils
-
-sex-macros.o: sex-macros.module.scm sex-macros.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
-
-reader.o: reader.module.scm reader.scm utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
-
-sex-modules.o: sex-modules.module.scm sex-modules.scm reader.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
-
-semen.o: semen.module.scm semen.scm infer.o sex-macros.o sex-modules.o types.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,infer,types,utils
-
-sex-fmt-c.o: sex-fmt-c.scm
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
-
-fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o types.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,types,utils
-
-sexc.o: sexc.module.scm infer.o types.o sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,infer,types,utils
-
-# Unit testing
-sex-tests:
-	$(MAKE) -C ./tests sex-tests
-	cp ./tests/sex-tests ./
-
-sextest:
-	$(MAKE) -C ./tools/sextest sextest
-	cp ./tools/sextest/sextest .
-
-SEX_TEST_PROGRAMS = c99 \
-                    closure-signatures \
-                    closures \
-                    comments \
-                    compound-literals \
-                    feature-flags \
-                    features \
-                    fixpoint \
-                    hello-world \
-                    inference \
-                    lambdas \
-                    lists \
-                    operators \
-                    serialize \
-                    type-shapes \
-                    unicode \
-                    unnamed-params \
-                    wildcards
-
-# Multi-module linking is checked end to end; see tests/modules/Makefile.
-check-modules: sexc
-	@$(MAKE) --no-print-directory -C ./tests/modules check SEXC=../../sexc
-
-# The failure paths are checked end to end; see tests/exit-code/Makefile.
-check-exit-code: sexc
-	@$(MAKE) --no-print-directory -C ./tests/exit-code check SEXC=../../sexc
-
-check run-tests: sexc sex-tests sextest
-	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules && $(MAKE) check-exit-code
-
-install: all installdirs
-	$(INSTALL_PROGRAM) sexc $(DESTDIR)$(bindir)/sexc
-
-install-strip:
-	$(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
-
-installdirs:
-	$(INSTALL) -d $(DESTDIR)$(bindir)
-
-uninstall:
-	rm -f $(DESTDIR)$(bindir)/sexc
-
-$(EGGS_STAMP) deps-update: export CHICKEN_EGG_CACHE := $(EGGS_DIR)/cache
-$(EGGS_STAMP) deps-update: export CHICKEN_INSTALL_REPOSITORY := $(EGGS_DIR)
-$(EGGS_STAMP) deps-update: export CHICKEN_INSTALL_PREFIX := $(EGGS_DIR)
-$(EGGS_STAMP) deps-update: export CHICKEN_REPOSITORY_PATH := $(EGGS_DIR):$(SYSTEM_CHICKEN_REPO)
-
-$(EGGS_STAMP): $(DEPSLOCK)
-	mkdir -p $(CHICKEN_EGG_CACHE)
-	$(CHICKEN_INSTALL) -force -from-list $(DEPSLOCK)
-	touch $@
-
-deps: $(EGGS_STAMP)
-
-deps-update: $(DEPSFILE) deps-clean
-	mkdir -p $(CHICKEN_EGG_CACHE)
-	$(CHICKEN_INSTALL) -force $$(cat $(DEPSFILE))
-	# Local repo only: a system path here would leak distro eggs into the lock.
-	CHICKEN_REPOSITORY_PATH=$(EGGS_DIR) $(CHICKEN_STATUS) -list | sort > $(DEPSLOCK).tmp
-	mv $(DEPSLOCK).tmp $(DEPSLOCK)
-	touch $(EGGS_STAMP)
+%.o: %.scm
+	$(CHICKEN_C) $< -e -c -o $@ $(CFLAGS)
 
 clean:
-	rm -f $(OBJ) main.o
-	rm -f *.import.scm
-	rm -f *.link
-	rm -f sexc sex-tests sextest
-	$(MAKE) -C ./tests clean
-	$(MAKE) -C ./tests/modules clean
-	$(MAKE) -C ./tools/sextest clean
-
-deps-clean:
-	rm -rf $(EGGS_DIR)
-
-.PHONY: all check run-tests check-modules check-exit-code \
-        install install-strip installdirs uninstall \
-        deps deps-update deps-clean clean sex-tests sextest
+	rm -f $(OBJ) sexc

Readme.org

@@ -1,123 +1,66 @@
 * The Sex language
+Sex is a S-expressions language, which transpiles to C.
 
-#+NAME: the Sex logo
-#+ATTR_HTML: :width 300px
-[[sex.png][file:./sex.png]]
+Sex is also Chicken, since all source processing and compile-time
+computations are written in Chicken.
 
-Sex is a S-expressions language. Sex is written in Chicken, which is an
-[[https://call-cc.org][R7RS Scheme]].
-Sex is statically typed, compiled general purpose language.
+And Chicken is [[https://call-cc.org][R5RS Scheme]].
 
-* Compilation
-First, get yourself a Chicken, then, some Chicken deps. You also will
-need a C compiler.
+* Compilation and usage
+First, get yourself a Chicken. Second, some Chicken deps.
 
-** Development
-#+begin_src sh
-  make deps
-  make
-#+end_src
+** Install Chicken Eggs
+By the way, there's a way to make Chicken install eggs non-globally. Refer to
+the documentation for more info:
+https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
 
-~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:
+~chicken-install fmt getopt-long brev-separate~
 
-#+begin_src sh
-  make deps-update
-#+end_src
+** Compilation
+~make~
 
-** Packaging for system package managers
-- Depend ~sex~ package on Chicken-6 (with ~libchicken.a~) and all eggs from ~dependencies.txt~.
-- Compile and install with ~make~ (usually no other arguments required).
-- Move resulting ~sexc~ binary to the appropriate place.
-
-** Static compilation
-The default ~CSC_FLAGS~ include ~-static~, so ~sexc~ does not need
-~.eggs~ at runtime and ~make install~ stays relocatable. Chicken must
-provide ~libchicken.a~ (E.g. for gentoo: ~dev-scheme/chicken~ with
-~static-libs~ use flag).
-
-To link dynamically instead (the binary will look for eggs under this
-tree's ~.eggs~ path):
-
-#+begin_src sh
-  make CSC_FLAGS='-K prefix'
-#+end_src
-
-** Installation
-GNU directory variables: ~prefix~, ~exec_prefix~, ~bindir~, ~DESTDIR~.
-
-#+begin_src sh
-  # default installation (/usr/local/bin/)
-  make install
-  # customize the prefix (installs to ~/.local/bin)
-  make prefix=$(HOME)/.local install
-  # staged install for packaging
-  make DESTDIR=/tmp/stage prefix=/usr install
-#+end_src
-
-* Usage
-** Summary
+** Usage
+You'll also need a C compiler, so pick any.
 #+begin_src
-Usage: sexc [options] filename [-- options-for-c-compiler]
-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
- -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
- -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
-sexc ./examples/hello-world.sex -o hello
+cat hello-world.sex | sexc > hello_world.c
+cc hello_world.c -o hello_world
 #+end_src
 
-That's it. Now you should have executable named ~hello~ in your
-directory. Sex uses C under the hood, the default C compiler is ~cc~,
-but you can pass any using ~--c-compiler~ option, or by setting
-~SEX_CC~ environment variable.
+* Example
+Here is an example, demonstrating what Sex source looks like, and what
+it compiles too. An avid reader also shall notice how we call Chicken
+procedures in Sex source.
 
-Everything after ~--~ is handed to the C compiler exactly as written:
-
-#+begin_src shell
-sexc example/sdl3-triangle.sex -o triangle -- `pkg-config --cflags --libs sdl3` -framework OpenGL
-#+end_src
-
-** Example
-An example of Sex source:
-#+begin_src scheme
+The Sex source:
+#+begin_src
 (include stdio.h)
 
-(pub fn main ((argc int) (argv  [* const char])) int
-  (puts "Hello from Sex!")
-  (var name [char 512])
-  (puts "What is your name?")
-  (scanf "%s" (cast (& name) (* char)))
-  (printf "Hello, %s!\n" name)
-  (return 0))
+(define (foo)
+  "Hello from Chicken code!\n")
+
+(pub fn int main ((int argc) (char **argv))
+    (puts "Hello from Sex!")
+    (var (array char 512) name)
+    (puts "What is your name?")
+    (scanf "%s" &name)
+    (printf "Hello, %s!\n" name)
+    (printf ,(foo))
+    0)
 #+end_src
 
-Compile and run:
-#+begin_src shell
-~/dev/sex $ ./sexc ./example/hello-world.sex -o hello-world
-~/dev/sex $ ./hello-world
-Hello from Sex!
-What is your name?
-Alex
-Hello, Alex!
+The resulting C source:
+#+begin_src
+#include <stdio.h>
+
+int main (int argc, char **argv) {
+    puts("Hello from Sex!");
+    char name[512];
+    puts("What is your name?");
+    scanf("%s", &name);
+    printf("Hello, %s!\n", name);
+    printf("Hello from Chicken code!\n");
+    return 0;
+}
 #+end_src
 
 * Features
@@ -125,151 +68,145 @@ Hello, Alex!
 Just ~(include "Your/Favourite/Library.h")~ and use it as you would
 have is C.
 
-*** Auto kebabification
 For hardcore fans of traditional Lisp naming convention,
-Sex offers automatic kebabification of all symbols, i.e. no more
+Sex offers automatic unkebabification of all symbols, i.e. no more
 ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
 proper form: ~GL-ARRAY-BUFFER~.
 
-** Modules
-Each source file is a module. Module can provide public interface and
-be imported by using ~(import path/to/module)~ expression. Module
-search path consists of two parts: first is relative to the source
-being compiled location, and the second is ~SEX_MODULE_PATH~
-environment variable.
+** Auto typedef for structs
+Probably harmless idk. Example:
+#+begin_src
+(struct foo
+  ((float a)
+   (int b)))
+#+end_src
+expands to
+#+begin_src
+typedef struct foo foo;
 
-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)
+struct foo {
+    float a;
+    int b;
+};
 #+end_src
 
-An expression is a feature name, or ~and~, ~or~ and ~not~ of them.
+** Syntactic templates
+Sex has support for template substitutions. Any piece of code can be
+templated. Template declarations look like functions: they have a
+name, an argument list and a body. When declared template is
+encountered during reading of Sex code, its body will udergo syntactic
+rewriting using the provided values by the following rules:
+1. If the value is a symbol, all arguments in a body are replaced with
+   the value, and also all /parts/ of any other symbol equal to the
+   value also get replaced.
+2. If the value is a non-symbolic form, all arguments in a body are
+   replaced with it, but no symbolic substitution is performed.
 
-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
+Formally, template declaration has the following syntax:
+#+begin_src
+(template (name . substitute-args) . body)
 #+end_src
 
-A feature is never taken away. The host's features can be disabled,
-e.g. for checking output for other platform:
-
-#+begin_src shell
-sexc example/sdl3-triangle.sex -C --no-platform-features --features=linux,unix,x86-64
-#+end_src
-
-** Aggregate initializers and compound literals
-~#(...)~ is a brace initializer. On its own it has no type and takes one
-from where it is written:
-
-#+begin_src scheme
-(var p (struct point) #(1 2))
-#+end_src
-
-A ~:~ inside one ends a type and makes the whole thing a compound
-literal --- an unnamed object of that type, usable anywhere an
-expression is:
-
-#+begin_src scheme
-(var q (struct point) #(struct point : 3 4))
-(var a (* int) #([int 3] : 10 20 30))
-(draw-line ui #(struct point : 0 0) end)
-(var p (* struct point) (& #(struct point : 9 9)))  ; an lvalue, so `&' works
-#+end_src
-
-The type is written as bare words, the way it is everywhere else in the
-language; ~:~ is what ends it.
-
-A leading ~.~ names a field, so initializers may be designated, given in
-any order, and mixed with positional ones:
-
-#+begin_src scheme
-(var r (struct named) #(struct named : .n 7 .first-name "zoe"))
-#+end_src
-
-A compound literal written inside a block lives until the end of that
-block and no longer, so returning its address is a dangling pointer.
-
-** Syntactic macros
-Sex has support for syntactic macros. Macro definitions look like
-functions: they have a name, an argument list and a body. Macro should
-return Sex code.
-
-A macro returns *one* form. To return several --- a function beside the
-struct it works on, say --- return them under =$=, which splices them in
-where the macro was written:
-
-#+begin_src scheme
-  (defmacro (pair-of-fns a b)
-    `($ (fn ,a () int (return 1))
-        (fn ,b () int (return 2))))
-#+end_src
-
-=($)= expands to nothing. Everything else is a single form, including
-one whose head is itself a form: =`((make-adder 10) 5)= calls what
-=make-adder= returned, and is not two forms.
-
 *** Examples:
 **** Structure with templated value type
-#+begin_src scheme
-(pub defmacro (list-T type)
-  (let ((list-type (cat 'list- type)))
-    `(struct ,list-type
-       ((value ,type)
-        (next (* ,list-type))))))
+#+begin_src
+(template (foo ?T)
+  (struct foo-?T
+    ((?T value))))
 
-(list-T int)
+(foo float)
 #+end_src
 ->
-#+begin_src scheme
-(struct list_int
- ((value int)
-  (next (* list_int))))
+#+begin_src
+typedef struct foo_float foo_float;
+
+struct foo_float {
+    float value;
+};
 #+end_src
 
-**** Wrapper for checking return codes
-#+begin_src scheme
-(pub defmacro (check-sdl-return call message ret-code)
-  `(if (< 0 ,call)
-       (do
-         (puts ,message)
-         (return ,ret-code))))
+Note that ~?~ at the start of template argument is not syntax, just
+convention.
 
-(pub fn init () int
+**** Wrapper for checking return codes
+#+begin_src
+(template (check-sdl-return call message ret-code)
+  (if (< 0 call)
+      (begin
+       (puts message)
+       (return ret-code))))
+
+(fn int init ()
   (check-sdl-return
     (SDL-Init SDL-INIT-VIDEO) "Failed to initialize SDL" 1)
 ...)
 #+end_src
 ->
-#+begin_src scheme
-(pub fn init () int
-  (if (< 0 (SDL_Init SDL_INIT_VIDEO))
-    (do (puts "Failed to initialize SDL") (return 1)))
-  ...)
+#+begin_src
+static int init () {
+    if (0 < SDL_Init(SDL_INIT_VIDEO)) {
+        puts("Failed to initialize SDL");
+        return 1;
+    }
+    return 0;
+}
 #+end_src
 
-** Compile-time type information
-Sex has a number of type reflection features, aiming to help with
-macro writing. During the compilation, all type info is collected, and
-is accessible during macro expansion. This allows us to write things
-like providing auto serialization, adding meta information, and so on.
+**** A bit of everything
+#+begin_src
+(template (list-T ?T)
+  (struct list-?T
+    ((?T value)
+     ((* list-?T) next))))
+
+(template (list-for-each type list-var elt-var body)
+  (var type elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    body
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))
+
+; ... somewhere later
+(list-T int)
+
+(pub fn void print-list (((const list-int) *l))
+     (list-for-each int l v (printf "%d " v))
+     (printf "\n"))
+#+end_src
+Then will be expanded in the following code:
+#+begin_src
+(typedef struct list_int list_int)
+(struct list_int ((int value) ((* list_int) next)))
+(%fun void
+      print_list
+      (((const list_int) *l))
+      (%var int v (-> l value))
+      (while (!= (-> l next) NULL)
+             (printf "%d " v)
+             (= l (-> l next))
+             (= v (-> l value)))
+      (printf "\n"))
+#+end_src
+
+And then translated to:
+#+begin_src
+typedef struct list_int list_int;
+
+struct list_int {
+    int value;
+    list_int *next;
+};
+
+void print_list (const list_int *l) {
+    int v = l->value;
+    while (l->next != NULL) {
+        printf("%d ", v);
+        l = l->next;
+        v = l->value;
+    }
+    printf("\n");
+}
+#+end_src
 
 ** Use an established environment for development
 As Sex is S-expressions, you always have Emacs with paredit as your
@@ -278,8 +215,10 @@ best option.
 *** sex-mode.el
 To harness the power of sex-mode, add the following lines to your
 ~$HOME/.config/emacs/init.el~:
-#+begin_src emacs-lisp
+#+begin_src
 (use-package sex-mode
   :load-path "/path/to/sex"
-  :mode ("\\.sex\\'"))
+  :mode ("\\.sex\\'" "\\.seh\\'"))
 #+end_src
+
+** COMING SOON?: Polymorphism

dependencies.txt

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

eggs.lock

@@ -1,8 +0,0 @@
-(brev-separate "1.100")
-(fmt "0.8.14")
-(getopt-long "4.0")
-(matchable "1.2")
-(srfi-1 "0.5.1")
-(srfi-13 "0.3.8")
-(srfi-69 "0.5.3")
-(test "1.3")

example/fns.sex

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

example/hello-world.sex

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

example/lambdas.sex

@@ -1,48 +0,0 @@
-(include stdio.h)
-
-(fn sum ((a int) (b int)) int
-  (return (+ a b)))
-
-;;; A lambda captures nothing and is a bare function pointer; a closure
-;;; captures and is a value carrying its own environment
-(fn make-adder ((a int)) (closure ((int)) int)
-  (return (closure ((b int)) int (a)
-            (return (+ a b)))))
-
-(pub fn main () int
-  (var a int 10)
-  (var b int 20)
-  (var sum-fn (fn ((int) (int)) int) sum)
-
-  (var sum-lambda (fn ((int) (int)) int)
-
-       (lambda ((a int) (b int)) int
-         (return (+ a b))))
-
-  (var sum-lambda-2 (fn ((int)) int)
-
-       (lambda ((a int)) int
-         (return (+ a 20))))
-
-  (printf "Hello from main fn!\n")
-  (printf "We will now perform some function calling.\n")
-
-  (printf "Calling fn ptr: %d\n" (sum-fn a b))
-  (printf "Calling lambda: %d\n" (sum-lambda a b))
-  (printf "Calling other lambda: %d\n" (sum-lambda-2 a))
-  (printf "Calling lambda inplace: %d\n" ((lambda ((a int) (b int)) int
-                                            (return (+ a b 100)))
-                                          a b))
-
-  (var l-1 (fn ((int)) int)
-       (lambda ((a int)) int
-         (var l-2 (fn ((int)) int)
-              (lambda ((a int)) int
-                (return (+ 60 a))))
-         (return (+ 600 (l-2 a)))))
-  (printf "Calling nested lambdas: %d\n" (l-1 6))
-
-  (var add-10 (closure ((int)) int) (make-adder 10))
-  (var add-20 (closure ((int)) int) (make-adder 20))
-  (printf "Calling closures: %d %d\n" (add-10 24) (add-20 24))
-  (return 0))

example/list.seh

@@ -0,0 +1,36 @@
+(template (list-T ?T)
+  (struct list-?T
+    ((?T value)
+     ((* list-?T) next))))
+
+(template (make-list-T ?T is-public?)
+  (,@(if 'is-public? '(pub) '()) fn (* list-?T) make-list-?T ()
+   (var (* list-?T) list (cast (* list-?T) (malloc (sizeof list-?T))))
+   (= (-> list next) NULL)
+   list))
+
+(template (add-value-list-?T ?T is-public?)
+  (,@(if 'is-public? '(pub) '()) fn void add-value-list-?T ((list-?T *list) (T value))
+       (while (!= (-> list next) NULL)
+         (= list (-> list next)))
+       (= (-> list next) (make-list-?T))
+       (= (-> list value) value)))
+
+(template (length-list-?T ?T is-public?)
+  (,@(if 'is-public? '(pub) '()) fn size-t length-list-?T ((list-?T *list))
+   (var size-t n 0)
+   (while (!= (-> list next) NULL)
+     (= list (-> list next))
+     (++ n))
+   n))
+
+(template (is-empty-list-?T ?T is-public?)
+  (,@(if 'is-public? '(pub) '()) fn bool is-empty-list-?T ((list-?T *list))
+    (== (-> list next) NULL)))
+
+(template (list-for-each list-var elt-var what-do)
+  (var int elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    what-do
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))

example/list.sex

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

example/sdl3-triangle.sex

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

example/serialize.sex

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

example/test-list.sex

@@ -1,44 +1,69 @@
 (include stdlib.h)
 (include stddef.h)
+(include stdbool.h)
 (include stdio.h)
 
-(import list)
+(chicken-import srfi-1 brev-separate)                 ; list routines, e.g. fold
+
+(chicken-load "list.seh")
+
+(chicken-define (imports-test a b c)
+  (fold + 0 (list 1 2 3 a b c)))
 
 (struct foo
-  ((a-field float)
-   (b int)
-   (c (* const char))
-   (not (fn ((val bool)) bool))))
+  ((float a-field)
+   (int b)
+   ((const char *) c)
+   ((fn bool ((bool val))) not)))
 
-(var f (struct foo))
+(var foo f #((= .a-field 1.2)))
 
 (list-T int)
-(make-list-T int #f)
-(add-value-list-T int #f)
-(length-list-T int #f)
-(is-empty-list-T int #f)
+(make-list-T int)
+(add-value-list-T int)
+(length-list-T int)
+(is-empty-list-T int)
 
-(extern fn puk ((a int) (b float)) void)
-(pub fn baz () bool
-  (return true))
+(extern fn void puk ((int a) (float b)))
+(fn int bar () ,(imports-test 10 20 30))
+(pub fn void baz () true)
 
-(extern var i int)
-(var j int)
-(pub var k int)
+(extern var int i)
+(var int j)
+(pub var int k)
 
-(pub fn main () int
-     (var l (* struct list-int) (make-list-int))
-     (printf "Size of the list: %lu\n" (length-list-int l))
+(pub fn int main ()
+     (var (* list-int) l (make-list-int))
+     (printf "Size of the list: %zu\n" (length-list-int l))
      (add-value-list-int l 3)
      (add-value-list-int l 4)
-     (printf "Size of the list: %lu\n" (length-list-int l))
-     (list-for-each (struct list-int) l int v
+     (printf "Size of the list: %zu\n" (length-list-int l))
+     (list-for-each l v
        (printf "%d " v))
      (printf "\n")
-     (printf "Size of the list: %lu\n" (length-list-int l))
-     (printf "%p\n" (cast l->next (* void)))
-     (return 0))
+     (printf "%zu\n" l->next)
+     0)
 
-(pub fn print-list ((l (* const struct list-int))) void
-     (list-for-each (const struct list-int) l int v (printf "%d " v))
+(pub fn segs-renderer* create-renderer ())
+(pub fn void clear-command-buffer ((segs-renderer *r)))
+(pub fn void add-render-command ((segs-renderer *r) ((fn void ()) command)))
+(pub fn void commit-command-buffer ((segs-renderer *r)))
+
+(template (list-T ?T)
+  (struct list-?T
+    ((?T value)
+     ((* list-?T) next))))
+
+(template (list-for-each type list-var elt-var body)
+  (var type elt-var (-> list-var value))
+  (while (!= (-> list-var next) NULL)
+    body
+    (= list-var (-> list-var next))
+    (= elt-var (-> list-var value))))
+
+; ... somewhere later
+(list-T int)
+
+(pub fn void print-list (((const list-int) *l))
+     (list-for-each int l v (printf "%d " v))
      (printf "\n"))

fmt-c-writer.module.scm

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

fmt-c-writer.scm

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

hello-world.sex

@@ -0,0 +1,18 @@
+(include stdio.h)
+
+(define (foo)
+  "Hello from Chicken code!\n")
+
+(struct foo
+  ((int a)
+   (float b)))
+
+(pub fn int main ((int argc) (char **argv))
+    (var int a 10)
+    (puts "Hello from Sex!")
+    (var (array char 512) name)
+    (puts "What is your name?")
+    (scanf "%s" &name)
+    (printf "Hello, %s!\n" name)
+    (printf ,(foo))
+    0)

infer.module.scm

@@ -1,45 +0,0 @@
-(module infer
-    (;; The IR
-     tvar?
-     tvar-id
-     tvar-classes
-     tvar-rigid?
-     fresh-tvar
-     fresh-rigid-tvar
-
-     prim-type? prim-name prim-quals make-prim
-     ptr-type? ptr-target ptr-quals make-ptr
-     array-type? array-elt array-size make-array-type
-     fn-type? fn-ret fn-args fn-variadic? make-fn-type
-     agg-type? agg-kind agg-name agg-spelling agg-quals make-agg
-     alias-type? alias-name alias-expansion alias-quals make-alias
-     unknown-type? the-unknown-type
-
-     resolve
-     underlying
-     c-primitive?
-     type-quals
-     free-tvars
-     decay
-
-     ;; The boundary
-     parse-type
-     unparse-type
-
-     ;; Constraints
-     register-class!
-     add-instance!
-     entails?
-     default-tvar!
-     default-type-variables!
-
-     ;; Unification
-     unify
-
-     ;; Type schemes
-     scheme? scheme-vars scheme-constraints scheme-type
-     make-scheme
-     generalize
-     instantiate
-     substitute)
-  "infer.scm")

infer.scm

@@ -1,644 +0,0 @@
-;;; Type inference, layer 0: the type representation and unification.
-;;;
-;;; Nothing in the compiler calls this unit yet. It is the ground floor
-;;; of the pass described in Type-inference.org -- built and tested on
-;;; its own before a single form is routed through it.
-;;;
-;;; Two representations meet here. *Surface* types are the forms the
-;;; rest of the compiler passes around -- `int', `(* const char)',
-;;; `(¤ int 16)', `(fn ((int)) int)'. They are what the reader
-;;; produces, what the C writer consumes and what `type-match' compares
-;;; with `equal?', and they are hopeless for unification. The *IR*
-;;; below is the other one: mutable cells, so that solving a type
-;;; variable is a side effect rather than a substitution rebuilt at
-;;; every step.
-;;;
-;;; `parse-type' and `unparse-type' are the boundary between the two,
-;;; and they carry the whole compatibility burden: `unparse-type' must
-;;; produce the exact spelling `type-match' compares against, or the
-;;; reflection macros break by silently falling into their `else'
-;;; branch. That is what the round-trip test in tests/infer.scm is for,
-;;; and why it is driven by every type spelling that appears in the
-;;; repository.
-
-(import
-  scheme
-  (scheme base)
-  (chicken base)
-  matchable
-  srfi-1
-  srfi-69
-  types
-  utils)
-
-;;; ---------------------------------------------------------------
-;;; The IR
-;;; ---------------------------------------------------------------
-
-;;; A type variable is a mutable cell. `ref' is #f while unsolved and
-;;; the type it stands for once bound -- union-find, with the path
-;;; compression done in `resolve'.
-;;;
-;;; `classes' is the list of type classes the variable must satisfy
-;;; (`numeric', and one day `ord'); see "constraints" below. `rigid?'
-;;; marks a variable that must not unify with anything but itself --
-;;; unused until a `fn' grows type parameters, and five lines now
-;;; against an IR change later.
-(define-record-type <tvar>
-  (%make-tvar id ref classes rigid?)
-  tvar?
-  (id tvar-id)
-  (ref tvar-ref tvar-ref-set!)
-  (classes tvar-classes tvar-classes-set!)
-  (rigid? tvar-rigid?))
-
-;;; A primitive or otherwise nominal type. `name' is the list of words
-;;; making it up, so `int', `(unsigned int)' and `(long long)' are all
-;;; one node, and so is a name we have never parsed a declaration for
-;;; (`size-t', `GLuint'). The two cases are told apart by
-;;; `c-primitive?', which is what keeps a constraint over an unparsed C
-;;; typedef from being an error.
-(define-record-type <prim>
-  (make-prim name quals)
-  prim-type?
-  (name prim-name)
-  (quals prim-quals))
-
-(define-record-type <ptr>
-  (make-ptr target quals)
-  ptr-type?
-  (target ptr-target)
-  (quals ptr-quals))
-
-;;; `size' is an integer, or #f for `(¤ int)' -- an array of unwritten
-;;; length.
-(define-record-type <array>
-  (make-array-type elt size)
-  array-type?
-  (elt array-elt)
-  (size array-size))
-
-(define-record-type <fn>
-  (make-fn-type ret args variadic?)
-  fn-type?
-  (ret fn-ret)
-  (args fn-args)
-  (variadic? fn-variadic?))
-
-;;; struct / union / enum. Nominal: two of them are the same type when
-;;; they are the same kind and the same name. `spelling' is the surface
-;;; form it was written as, kept verbatim so that an aggregate defined
-;;; inline in a type position round-trips unchanged.
-(define-record-type <agg>
-  (make-agg kind name spelling quals)
-  agg-type?
-  (kind agg-kind)
-  (name agg-name)
-  (spelling agg-spelling)
-  (quals agg-quals))
-
-;;; A typedef. Transparent to unification -- it unifies as whatever it
-;;; expands to -- and opaque to printing, so a diagnostic and a
-;;; generated declaration both say `size-t' rather than `unsigned long'.
-(define-record-type <alias>
-  (make-alias name expansion quals)
-  alias-type?
-  (name alias-name)
-  (expansion alias-expansion)
-  (quals alias-quals))
-
-;;; `?'. Sex has full C interop, so `printf', `SDL-CreateWindow' and
-;;; `size-t' arrive from headers nobody parsed. Rather than reject
-;;; every real program, the lattice gets a top element: `?' is
-;;; consistent with every type and constrains nothing.
-(define-record-type <unknown>
-  (%make-unknown)
-  unknown-type?)
-
-(define the-unknown-type (%make-unknown))
-
-(define tvar-counter 0)
-
-(define (fresh-tvar . classes)
-  (set! tvar-counter (+ tvar-counter 1))
-  (%make-tvar tvar-counter #f (if (null? classes) (list) (car classes)) #f))
-
-(define (fresh-rigid-tvar . classes)
-  (set! tvar-counter (+ tvar-counter 1))
-  (%make-tvar tvar-counter #f (if (null? classes) (list) (car classes)) #t))
-
-;;; Follow a bound variable to what it stands for, compressing the path
-;;; on the way out. Every procedure that looks at a type's shape starts
-;;; here.
-(define (resolve type)
-  (if (and (tvar? type) (tvar-ref type))
-      (let ((target (resolve (tvar-ref type))))
-        (tvar-ref-set! type target)
-        target)
-      type))
-
-;;; ...and through any typedef as well, for the places that care what a
-;;; type *is* rather than what it is called.
-(define (underlying type)
-  (let ((t (resolve type)))
-    (if (alias-type? t)
-        (underlying (alias-expansion t))
-        t)))
-
-(define (type-quals type)
-  (cond ((prim-type? type) (prim-quals type))
-        ((ptr-type? type) (ptr-quals type))
-        ((agg-type? type) (agg-quals type))
-        ((alias-type? type) (alias-quals type))
-        (else (list))))
-
-;;; Array-to-pointer and function-to-function-pointer, for the
-;;; positions where C decays: a call argument, an operand of `+', the
-;;; subscripted half of `(¤ a i)'.
-(define (decay type)
-  (let ((t (underlying type)))
-    (cond ((array-type? t) (make-ptr (array-elt t) (list)))
-          ((fn-type? t) (make-ptr t (list)))
-          (else (resolve type)))))
-
-(define (free-tvars type)
-  (let collect ((t type) (acc (list)))
-    (let ((t (resolve t)))
-      (cond ((tvar? t) (if (memq t acc) acc (cons t acc)))
-            ((ptr-type? t) (collect (ptr-target t) acc))
-            ((array-type? t) (collect (array-elt t) acc))
-            ((alias-type? t) (collect (alias-expansion t) acc))
-            ((fn-type? t) (fold collect (collect (fn-ret t) acc) (fn-args t)))
-            (else acc)))))
-
-;;; ---------------------------------------------------------------
-;;; Surface -> IR
-;;; ---------------------------------------------------------------
-
-(define +qualifiers+ '(const volatile restrict))
-
-(define (qualifier? word) (memq word +qualifiers+))
-
-;;; `(const char)' written as `((const char))' is the same type: a
-;;; sublist that merely groups. The C writer unwraps these too.
-(define (maybe-unwrap type)
-  (if (and (list? type) (= 1 (length type)))
-      (car type)
-      type))
-
-(define (parse-type surface)
-  (cond
-   ((symbol? surface) (parse-words (list surface) (list) surface))
-   ((not (pair? surface)) (sex-error surface "not a type" surface))
-   ((eq? (car surface) '¤) (parse-array surface))
-   ((eq? (car surface) 'fn) (parse-fn surface))
-   ((memq '* surface) (parse-pointer-chain surface))
-   (else (parse-words surface (list) surface))))
-
-;;; A `*'-free run of words: qualifiers, then whatever they qualify.
-;;; `form' is only carried along so a complaint can say where it was
-;;; written.
-(define (parse-words words quals form)
-  (cond
-   ((null? words) (sex-error form "type is nothing but qualifiers" form))
-   ((qualifier? (car words))
-    (parse-words (cdr words) (cons (car words) quals) form))
-   ;; A single sublist left: grouping parens, as in (* (const struct s))
-   ((and (null? (cdr words)) (pair? (car words)))
-    (with-quals (parse-type (car words)) (reverse quals)))
-   ((memq (car words) '(struct union enum)) (parse-agg words (reverse quals)))
-   ((eq? (car words) '¤) (parse-array words))
-   ((eq? (car words) 'fn) (parse-fn words))
-   ((memq '* words) (parse-pointer-chain (append (reverse quals) words)))
-   (else (parse-name words (reverse quals) form))))
-
-;;; A name, one word or several: `int', `size-t', `(unsigned int)'.
-(define (parse-name words quals form)
-  (cond
-   ((not (every symbol? words)) (sex-error form "malformed type" form))
-   ;; The type-level wildcard. It is a fresh variable wherever it
-   ;; appears, which is what makes partial types -- `(* _)', `(¤ _ 4)'
-   ;; -- fall out for free rather than needing their own grammar.
-   ((equal? words '(_)) (fresh-tvar))
-   ((and (null? (cdr words)) (get-underlying-type (car words)))
-    => (lambda (target)
-         (make-alias (car words) (parse-type target) quals)))
-   (else (make-prim words quals))))
-
-;;; ([pub] struct name), (struct name (fields ...)), (struct (fields ...))
-(define (parse-agg words quals)
-  (let* ((kind (car words))
-         (name (and (pair? (cdr words)) (symbol? (cadr words)) (cadr words))))
-    (make-agg kind name words quals)))
-
-;;; (¤ elt ... size) -- the size is the last element when it is an
-;;; integer, and absent otherwise. The element words are unwrapped the
-;;; way the C writer unwraps them, so `[int 16]' and `[(int) 16]' are
-;;; one type.
-(define (parse-array surface)
-  (let* ((rest (cdr surface))
-         (sized? (and (pair? rest) (integer? (last rest))))
-         (size (and sized? (last rest)))
-         (words (if sized? (drop-right rest 1) rest)))
-    (when (null? words)
-      (sex-error surface "array type without an element type" surface))
-    (make-array-type (parse-type (maybe-unwrap words)) size)))
-
-;;; (fn ((int) (float)) void). Argument entries are types, not named
-;;; parameters -- a `fn' in type position has no room for names.
-(define (parse-fn surface)
-  (match surface
-    (('fn (? list? arglist) ret)
-     (let* ((variadic? (and (pair? arglist) (variadic-marker? (last arglist))))
-            (entries (if variadic? (drop-right arglist 1) arglist)))
-       (make-fn-type (parse-type ret)
-                     (map (lambda (entry) (parse-type (maybe-unwrap entry)))
-                          entries)
-                     variadic?)))
-    (else (sex-error surface "malformed function type" surface))))
-
-;;; `...' in an arglist, written bare or wrapped the way every other
-;;; entry is.
-(define (variadic-marker? entry)
-  (or (eq? entry '...) (equal? entry '(...))))
-
-;;; Pointer chains are written flat and read right to left: the last
-;;; `*'-separated run is the pointed-to type, and each run before it
-;;; qualifies one level of indirection. `(const * const char)' is a
-;;; const pointer to a const char.
-(define (parse-pointer-chain words)
-  (let* ((segments (list-split words '*))
-         (base (last segments))
-         (levels (reverse (drop-right segments 1))))
-    (when (null? base)
-      (sex-error words "pointer to nothing" words))
-    (fold (lambda (level acc)
-            (unless (every qualifier? level)
-              (sex-error words "only qualifiers may sit between two `*'" words))
-            (make-ptr acc level))
-          (parse-words (maybe-unwrap-segment base) (list) words)
-          levels)))
-
-(define (maybe-unwrap-segment segment)
-  (let ((s (maybe-unwrap segment)))
-    (if (list? s) s (list s))))
-
-;;; Re-qualify a parsed type, for the grouping case `(const (struct s))'
-;;; where the qualifier is read before the thing it qualifies.
-(define (with-quals type quals)
-  (if (null? quals)
-      type
-      (cond ((prim-type? type) (make-prim (prim-name type)
-                                          (append quals (prim-quals type))))
-            ((ptr-type? type) (make-ptr (ptr-target type)
-                                        (append quals (ptr-quals type))))
-            ((agg-type? type) (make-agg (agg-kind type) (agg-name type)
-                                        (agg-spelling type)
-                                        (append quals (agg-quals type))))
-            ((alias-type? type) (make-alias (alias-name type)
-                                            (alias-expansion type)
-                                            (append quals (alias-quals type))))
-            (else type))))
-
-;;; ---------------------------------------------------------------
-;;; IR -> surface
-;;; ---------------------------------------------------------------
-
-;;; Every result here has to be the spelling the rest of the compiler
-;;; already writes by hand, since `type-match' compares with `equal?'
-;;; and a near miss is silent.
-(define (unparse-type type)
-  (let ((t (resolve type)))
-    (cond
-     ((tvar? t) '_)
-     ((unknown-type? t) '?)
-     ((alias-type? t) (qualify (alias-quals t) (list (alias-name t))))
-     ((prim-type? t) (qualify (prim-quals t) (prim-name t)))
-     ((agg-type? t) (qualify (agg-quals t) (agg-spelling t)))
-     ((ptr-type? t)
-      (append (ptr-quals t) (list '*) (as-words (unparse-type (ptr-target t)))))
-     ((array-type? t)
-      (let ((elt (as-words (unparse-type (array-elt t)))))
-        (append (list '¤)
-                (if (and (pair? elt) (eq? (car elt) '¤)) (list elt) elt)
-                (if (array-size t) (list (array-size t)) (list)))))
-     ((fn-type? t)
-      (list 'fn
-            (append (map (lambda (arg) (as-arg (unparse-type arg))) (fn-args t))
-                    (if (fn-variadic? t) (list '(...)) (list)))
-            (unparse-type (fn-ret t))))
-     (else (error "unparse-type: not a type" t)))))
-
-;;; A one-word type is written bare, anything longer as a list --
-;;; `int', but `(const int)' and `(struct point)'.
-(define (qualify quals words)
-  (let ((all (append quals words)))
-    (if (and (null? quals) (= 1 (length all)))
-        (car all)
-        all)))
-
-;;; An argument in a `fn' type is written as a list even when it is one
-;;; word -- `((int) (float))' -- so only an atom needs wrapping.
-(define (as-arg surface)
-  (if (pair? surface) surface (list surface)))
-
-;;; Splice a type into a surrounding word list, the way `(* const char)'
-;;; and `[* const char]' splice theirs. An array keeps its parentheses:
-;;; `(¤ ¤ char 4)' would read back as something else entirely.
-(define (as-words surface)
-  (cond ((not (pair? surface)) (list surface))
-        ((memq (car surface) '(¤ fn)) (list surface))
-        (else surface)))
-
-;;; ---------------------------------------------------------------
-;;; Constraints
-;;; ---------------------------------------------------------------
-
-;;; `(numeric a)' is already a type class, so it is written as one from
-;;; the start: one representation, one table, one entailment check. A
-;;; trait bound `(ord (struct circle))' is the same shape, discharged
-;;; the same way, and reported by the same procedure -- which is the
-;;; whole reason to build it this way while there is only one kind of
-;;; constraint to build.
-;;;
-;;; `default' is the type an unresolved constraint falls back to, the
-;;; way Haskell defaults `Num a' to Integer. `test' is how the built-in
-;;; classes say "every arithmetic type" without enumerating twenty
-;;; spellings as instances; a user trait has no test and lives entirely
-;;; in the instance table. `strict?' marks a class that must not be
-;;; guessed at: static dispatch needs a real instance, so `?' fails it.
-(define-record-type <type-class>
-  (%make-type-class name default test strict?)
-  type-class?
-  (name type-class-name)
-  (default type-class-default)
-  (test type-class-test)
-  (strict? type-class-strict?))
-
-(define +classes+ (make-hash-table))
-(define +instances+ (make-hash-table))
-
-(define (register-class! name default test strict?)
-  (hash-table-set! +classes+ name (%make-type-class name default test strict?)))
-
-(define (get-class name)
-  (or (hash-table-ref/default +classes+ name #f)
-      (error "no such type class" name)))
-
-;;; Instances key on the *resolved* type, so `(impl show for size-t)'
-;;; and `(impl show for unsigned long)' collide rather than quietly
-;;; coexisting as two instances of one C type.
-(define (instance-key type)
-  (unparse-type (underlying type)))
-
-(define (add-instance! class-name type)
-  (hash-table-set! +instances+ (cons class-name (instance-key type)) #t))
-
-(define (has-instance? class-name type)
-  (hash-table-exists? +instances+ (cons class-name (instance-key type))))
-
-;;; #t, #f, or 'unknown -- and the third answer is the important one.
-;;; A C name we never parsed a declaration for might well be numeric;
-;;; saying #f there would reject working programs, and saying #t would
-;;; invent knowledge. 'unknown means "do not constrain, do not
-;;; complain".
-(define (entails? class-name type)
-  (let ((cls (get-class class-name))
-        (t (underlying type)))
-    (cond
-     ((tvar? t) 'unknown)
-     ;; `?' is consistent with every type, but it entails nothing:
-     ;; there is no instance to select and no name to mangle.
-     ((unknown-type? t) (if (type-class-strict? cls) #f 'unknown))
-     ((has-instance? class-name t) #t)
-     ((type-class-test cls) => (lambda (test) (test t)))
-     (else #f))))
-
-(define +integer-words+ '(char short int long signed unsigned bool _Bool))
-(define +float-words+ '(float double))
-(define +known-words+ (append '(void) +integer-words+ +float-words+))
-
-;;; A prim built only out of words we recognise. Anything else is a
-;;; name from a header, and we have no opinion about it.
-(define (c-primitive? t)
-  (and (prim-type? t)
-       (every (lambda (word) (memq word +known-words+)) (prim-name t))))
-
-(define (void-type? t)
-  (and (prim-type? t) (equal? (prim-name t) '(void))))
-
-(define (arithmetic-type? t)
-  (cond ((and (agg-type? t) (eq? (agg-kind t) 'enum)) #t) ; an enum is an integer
-        ((not (prim-type? t)) #f)
-        ((not (c-primitive? t)) 'unknown)
-        ((void-type? t) #f)
-        (else #t)))
-
-(define (integral-type? t)
-  (cond ((and (agg-type? t) (eq? (agg-kind t) 'enum)) #t)
-        ((not (prim-type? t)) #f)
-        ((not (c-primitive? t)) 'unknown)
-        ((void-type? t) #f)
-        ((any (lambda (word) (memq word +float-words+)) (prim-name t)) #f)
-        (else #t)))
-
-(define (floating-type? t)
-  (cond ((not (prim-type? t)) #f)
-        ((not (c-primitive? t)) 'unknown)
-        (else (and (any (lambda (word) (memq word +float-words+)) (prim-name t))
-                   #t))))
-
-(define (scalar-type? t)
-  (cond ((ptr-type? t) #t)
-        ((array-type? t) #t)            ; decays to one
-        ((fn-type? t) #t)               ; likewise
-        (else (arithmetic-type? t))))
-
-;;; The built-ins. They are ordinary classes, registered the same way a
-;;; trait will be -- that is the point.
-(register-class! 'numeric  'int    arithmetic-type? #f)
-(register-class! 'integral 'int    integral-type?   #f)
-(register-class! 'floating 'double floating-type?   #f)
-(register-class! 'scalar   #f      scalar-type?     #f)
-
-;;; A constraint that survives to the end of a function is defaulted:
-;;; `(numeric a)' with nothing else known is an `int'. A *strict*
-;;; class has no default and no business guessing, so an unresolved one
-;;; is an error -- the rule is worth stating while there is only one
-;;; kind of constraint to state it about.
-(define (default-tvar! v form)
-  (let ((strict (find (lambda (c) (type-class-strict? (get-class c)))
-                      (tvar-classes v))))
-    (cond
-     (strict (sex-error form "unresolved constraint" (list strict (unparse-type v))))
-     ((find (lambda (c) (type-class-default (get-class c))) (tvar-classes v))
-      => (lambda (c)
-           (tvar-ref-set! v (parse-type (type-class-default (get-class c))))
-           #t))
-     (else #f))))
-
-;;; Default every variable still open in TYPE. Returns #t when none is
-;;; left unsolved, so a caller can tell "inferred" from "give up and
-;;; ask for the type in writing".
-(define (default-type-variables! type form)
-  (fold (lambda (v ok) (and (default-tvar! v form) ok))
-        #t
-        (free-tvars type)))
-
-(define (check-classes classes type form)
-  (for-each
-   (lambda (c)
-     (when (eq? #f (entails? c type))
-       (sex-error form "type does not satisfy a constraint"
-                  (list c (unparse-type type)))))
-   classes))
-
-;;; ---------------------------------------------------------------
-;;; Unification
-;;; ---------------------------------------------------------------
-
-;;; Consistency in the gradual-typing sense rather than equality: `?'
-;;; succeeds against anything and binds nothing, which is what keeps
-;;; the pass from rejecting every program that includes a C header.
-;;;
-;;; FORM is carried only so a failure can say where it was written.
-(define (unify t1 t2 form)
-  (let ((a (resolve t1))
-        (b (resolve t2)))
-    (cond
-     ((eq? a b) #t)
-     ((unknown-type? a) #t)
-     ((unknown-type? b) #t)
-     ;; Whichever side is free takes the binding: `(unify a r)' and
-     ;; `(unify r a)' both leave `a' bound to `r'. Two rigid and
-     ;; distinct is the mismatch `eq?' above let through.
-     ((and (tvar? a) (not (tvar-rigid? a))) (bind-tvar! a b form))
-     ((and (tvar? b) (not (tvar-rigid? b))) (bind-tvar! b a form))
-     ((or (tvar? a) (tvar? b)) (type-mismatch a b form))
-     ;; A typedef unifies as what it stands for. Its name survives in
-     ;; whichever side is printed later, since neither side is rebuilt.
-     ((alias-type? a) (unify (alias-expansion a) b form))
-     ((alias-type? b) (unify a (alias-expansion b) form))
-     ((and (prim-type? a) (prim-type? b))
-      (check-quals a b form)
-      (or (equal? (prim-name a) (prim-name b))
-          (type-mismatch a b form)))
-     ((and (ptr-type? a) (ptr-type? b))
-      (check-quals a b form)
-      (unify (ptr-target a) (ptr-target b) form))
-     ((and (array-type? a) (array-type? b))
-      ;; One of them may be `(¤ int)': an unwritten length constrains
-      ;; nothing, the way it does not in C either.
-      (when (and (array-size a) (array-size b)
-                 (not (= (array-size a) (array-size b))))
-        (type-mismatch a b form))
-      (unify (array-elt a) (array-elt b) form))
-     ((and (fn-type? a) (fn-type? b))
-      (unless (and (= (length (fn-args a)) (length (fn-args b)))
-                   (eq? (fn-variadic? a) (fn-variadic? b)))
-        (type-mismatch a b form))
-      (unify (fn-ret a) (fn-ret b) form)
-      (for-each (lambda (x y) (unify x y form)) (fn-args a) (fn-args b))
-      #t)
-     ((and (agg-type? a) (agg-type? b))
-      (check-quals a b form)
-      (or (and (eq? (agg-kind a) (agg-kind b))
-               (if (and (agg-name a) (agg-name b))
-                   (eq? (agg-name a) (agg-name b))
-                   (equal? (agg-spelling a) (agg-spelling b))))
-          (type-mismatch a b form)))
-     (else (type-mismatch a b form)))))
-
-(define (type-mismatch a b form)
-  (sex-error form "type mismatch: expected"
-             (unparse-type a) 'got (unparse-type b)))
-
-;;; Qualifiers are compared, and a mismatch is a warning rather than a
-;;; failure: C's const-correctness is not this pass's fight yet, and
-;;; making it one would reject programs that compile today.
-(define (check-quals a b form)
-  (let ((qa (type-quals a))
-        (qb (type-quals b)))
-    (unless (lset= eq? qa qb)
-      (sex-warning form "qualifiers differ between"
-                   (unparse-type a) "and" (unparse-type b)))))
-
-(define (bind-tvar! v t form)
-  (cond
-   ;; Without recursive types this cannot trigger. It is four lines,
-   ;; and the alternative to having it is a hang.
-   ((occurs? v t) (sex-error form "recursive type" (unparse-type v)))
-   ;; A rigid variable is a type *parameter*: inside a generic body it
-   ;; stands for one specific unknown type and must not be solved.
-   ((tvar-rigid? v) (type-mismatch v t form))
-   (else
-    (when (tvar? t)
-      (tvar-classes-set! t (lset-union eq? (tvar-classes t) (tvar-classes v))))
-    (tvar-ref-set! v t)
-    (unless (tvar? t)
-      (check-classes (tvar-classes v) t form))
-    #t)))
-
-(define (occurs? v type)
-  (let ((t (resolve type)))
-    (cond ((eq? v t) #t)
-          ((ptr-type? t) (occurs? v (ptr-target t)))
-          ((array-type? t) (occurs? v (array-elt t)))
-          ((alias-type? t) (occurs? v (alias-expansion t)))
-          ((fn-type? t) (or (occurs? v (fn-ret t))
-                            (any (lambda (a) (occurs? v a)) (fn-args t))))
-          (else #f))))
-
-;;; ---------------------------------------------------------------
-;;; Type schemes
-;;; ---------------------------------------------------------------
-
-;;; Nothing generalizes yet -- every `fn' in Sex carries a written
-;;; signature and there is no polymorphism to abstract over. These are
-;;; here because they are ten lines on top of unification and because
-;;; they are exactly what a `fn' with type parameters needs, and
-;;; because a scheme without a constraint list is the wrong shape for
-;;; every bounded generic. `(forall vars constraints type)' it is,
-;;; from the start.
-(define-record-type <scheme>
-  (make-scheme vars constraints type)
-  scheme?
-  (vars scheme-vars)
-  (constraints scheme-constraints)
-  (type scheme-type))
-
-;;; Quantify over everything free in TYPE that is not also free in the
-;;; environment, carrying each variable's class constraints along as
-;;; the scheme's context.
-(define (generalize type env-tvars)
-  (let ((vars (lset-difference eq? (free-tvars type) env-tvars)))
-    (make-scheme vars
-                 (append-map (lambda (v)
-                               (map (lambda (c) (cons c v)) (tvar-classes v)))
-                             vars)
-                 type)))
-
-(define (instantiate scheme)
-  (let ((subst (map (lambda (v) (cons v (fresh-tvar (tvar-classes v))))
-                    (scheme-vars scheme))))
-    (substitute (scheme-type scheme) subst)))
-
-;;; Structural copy with the variables in SUBST replaced. Copying is
-;;; how a generic body must be handled anyway -- `form-type' is keyed
-;;; by cons cell, one form one type, so an instantiation gets fresh
-;;; cells rather than a second type for the same cell.
-(define (substitute type subst)
-  (let ((t (resolve type)))
-    (cond
-     ((tvar? t) (let ((hit (assq t subst))) (if hit (cdr hit) t)))
-     ((ptr-type? t) (make-ptr (substitute (ptr-target t) subst) (ptr-quals t)))
-     ((array-type? t) (make-array-type (substitute (array-elt t) subst)
-                                       (array-size t)))
-     ((alias-type? t) (make-alias (alias-name t)
-                                  (substitute (alias-expansion t) subst)
-                                  (alias-quals t)))
-     ((fn-type? t) (make-fn-type (substitute (fn-ret t) subst)
-                                 (map (lambda (a) (substitute a subst))
-                                      (fn-args t))
-                                 (fn-variadic? t)))
-     (else t))))

main.scm

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

reader.module.scm

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

reader.scm

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

semen.module.scm

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

sex-macros.module.scm

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

sex-macros.scm

@@ -1,55 +0,0 @@
-(import
-  scheme
-  (only fmt fmt)
-  (chicken base)
-  (chicken plist)
-  (chicken string))
-
-(define (cat-syms s-1 s-2)
-  (fmt #f s-1 s-2))
-
-(define (cat sym-1 sym-2)
-  (string->symbol (cat-syms sym-1 sym-2)))
-
-;;; The reader keeps `;' comments as (comment "...") forms so they can
-;;; be re-emitted into the generated C. In a macro body a comment
-;;; should be a call which does nothing, hence this one
-(define (comment . _)
-  (void))
-
-(define (register-macro name arglist body)
-  (put! name 'sex-macro
-        `(lambda ,arglist
-           ;; A macro body is ordinary Scheme, evaluated at compile
-           ;; time. It gets `cat' for building names, and read access to
-           ;; the type database
-           (import scheme
-                   (scheme base)
-                   ;; a type is a list, so a macro reading one wants
-                   ;; `(third type)' rather than `(caddr type)'
-                   (only srfi-1 first second third fourth fifth last)
-                   (only sex-macros cat comment)
-                   (only types get-type-info get-tag-info get-fields
-                         get-underlying-type type-match type-pattern-matches?
-                         map-fields
-                         get-name-type get-return-type type-of))
-           ,@body)))
-
-(define (get-macro name)
-  (eval (get name 'sex-macro)))
-
-(define (macro? form)
-  (and (list? form)
-       (symbol? (car form))
-       (get (car form) 'sex-macro)))
-
-(define (apply-macro form)
-  (assert (macro? form)
-          (fmt #f (car form) " is not a macro"))
-  (apply (get-macro (car form))
-         (cdr form)))
-
-(define (defmacro form)
-  (let ((arglist (car form))
-        (body (cdr form)))
-    (register-macro (car arglist) (cdr arglist) body)))

sex-mode.el

@@ -33,13 +33,12 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
                                  "chicken-import"
                                  "chicken-load"
                                  "define"
-                                 "defmacro"
                                  "extern"
-                                 "import"
                                  "include"
                                  "fn"
                                  "pub"
                                  "struct"
+                                 "template"
                                  "var"
                                  "union")
                                'word)
@@ -51,9 +50,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
      ;; Keywords
      (list (concat "("
                    (regexp-opt '(
-                                 "do"
                                  "case"
-                                 "default"
                                  "do"
                                  "if"
                                  "for"
@@ -79,14 +76,9 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
   (setq-local prettify-symbols-alist lisp-prettify-symbols-alist))
 
 (put 'fn 'lisp-indent-function 'defun)
-(put 'pub 'lisp-indent-function 'defun)
-(put 'defmacro 'lisp-indent-function 'defun)
+(put 'template 'lisp-indent-function 'defun)
 (put 'struct 'lisp-indent-function 'defun)
-(put 'union 'lisp-indent-function 'defun)
 (put 'var 'lisp-indent-function 0)
-(put 'import 'lisp-indent-function 1)
-(put 'switch 'lisp-indent-function 1)
-(put 'case 'lisp-indent-function 1)
 
 ;;;###autoload
 (define-derived-mode sex-mode lisp-data-mode "Sex"

sex-modules.module.scm

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

sex-modules.scm

@@ -1,112 +0,0 @@
-(import
-  scheme
-  brev-separate
-  (chicken base)
-  (chicken file)
-  (chicken load)
-  (chicken pathname)
-  (chicken process-context)
-  (chicken string)
-  fmt
-  matchable
-  reader
-  srfi-1
-  utils)
-
-(define +persistent-module-paths+ (list))
-
-;;; for guarding against multiple imports (sort of mandatory #pragma
-;;; once)
-(define +imported-modules+ (list))
-
-(define (get-modules-public-forms module-list)
-  ;; Module list is a list of symbols
-  ;; How Sex handles modules:
-  ;; For each module in a list, construct path, find module by path in
-  ;; module path directories, extract public definitions from the
-  ;; module, paste them in current one in emulation of C include
-  ;; directives.
-  (fold-right append (list)
-              (map (fn (import-module (symbol->string x)))
-                   module-list)))
-
-(define (import-module name)
-  (let ((module-path (locate-module name)))
-    (assert module-path (fmt #f "Failed to find module " name " in "
-                             (get-module-paths)))
-    (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)
-        +persistent-module-paths+))
-
-(define (locate-module name)
-  ;; Module locations: relative to file being compiled, or in what was
-  ;; in SEX_MODULE_PATH env var at the start of the process (see
-  ;; load-persistent-module-paths function)
-
-  (let ((search-paths (get-module-paths)))
-    (let loop ((paths search-paths))
-      (if (null? paths)
-          #f
-          (or (module-exists? name (car paths))
-              (loop (cdr paths)))))))
-
-(define (module-exists? name module-dir)
-  ;; returns absolute path to module, if it exists
-  (and (directory-exists? module-dir)
-       (let ((module-path (make-absolute-pathname module-dir name "sex")))
-         (and (file-exists? module-path)
-              (file-readable? module-path)
-              module-path))))
-
-(define (read-public-interface module-path)
-  ;; pub fns are reduced to prototypes, other pub forms are just pasted
-  (let ((raw-forms (read-from-file module-path)))
-    (fold
-     process-public-interface-form
-     (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)
-  (match form
-    ;; Reduced to a prototype, still `pub', so the importer declares it
-    ;; with external linkage
-    (('pub 'fn . _)
-     (cons (copy-form-source! form (public-fn-interface form)) acc))
-    (('pub 'var . _)
-     (match-let ((('pub 'var name type . _) (strip-header-comments form 4)))
-       (cons (copy-form-source! form `(extern var ,name ,type)) acc)))
-    (('pub (or 'define 'defmacro 'enum 'import 'include 'struct 'typedef 'union) . _)
-     (cons (copy-form-source! form (cdr form)) acc))
-    (('pub . _)
-     (sex-error form "pub must be followed by a definition" form))
-    (_ acc)))
-
-(define (load-persistent-module-paths)
-  (let ((sex-module-path-env-var
-         (get-env-var "SEX_MODULE_PATH")))
-    (when sex-module-path-env-var
-      (set! +persistent-module-paths+
-        (map (lambda (p)
-               (make-absolute-pathname p #f #f))
-             (string-split sex-module-path-env-var ":"))))))

sexc.module.scm

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

sexc.scm

@@ -1,81 +1,221 @@
-(import scheme
-        (scheme base)                   ; call/cc
-        brev-separate
-        (chicken base)
-        (chicken condition)             ; handle-exceptions
-        (chicken file)
+(declare (unit sexc)
+         (uses templates))
+
+(import brev-separate
+        (chicken pathname)
         (chicken plist)
         (chicken pretty-print)
-        (chicken process)
         (chicken process-context)
-        (chicken port)
-        (chicken string)                ; string-split
+        (chicken string)
         fmt
-        fmt-c-writer
+        fmt-c
         getopt-long
-        sex-macros
-        sex-modules
-        reader
-        semen
+        regex
         srfi-1                          ; list routines
-        utils)
+        tree)
+
+(define +debug+ #f)
+
+(define (unkebabify sym)
+  (case sym
+    ((-) sym)
+    ((--) sym)
+    ((->) sym)
+    ((-=) sym)
+    (else
+     (string->symbol
+      (string-substitute "-(?!>)" "_"
+                         (symbol->string sym) #t)))))
+
+(define (atom-to-fmt-c atom)
+  (case atom
+    ((fn) '%fun)
+    ((prototype) '%prototype)
+    ((var) '%var)
+    ((begin) '%begin)
+    ((define) '%define)
+    ((pointer) '%pointer)
+    ((array) '%array)
+    ((@) 'vector-ref)
+    ((include) '%include)
+    ((cast) '%cast)
+    (else
+     (if (symbol? atom)
+         (unkebabify atom)
+         atom))))
+
+(define (tree-finder symbol)
+  (lambda (node)
+    (or (and (tree? node)
+             (eq? (car node) symbol))
+        #f)))
+
+(define (make-field-access form)
+  (assert (= 2 (length form)) "Wrong field access format")
+  (unkebabify
+   (string->symbol
+    (fmt #f (cadr form) (car form)))))
+
+(define (walk-generic form acc)
+  (cond
+   ((null? form) (cons '() acc))
+
+   ;; vector, e.g. {}-initializer
+   ((vector? form)
+    (cons
+     (list->vector
+      (car (walk-sex-tree (vector->list form) (list))))
+     acc))
+
+   ;; atom (hopefully)
+   ((not (list? form)) (cons (atom-to-fmt-c form) acc))
+
+   ;; special case - replace unquote with its expansion
+   ((eq? (car form) 'unquote)
+    (fold
+     cons
+     acc
+     (car                               ; bc walk-sex-tree always
+                                        ; wraps its result
+      (walk-sex-tree (eval (cadr form)) (list)))))
+
+   ;; another special case - field access
+   ((and (symbol? (car form))
+         (char=? #\. (string-ref (symbol->string (car form)) 0)))
+    (cons (make-field-access form) acc))
+
+   ;; another special case - template
+   ((template? form)
+    (append (fold
+             walk-generic
+             (list)
+             (eval form))
+            acc))
+
+   ;; toplevel, or a start of a regular list form
+   (else
+    (let ((new-acc (list)))
+      (cons (reverse
+             (fold
+              walk-generic
+              new-acc
+              form))
+            acc)))))
+
+(define (normalize-fn-form form)
+  ;; (fn ret-type name arglist body) -> normal function
+  ;; (fn ret-type name arglist) -> prototype
+  (if (>= (length form) 5)
+      form
+      (cons 'prototype (cdr form))))
+
+(define (walk-function form static acc)
+  (if static
+      (append (walk-generic (list 'static (normalize-fn-form form))
+                            (list))
+              acc)
+      (append (walk-generic (normalize-fn-form (cdr form))
+                            (list))
+              acc)))
+
+(define (walk-struct form acc)
+  (let ((name (unkebabify (cadr form))))
+    (append (walk-generic form (list))
+          (cons `(typedef struct ,name ,name) acc))))
+
+(define (walk-extern form acc)
+  (case (cadr form)
+    ((fn)
+     (append
+      (list (cons 'extern (walk-function form #f (list))))
+      acc))
+    ((var)
+     (append
+      (list (cons 'extern (walk-generic (cdr form) (list))))
+      acc))
+    (else (error "Extern what?"))))
+
+(define (walk-public form acc)
+  (case (cadr form)
+    ((fn)
+     (walk-function form #f acc))
+    ((var)
+     (append (walk-generic (list 'static (cdr form)) (list)) acc))
+    (else (error "Pub what?"))))
+
+(define (template? form)
+  (and (list? form)
+       (symbol? (car form))
+       (get (car form) 'sex-template)))
+
+(define (walk-sex-tree form acc)
+  (if (list? form)
+      (if (template? form)
+          (fold (fn (walk-sex-tree x y))
+                acc
+                (eval form))
+          (case (car form)
+            ((fn) (walk-function form #t acc))
+            ((extern) (walk-extern form acc))
+            ((pub) (walk-public form acc))
+            ((struct union) (walk-struct form acc))
+            ((unquote) (fold (fn (walk-sex-tree x y))
+                             acc
+                             (eval (cadr form))))
+            (else (append (walk-generic form (list)) acc))))
+      ;; only for unquote support
+      (list (list (atom-to-fmt-c form)))))
+
+(define (process-form form acc)
+  (case (car form)
+    ((chicken-define) (eval (cons 'define (cdr form))) acc)
+    ((template) (eval form) acc)
+    ((chicken-load)
+     (load (cadr form)) acc)
+    ((chicken-import)
+     (eval (cons 'import (cdr form))) acc)
+    (else
+     (walk-sex-tree form acc))))
+
+
+(define (process-raw-forms raw-forms acc)
+  (if (null? raw-forms)
+      (reverse acc)
+      (process-raw-forms (cdr raw-forms)
+                         (process-form (car raw-forms) acc))))
+
+(define (read-forms acc)
+  (let ((r (read)))
+    (if (eof-object? r) (reverse acc)
+        (read-forms (cons r acc)))))
+
+(define (emit-c forms)
+  (for-each (lambda (form)
+              (fmt #t (c-expr form))
+              (fmt #t "\n"))
+            forms))
 
 ;;; Main function facilities
 
 (define opts-grammar
-  (let ((padding 26))
-    `((c-compiler ,(fmt #f "Select C compiler. Defaults to value of SEX_CC" nl
-                        (pad padding) "environment variable, or if it is empty, to cc")
-                  (required #f)
-                  (value #t))
-      (compile-object "Compile object file instead of executable program"
-                      (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)
-              (single-char #\C))
-      (public-interface "Get module's public interface"
-                        (required #f)
-                        (value #f))
-      (help "Show this help"
+  `((output "Write output to file"
             (required #f)
-            (value #f)
-            (single-char #\h))
-      (macro-expand "Emit macro-expanded semantically processed Sex code"
-                    (required #f)
-                    (value #f)
-                    (single-char #\m))
-      (output ,(fmt #f "Write output to file. Default file name is a.out." nl
-                    (pad padding) "If -E or -m options are provided, defaults to stdout")
-              (required #f)
-              (value #t)
-              (single-char #\o))
-      (line-directives
-       ,(fmt #f "How much #line information to emit: statement (default)," nl
-             (pad padding) "toplevel, or none. `statement' is what makes a debugger" nl
-             (pad padding) "land on the right source line; `none' is for reading -C" nl
-             (pad padding) "output by eye")
-       (required #f)
-       (value #t)))))
+            (value #t)
+            (single-char #\o))
+    (help "Show this help"
+          (required #f)
+          (value #f)
+          (single-char #\h))
+    (macro-expand "Emit macro-expanded Sex code instead of C"
+                  (required #f)
+                  (value #f)
+                  (single-char #\m))))
 
 (define (print-help)
-  (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
-  (fmt #t "Options:\n")
-  (fmt #t (usage opts-grammar))
-  (fmt #t ""))
+  (fmt #t "Usage: sexc [OPTIONS] [FILE]\n")
+  (fmt #t "Options: -o, --output <file>        Write output to file. If omitted, write to stdout\n")
+  (fmt #t "         -h, --help                 Show this help\n")
+  (fmt #t "         -m, --macro-expand         Emit macro-expanded Sex code instead of C\n"))
 
 (define (help-arg? args)
   (assoc 'help args))
@@ -85,163 +225,44 @@
     (if arg (cdr arg)
         default)))
 
-;;; Everything before the first `--' is ours to parse, everything after
-;;; is handed to the C compiler verbatim
-
-(define (separator? a)
-  (string=? a "--"))
-
-(define (args-before-separator argv)
-  (take-while (complement separator?) argv))
-
-(define (args-after-separator argv)
-  (let ((tail (drop-while (complement separator?) argv)))
-    (if (null? tail)
-        (list)
-        (cdr tail))))
-
-(define (get-rest-args args)
-  (cdr (assoc '@ args)))
-
-(define (line-directives-arg args)
-  (let ((v (get-arg args 'line-directives "statement")))
-    (cond ((equal? v "statement") 'statement)
-          ((equal? v "toplevel") 'toplevel)
-          ((equal? v "none") 'none)
-          (else (error "--line-directives must be statement, toplevel or none, got" v)))))
-
-
-
-;;; --features may be given more than once, and each may name several.
-;;; Collect all of them
-(define (cli-features args)
-  (append-map (lambda (entry)
-                (map string->symbol (string-split (cdr entry) ",")))
-              (filter (lambda (entry) (eq? (car entry) 'features)) args)))
-
 (define (get-input-file args)
-  (let ((rest-args (get-rest-args args)))
-    (if (null? rest-args)
+  (let ((rest-args (assoc '@ args)))
+    (if (= 1 (length rest-args))
         'stdin
-        (car rest-args))))
+        (cadr rest-args))))
 
-(define (write-to-file-or-stdout output what)
-  (if (eq? output 'default)
-      (what)
-      (with-output-to-file output
-        (fn (what)))))
+(define (read-from-file file)
+  (with-input-from-file (pathname-strip-directory file)
+    (fn (read-forms (list)))))
 
-(define (emit-c-or-sex sex-forms output args)
-  (write-to-file-or-stdout output
-                           (lambda ()
-                             (if (get-arg args 'macro-expand #f)
-                                 (map pp sex-forms)
-                                 (emit-c sex-forms)))))
-
-(define (compile-to-file sex-forms output args 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))
-        ;; The generated C goes to a temporary .c file rather than the
-        ;; compiler's stdin. It is removed however we leave -- emit-c
-        ;; can throw, and used to leave the file behind when it did
-        (c-file (create-temporary-file "c")))
-    ;; An unhandled error ends the process without unwinding, so the
-    ;; cleanup cannot be left to dynamic-wind
-    (handle-exceptions exn
-        (begin (delete-file* c-file) (abort exn))
-      (with-output-to-file c-file
-        (lambda () (emit-c sex-forms)))
-      (let ((proc (process compiler (append (list "-o" out-file)
-                                            (if (get-arg args 'compile-object #f)
-                                                (list "-c")
-                                                (list))
-                                            (list c-file)
-                                            cc-args))))
-        (call-with-values (lambda () (process-wait proc))
-          (lambda (pid normal-exit? status)
-            (delete-file* c-file)
-            (if normal-exit? status 1)))))))
-
-(define (semantic-process-forms raw-forms input-source)
-  (if (eq? input-source 'stdin)
-      (semen-process raw-forms)
-      (with-directory input-source
-                      (semen-process raw-forms))))
-
-(define prelude
-  (append
-   '((include inttypes.h)
-     (include stdbool.h)
-     (include stddef.h)        ; max_align_t, for closure environments
-     (typedef u8 uint8-t)
-     (typedef i8 int8-t)
-     (typedef u16 uint16-t)
-     (typedef i16 int16-t)
-     (typedef u32 uint32-t)
-     (typedef i32 int32-t)
-     (typedef u64 uint64-t)
-     (typedef i64 int64-t))
-
-   ;; The closure environment is the part of the ABI, so include it in
-   ;; every module
-   (list (closure-env-declaration))))
+(define (set-working-directory file)
+  (change-directory
+   (normalize-pathname
+    (make-absolute-pathname
+     (current-directory)
+     (pathname-directory file)))))
 
 (define (main)
-  (let* ((argv (command-line-arguments))
-         (raw-args (args-before-separator argv))
-         (cc-args (args-after-separator argv))
+  (let* ((raw-args (command-line-arguments))
+         (current-dir (current-directory))
          (args (getopt-long raw-args
                             opts-grammar))
-         (output (get-arg args 'output 'default))
+         (output (get-arg args 'output 'stdout))
          (help (help-arg? args))
-
-         (input (get-input-file args))
-         (current-dir (current-directory)))
-    (call/cc
-     (lambda (return)
-       (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")
-
-         (write-to-file-or-stdout
-          output
-          (fn
-           (map pp (reverse
-                    (read-public-interface input)))))
-         (return #f))
-       (load-persistent-module-paths)
-
-       ;; The file name in a #line directive now comes from the form's
-       ;; own recorded location, so imported modules report themselves
-       ;; rather than the unit that imported them
-       (sex-line-directives (line-directives-arg args))
-       (when (and (get-arg args 'emit-c #f)
-                  (not (get-arg args 'line-directives #f)))
-         (sex-line-directives 'none))
-
-       (let* ((raw-forms (append prelude (read-raw-forms input)))
-              (sex-forms (semantic-process-forms raw-forms input)))
-         (if (or (get-arg args 'macro-expand #f)
-                 (get-arg args 'emit-c #f))
-             ;; Emit processed and macro-expanded sex code, or emit C code
-             (emit-c-or-sex sex-forms output args)
-             ;; Compile file! The C compiler's status is ours too
-             (let ((status (compile-to-file sex-forms output args cc-args)))
-               (unless (zero? status)
-                 (exit status)))))))))
+         (input (get-input-file args)))
+    (if help (print-help)
+        (let* ((raw-forms
+                (if (eq? input 'stdin)
+                    (read-forms (list))
+                    (begin
+                      (set-working-directory input)
+                      (read-from-file input))))
+               (sex-forms (process-raw-forms raw-forms (list))))
+          (change-directory current-dir)
+          (if (get-arg args 'macro-expand #f)
+              (map pp sex-forms)
+              (if (not (eq? output 'stdout))
+                  (with-output-to-file output
+                    (lambda ()
+                      (emit-c sex-forms)))
+                  (emit-c sex-forms)))))))

templates.scm

@@ -0,0 +1,66 @@
+(declare (unit templates))
+
+(import
+  (chicken plist)
+  brev-separate
+  fmt
+  regex
+  srfi-1                                ; list routines
+  tree)
+
+(define (register-template name)
+  (put! name 'sex-template #t))
+
+(define-syntax template
+  (syntax-rules ()
+    ((template (name . args) . body)
+     (begin
+       (register-template 'name)
+       (define-syntax name
+         (syntax-rules ()
+           ((name . applied-args)
+            (let* ((subst-alist (map cons 'args 'applied-args))
+                   (replaced-body (apply-substitution `body subst-alist)))
+              replaced-body))))))))
+
+(define (apply-symbol-substitution sym subst-alist)
+  ;; All non-symbol substitutions will be filtered.
+  ;; E.g. if the subst-alist is ((T + 1 2) (U . w) (W . e)),
+  ;; only ((U . w) (W . e)) will be applied to symbols.
+  (let ((str (symbol->string sym))
+        (subst-map (map (fn
+                         (if (symbol? (car x))
+                             (cons
+                              (fmt #f "([^\\-]?)"
+                                   (regexp-escape (symbol->string (car x)))
+                                   "([\\-$]?)")
+                              (fmt #f "\\1" (symbol->string (cdr x)) "\\2"))
+                             x))
+                        (filter (fn (symbol? (cdr x))) subst-alist))))
+    (string->symbol
+     (string-substitute* str subst-map))))
+
+(define (maybe-replace-symbol sym subst-alist)
+  (call/cc
+   (lambda (return)
+     (for-each (fn (when (eq? (car x) sym)
+                     (return (cdr x))))
+               subst-alist)
+     (return sym))))
+
+(define (apply-substitution target subst-alist)
+  ;; Subsitute free symbols and -/$/^ separated parts
+  ;; of symbols with provided forms.
+  ;; E.g. with substitution (T int):
+  ;; list-T -> list-int ; by apply-symbol-substitution
+  ;; (var T data) -> (var int data) ; by maybe-replace-symbol
+  ;; see respective functions for further details.
+  (tree-map
+   (fn
+    (if (symbol? x)
+        (let ((st (maybe-replace-symbol x subst-alist)))
+          (if (eq? st x)
+              (apply-symbol-substitution x subst-alist)
+              st))
+        x))
+   target))

tests/Makefile

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

tests/args.scm

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

tests/basic.scm

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

tests/codegen.scm

@@ -1,611 +0,0 @@
-;;; Codegen details that are easy to get subtly wrong, and that the
-;;; walk-* unit tests cannot see: they check the intermediate form we
-;;; hand to fmt-c, not the C that fmt-c renders from it.
-;;;
-;;; Both cases below were found by writing an OpenGL example, not by
-;;; the existing suite, because both need an operand shape that no
-;;; earlier test program happened to use.
-
-(import (chicken condition)
-        (chicken port)
-        (chicken string)
-        srfi-13
-        fmt-c-writer
-        reader
-        semen
-        utils)
-
-(define (sex->c source)
-  "Compile SOURCE, a string of Sex, and return the generated C."
-  (let ((forms (with-input-from-string source
-                 (lambda ()
-                   (parameterize ((current-source-file "codegen.sex"))
-                     (parse-all (current-input-port)))))))
-    (with-output-to-string
-      (lambda ()
-        (parameterize ((sex-line-directives 'none))
-          (emit-c (semen-process forms)))))))
-
-(define (emits? source fragment)
-  (and (string-contains (sex->c source) fragment) #t))
-
-(define (error-message source)
-  "Compile SOURCE and return the error text as the user sees it --
-message plus arguments, the way CHICKEN prints it -- or #f if SOURCE
-compiles."
-  (handle-exceptions e
-      (with-output-to-string
-        (lambda ()
-          (display ((condition-property-accessor 'exn 'message) e))
-          (for-each (lambda (a) (display " ") (write a))
-                    ((condition-property-accessor 'exn 'arguments) e))))
-    (begin (sex->c source) #f)))
-
-(define (reports? source fragment)
-  (let ((m (error-message source)))
-    (and m (string-contains m fragment) #t)))
-
-(define (in-fn body)
-  (string-append "(fn f ((a int) (b int)) void " body ")"))
-
-(test-group "codegen"
-
-  ;; c-switch handed its scrutinee straight to `cat', which only works
-  ;; when it is an atom. Anything else was displayed as a raw
-  ;; s-expression: `switch ((%. e type))'.
-  (test-group "switch scrutinee"
-    (test-assert "member access"
-      (emits? "(struct s ((type int))) (fn f ((e (struct s))) void (switch (. e type) (case 1 (g))))"
-              "switch (e.type)"))
-    (test-assert "call"
-      (emits? (in-fn "(switch (g a) (case 1 (h)))")
-              "switch (g(a))"))
-    (test-assert "arithmetic"
-      (emits? (in-fn "(switch (+ a b) (case 1 (h)))")
-              "switch (a + b)")))
-
-  ;; A cast binds tighter than every binary operator, so an operand
-  ;; that is itself a binary expression has to be parenthesised --
-  ;; otherwise the cast silently applies to the first operand only.
-  (test-group "cast precedence"
-    (test-assert "binary operand is parenthesised"
-      (emits? (in-fn "(var p (* void) (cast (* 2 (sizeof int)) (* void)))")
-              "(void *)(2 * sizeof(int))"))
-    (test-assert "subtraction operand is parenthesised"
-      (emits? (in-fn "(var f float (cast (- a b) float))")
-              "(float)(a - b)"))
-    ;; ...but exactly once. The operand used to parenthesise itself
-    ;; again inside the parens the cast had just added.
-    (test-assert "and not parenthesised twice"
-      (not (emits? (in-fn "(var f float (cast (- a b) float))")
-                   "(float)((a - b))")))
-    ;; Unary operands are already unary-expressions and must be left
-    ;; alone, or every existing cast in the tree gains noise.
-    (test-assert "identifier is left bare"
-      (emits? (in-fn "(var f float (cast a float))")
-              "(float)a"))
-    (test-assert "address-of is left bare"
-      (emits? (in-fn "(var p (* int) (cast (& a) (* int)))")
-              "(int *)&a"))
-    (test-assert "sizeof is left bare"
-      (emits? (in-fn "(var n int (cast (sizeof int) int))")
-              "(int)sizeof(int)")))
-
-  ;; A comment among a call's arguments used to become an argument,
-  ;; and c-apply put a comma on each side of it -- which does not
-  ;; compile. It is dropped, as in any other expression context.
-  (test-group "comments among arguments"
-    (test-assert "no stray comma"
-      (not (emits? (in-fn "(g 1 ;; c\n 2)") "*/,")))
-    (test-assert "the arguments survive"
-      (emits? (in-fn "(g 1 ;; c\n 2)") "g(1, 2)")))
-
-  ;; The reader leaves the `;'s that introduced each line, and a run of
-  ;; comment lines arrives as one form per line.
-  (test-group "comment rendering"
-    (test-assert "the markers are stripped"
-      (emits? "(fn f () void ;;; Foo\n (g))" "/* Foo */"))
-    (test-assert "so none survive into the C"
-      (not (emits? "(fn f () void ;;; Foo\n (g))" ";;")))
-    (test-assert "consecutive lines are packed into one comment"
-      (emits? "(fn f () void\n ;; first\n ;; second\n (g))"
-              "/* first\n second */"))
-    ;; Packing compares locations rather than just looking for adjacent
-    ;; comment forms, so a blank line still separates them.
-    (test-assert "a blank line keeps them apart"
-      (emits? "(fn f () void\n ;; first\n\n ;; second\n (g))" "/* first */")))
-
-  ;; A `;' comment is a form, so one written inside a construct with
-  ;; positional slots used to land in a slot and shift everything after
-  ;; it -- silently. In an `if' the comment became the then-arm and the
-  ;; then-arm became an `else if' condition, and it still compiled.
-  ;; Comments are now taken out of the slots and emitted just before the
-  ;; statement; comments in a body stay where they were written.
-  (test-group "comments in positional slots"
-    (test-assert "an if arm is not shifted"
-      (not (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "else if")))
-    (test-assert "and both arms survive"
-      (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "g(1)"))
-    (test-assert "the comment survives too"
-      (emits? (in-fn "(if 1 ;; kept here\n (g 1) (g 2))") "kept here"))
-    (test-assert "a for header is not shifted"
-      (emits? (in-fn "(for ;; c\n (var i int 0) (< i 2) (++ i) (g i))")
-              "for (int i = 0; i < 2; ++i)"))
-    (test-assert "a while condition is not shifted"
-      (emits? (in-fn "(while ;; c\n (< a b) (g 1))") "while (a < b)"))
-    (test-assert "a var is not shifted"
-      (emits? (in-fn "(var ;; c\n x int 5)") "int x = 5"))
-    (test-assert "a cast is not shifted"
-      (emits? (in-fn "(var y int (cast ;; c\n a int))") "(int)a"))
-    ;; Bodies are a statement sequence, so comments there stay put.
-    (test-assert "a comment in a body stays in the body"
-      (emits? (in-fn "(while (< a b) ;; inside\n (g 1))")
-              "while (a < b) {")))
-
-  (test-group "pub enum"
-    (test-assert "is emitted"
-      (emits? "(pub enum color (red green blue))" "enum color"))
-    (test-assert "with its values"
-      (emits? "(pub enum color (red green blue))" "red"))
-    (test-assert "and a non-pub enum still is too"
-      (emits? "(enum color (red green blue))" "enum color"))
-    ;; Naming an enum as a type, rather than defining it, had no
-    ;; walk-enum clause and died with `(match) no matching pattern'
-    (test-assert "and it can then be used as a type"
-      (emits? "(enum color (red green blue)) (fn f () void (var m (enum color) red))"
-              "enum color m = red"))
-    (test-assert "a malformed enum is rejected with its location"
-      (reports? "(enum)" "codegen.sex:1:"))
-    ;; c-type handed the declarator's name to c-enum as the enum tag,
-    ;; so this emitted `enum m { up, down }' with no variable at all
-    (test-assert "an anonymous enum keeps the variable"
-      (emits? "(fn f () void (var e (enum (up down)) up))" "} e = up"))
-    (test-assert "and a named definition keeps both"
-      (emits? "(fn f () void (var n (enum named (a b)) a))" "enum named{")))
-
-  ;; `|', `||' and `|=' read as ordinary symbols -- our own reader has
-  ;; no |symbol| syntax for them to collide with -- but fmt-c cannot
-  ;; dispatch on a symbol whose name it cannot write in Scheme source,
-  ;; so they used to fall through to the function-call path and emit
-  ;; `|\||(a, b)'. The writer renames them to heads fmt-c spells with
-  ;; a string.
-  (test-group "bitwise and logical operators"
-    (test-assert "bit-or"
-      (emits? (in-fn "(var x int (| a b))") "int x = a | b"))
-    (test-assert "logical or"
-      (emits? (in-fn "(var x int (|| a b))") "int x = a || b"))
-    (test-assert "or-assign"
-      (emits? (in-fn "(|= a b)") "a |= b"))
-    (test-assert "bit-and"
-      (emits? (in-fn "(var x int (& a b))") "int x = a & b"))
-    (test-assert "logical and"
-      (emits? (in-fn "(var x int (&& a b))") "int x = a && b"))
-
-    ;; Precedence too: the operator reaches fmt-c as a string it looks
-    ;; up, not as a symbol in its table
-    (test-assert "parenthesised where C needs it"
-      (emits? (in-fn "(var x int (& (| a b) a))") "(a | b) & a"))
-    (test-assert "and left alone where it does not"
-      (emits? (in-fn "(var x int (| a (& a b)))") "int x = a | a & b"))
-
-    ;; The spelling from before they could be written directly
-    (test-assert "c-or is still accepted"
-      (emits? (in-fn "(var x int (c-or a b))") "a || b"))
-    (test-assert "c-bit-or is still accepted"
-      (emits? (in-fn "(var x int (c-bit-or a b))") "a | b")))
-
-  ;; A `;' comment is a form. In a macro body `comment' is a no-op
-  ;; that swallows the comment itself. Inside a quasiquoted payload
-  ;; the same form is data, never evaluated, and reaches the writer
-  ;; intact
-  (test-group "comments in macros"
-    (test-assert "a comment in the payload reaches the C"
-      (emits? "(defmacro (m-kept) `(fn f () void\n ;; this survives\n (g)))\n(m-kept)"
-              "this survives"))
-    (test-assert "a comment about the macro does not"
-      (not (emits? "(defmacro (m-dropped)\n ;; this vanishes\n `(fn f () void (g)))\n(m-dropped)"
-                   "this vanishes")))
-    (test-assert "and the macro still expands"
-      (emits? "(defmacro (m-both)\n ;; about the macro\n `(fn f () void (g)))\n(m-both)"
-              "void f (void)")))
-
-  ;; Diagnostics name also the place. Every form carries a (file
-  ;; . line), so an error can cite it
-  (test-group "errors cite the source location"
-    (test-assert "unknown toplevel form"
-      (reports? "(include stdio.h)\n(wat 1 2)" "codegen.sex:2: unknown top level form"))
-    (test-assert "the offending form is shown too"
-      (reports? "(include stdio.h)\n(wat 1 2)" "(wat 1 2)"))
-    (test-assert "pub with nothing to define"
-      (reports? "(pub 1)" "codegen.sex:1:")))
-
-  ;; A nested pointer chain used to silently lose a level:
-  ;; (var p (* (* char))) emitted `char *p'
-  (test-group "malformed types are rejected"
-    (test-assert "nested pointer chain"
-      (reports? (in-fn "(var p (* (* char)))") "pointer chains are written flat"))
-    (test-assert "and names the line"
-      (reports? "(pub fn f () void\n  (var p (* (* char))))" "codegen.sex:2:"))
-    ;; A sublist that only groups has no `*' in it and must still work.
-    (test-assert "grouping sublist still accepted"
-      (emits? (in-fn "(var s (* (const struct suc)) 0)") "const struct suc * s"))
-    (test-assert "flat chain still accepted"
-      (emits? (in-fn "(var q (* * const char) 0)") "const char * * q")))
-
-  ;; A string as the first body form (or after the name of a struct,
-  ;; union or enum) is a docstring: it becomes a comment immediately
-  ;; before the declaration, not a statement inside it.
-  (test-group "docstrings"
-    (test-assert "appears before the function"
-      (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
-              "/* Greet NAME. */"))
-    (test-assert "and not inside the body as a statement"
-      (not (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
-                   "\"Greet NAME.\"")))
-    (test-assert "multiline keeps its paragraphs"
-      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
-              "Entry point."))
-    (test-assert "and the second paragraph too"
-      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
-              "ARGC and ARGV."))
-    (test-assert "a prototype with only a docstring stays a prototype"
-      (emits? "(fn helper ((a int)) int \"Forward.\")"
-              "helper (int a);"))
-    (test-assert "a string after the first statement is left alone"
-      (emits? "(fn f () void (g) \"not a docstring\")"
-              "\"not a docstring\""))
-    (test-assert "a struct docstring sits above the struct"
-      (emits? "(struct point \"A 2D point.\" ((x int) (y int)))"
-              "/* A 2D point. */"))
-    (test-assert "and an enum docstring too"
-      (emits? "(enum color \"RGB.\" (red green blue))"
-              "/* RGB. */")))
-
-  ;; `static-assert' is the keyword rather than the <assert.h> macro, so
-  ;; a static assertion costs no include. Mapped in `atom-to-fmt-c'
-  ;; because `unkebabify' alone would spell it `static_assert'.
-  (test-group "static-assert"
-    (test-assert "emits the C11 keyword"
-      (emits? (in-fn "(static-assert (== (sizeof int) 4) \"int is four bytes\")")
-              "_Static_assert(sizeof(int) == 4, \"int is four bytes\")"))
-    (test-assert "and not the header macro"
-      (not (emits? (in-fn "(static-assert (== (sizeof int) 4) \"x\")")
-                   "static_assert("))))
-
-  ;; A closure is a code pointer beside its captures. The struct is
-  ;; named from the signature, so separate translation units agree on
-  ;; it, and calling one goes through `code' with `env' passed first.
-  ;;
-  ;; A closure struct, and the helper its calls go through, are each
-  ;; emitted once per signature; the registries deciding that are
-  ;; compile-time state like the type databases, and outlive a single
-  ;; `sex->c' here. So every case below that looks for a *definition*
-  ;; uses a signature of its own -- cases looking at a call site can
-  ;; share one.
-  (test-group "closures"
-    (test-assert "the type becomes a struct named for its signature"
-      (emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
-              "struct ƛint_int"))
-    ;; The environment is one shared union, declared in the prelude --
-    ;; its layout is part of the ABI two units agree on, so it cannot
-    ;; depend on what either file contains. `sex->c' has no prelude, so
-    ;; what is visible here is the member
-    (test-assert "whose environment is the shared union"
-      (emits? "(fn f ((c (closure ((float)) int))) int (return (c 1.0)))"
-              "union ƛenv env;"))
-    ;; The receiver goes through a helper rather than being written
-    ;; out twice, so that `[table (++ i)]' evaluates its index once,
-    ;; exactly as it would for an array of function pointers
-    (test-assert "a call passes the receiver to a helper"
-      (emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
-              "ƛint_int_call(c, 1)"))
-    (test-assert "and the helper is what dereferences it"
-      (emits? "(fn f ((c (closure ((long)) int))) int (return (c 1)))"
-              "ƛc.code(&ƛc.env, ƛa0)"))
-    (test-assert "a subscript receiver is evaluated once"
-      (emits? "(fn f ((t (¤ (closure ((int)) int) 4)) (i int)) int (return ((¤ t (++ i)) 1)))"
-              "ƛint_int_call(t[++i], 1)"))
-    (test-assert "so is a member receiver"
-      (emits? "(struct h ((cb (closure ((int)) int))))
-               (fn f ((s (struct h))) int (return ((. s cb) 1)))"
-              "ƛint_int_call(s.cb, 1)"))
-    (test-assert "a captured name is rebound in the lifted body"
-      (emits? "(fn f ((n int)) (closure ((char)) int) (return (closure ((x char)) int (n) (return n))))"
-              "int n = ƛcaptures->n;"))
-    (test-assert "captures are checked against the environment"
-      (emits? "(fn f ((n int)) (closure ((short)) int) (return (closure ((x short)) int (n) (return n))))"
-              "_Static_assert(sizeof(struct"))
-    ;; A closure over nothing has no record to point at, and C has no
-    ;; empty struct to declare for it
-    (test-assert "no captures means no capture record"
-      (not (emits? "(fn f () (closure () int) (return (closure () int () (return 7))))"
-                   "_captures {")))
-    ;; `(name expr)' names a capture and gives what it holds, so the
-    ;; expression is evaluated once, where the closure is written
-    (test-assert "a named capture takes its type from the expression"
-      (emits? "(struct p ((x int) (y int)))
-               (fn f ((s (struct p))) (closure () int)
-                 (return (closure () int ((sum (+ (. s x) (. s y)))) (return sum))))"
-              "int sum;"))
-    (test-assert "and the constructor is handed the expression"
-      (emits? "(struct p ((x int) (y int)))
-               (fn f ((s (struct p))) (closure () int)
-                 (return (closure () int ((sum (+ (. s x) (. s y)))) (return sum))))"
-              "_make(s.x + s.y)"))
-    (test-assert "capturing a pointer is how by-reference is spelled"
-      (emits? "(struct p ((x int)))
-               (fn f ((s (* (struct p)))) (closure () int)
-                 (return (closure () int ((q s)) (return (-> q x)))))"
-              "struct p* q;"))
-    ;; A bare function is a closure that captures nothing, so it
-    ;; converts wherever one is expected -- the pointer goes in the
-    ;; environment and one thunk per signature reads it back out
-    (test-assert "a named function in a var initializer"
-      (emits? "(fn g ((n int)) int (return n))
-               (fn f () void (var c (closure ((int)) int) g))"
-              "ƛint_int_fromfn(g)"))
-    (test-assert "a lambda, which is a bare function too"
-      (emits? "(fn f () void (var c (closure ((int)) int)
-                               (lambda ((n int)) int (return n))))"
-              "ƛint_int_fromfn(λ0_f)"))
-    (test-assert "an argument, against the parameter that signature wrote"
-      (emits? "(fn g ((n int)) int (return n))
-               (fn h ((c (closure ((int)) int))) int (return (c 1)))
-               (fn f () int (return (h g)))"
-              "h(ƛint_int_fromfn(g))"))
-    (test-assert "a return, against the declared return type"
-      (emits? "(fn g ((n int)) int (return n))
-               (fn f () (closure ((int)) int) (return g))"
-              "return ƛint_int_fromfn(g)"))
-    (test-assert "the thunk reads the pointer out of the environment"
-      (emits? "(fn g ((n float)) int (return 1))
-               (fn f () void (var c (closure ((float)) int) g))"
-              "return ƛcaptures->f(ƛa0)"))
-    ;; a signature that does not match is left alone, and C rejects it
-    (test-assert "a function of the wrong signature does not convert"
-      (not (emits? "(fn g ((n float)) int (return 1))
-                    (fn f () void (var c (closure ((int)) int) g))"
-                   "_fromfn(g)")))
-    ;; a closure is lifted into the function it was written in, so
-    ;; there has to be one
-    (test-assert "a closure at toplevel is refused"
-      (reports? "(var c (closure () int) (closure () int () (return 1)))"
-                "only be written inside a function"))
-    (test-assert "and so is one in a struct field"
-      (reports? "(struct s ((f (closure () int) (closure () int () (return 1)))))"
-                "only be written inside a function"))
-    ;; A block opens a scope, so what it declares ends with it
-    (test-assert "a name shadowed in a block does not escape it"
-      (emits? "(fn mk () (closure () int) (return (closure () int () (return 1))))
-               (fn f () int (var c (closure () int) (mk))
-                            (do (var c int 9) (g c))
-                            (return (c)))"
-              "ƛvoid_int_call(c)"))
-    (test-assert "and the shadowing declaration is what the block sees"
-      (emits? "(fn mk () (closure () int) (return (closure () int () (return 1))))
-               (fn f () int (var c (closure () int) (mk))
-                            (do (var c int 9) (g c))
-                            (return (c)))"
-              "g(c)"))
-    ;; The receiver is written twice, so a name used as an argument
-    ;; must not be mistaken for a call of its own
-    (test-assert "a closure passed as an argument stays a value"
-      (emits? "(fn g ((c (closure ((int)) int))) int (return 0))
-               (fn f ((c (closure ((int)) int))) int (return (g c)))"
-              "g(c)")))
-
-  ;; a macro body reads types as lists, so the srfi-1 accessors are in
-  ;; scope beside the type database
-  (test-group "macro list accessors"
-    (test-assert "third reads an array's length"
-      (emits? "(defmacro (len t) (third t))
-               (fn f () int (return (len (¤ int 7))))"
-              "return 7;"))
-    (test-assert "second reads a tag"
-      (emits? "(defmacro (tag t) (symbol->string (second t)))
-               (fn f () void (g (tag (struct point))))"
-              "g(\"point\")")))
-
-  ;; `type-of' hands a macro the type of an *expression*, where
-  ;; `get-name-type' only answers for a name. The macro is expanded
-  ;; during the walk rather than before it, so the scope is still live.
-  (test-group "type-of"
-    (test-assert "a local, from its declaration"
-      (emits? "(defmacro (t x) (type-match (type-of x) (int 1) (else 0)))
-               (fn f () int (var n int 0) (return (t n)))"
-              "return 1;"))
-    (test-assert "an expression, not just a name"
-      (emits? "(defmacro (t x) (type-match (type-of x) (double 1) (else 0)))
-               (fn f () int (var d double 0.0) (return (t (+ d 1))))"
-              "return 1;"))
-    (test-assert "a call, through the callee's signature"
-      (emits? "(fn g () float (return 1.0))
-               (defmacro (t x) (type-match (type-of x) (float 1) (else 0)))
-               (fn f () int (return (t (g))))"
-              "return 1;"))
-    ;; a macro is shown the written spelling, not the generated struct
-    (test-assert "a closure, spelled the way it was written"
-      (emits? "(fn mk () (closure ((int)) int)
-                 (return (closure ((b int)) int () (return b))))
-               (defmacro (t x) (type-match (type-of x) ((closure _ _) 1) (else 0)))
-               (fn f () int (var c _ (mk)) (return (t c)))"
-              "return 1;"))
-    (test-assert "and calling one has the closure's return type"
-      (emits? "(fn mk () (closure ((int)) int)
-                 (return (closure ((b int)) int () (return b))))
-               (defmacro (t x) (type-match (type-of x) (int 1) (else 0)))
-               (fn f () int (var c _ (mk)) (return (t (c 1))))"
-              "return 1;"))
-    ;; outside an expansion there is no scope to ask about
-    (test-assert "a name the walk has not reached is unknown"
-      (emits? "(defmacro (t x) (type-match (type-of x) (int 1) (else 0)))
-               (fn f () int (return (t nope)))"
-              "return 0;")))
-
-  ;; `_' as a type is written out from what the initializer says. The
-  ;; answer comes from declarations and from the signature a call names,
-  ;; never from unification -- a partial type would need one.
-  (test-group "wildcard types"
-    (test-assert "an integer literal"
-      (emits? (in-fn "(var x _ 42)") "int x = 42"))
-    (test-assert "a float literal"
-      (emits? (in-fn "(var x _ 3.5)") "double x = 3.5"))
-    (test-assert "a string literal"
-      (emits? (in-fn "(var x _ \"hi\")") "const char * x"))
-    (test-assert "a call, through the name table"
-      (emits? "(fn g ((a int)) float (return 1.0))
-               (fn f () void (var x _ (g 1)))"
-              "float x = g(1)"))
-    (test-assert "a struct member"
-      (emits? "(struct p ((a int) (b float)))
-               (fn f ((s (struct p))) void (var x _ (. s b)))"
-              "float x = s.b"))
-    (test-assert "an address, which composes"
-      (emits? "(struct p ((a int)))
-               (fn f ((s (struct p))) void (var x _ (& s)))"
-              "struct p* x = &s"))
-    (test-assert "a comparison is a bool"
-      (emits? (in-fn "(var x _ (< a b))") "bool x = a < b"))
-    ;; a wildcard inside a spelling is solved in place, leaving the rest
-    ;; of the written type alone -- this is what needs the unifier
-    (test-assert "a wildcard inside a pointer"
-      (emits? "(struct p ((a int)))
-               (fn f ((s (struct p))) void (var x (* _) (& s)))"
-              "struct p* x = &s"))
-    (test-assert "a wildcard inside an array"
-      (emits? (in-fn "(var t (¤ _ 3) #((¤ int 3) : 1 2 3))") "int t[3]"))
-    ;; a compound literal carries its own type, where a brace
-    ;; initializer has none and takes one from its context
-    (test-assert "a compound literal answers a bare wildcard"
-      (emits? "(struct p ((a int) (b int)))
-               (fn f () void (var x _ #((struct p) : 1 2)))"
-              "struct p x = (struct p){1, 2}"))
-    (test-assert "a brace initializer cannot"
-      (reports? (in-fn "(var x _ #(1 2))") "cannot infer the type"))
-    ;; ...but its elements still solve the hole in an array type
-    (test-assert "elements solve an array's element type"
-      (emits? (in-fn "(var t (¤ _ 4) #(0 1 4 9))") "int t[4] = {0, 1, 4, 9}"))
-    (test-assert "including when there are fewer than the length"
-      (emits? (in-fn "(var t (¤ _ 10) #(1 2))") "int t[10] = {1, 2}"))
-    (test-assert "and they have to agree with each other"
-      (reports? (in-fn "(var t (¤ _ 2) #(1 \"s\"))") "type mismatch"))
-    ;; a closure type reaches the solver as the struct that stands for
-    ;; it, which is the spelling `parse-type' knows
-    (test-assert "a closure, from the signature that produced it"
-      (emits? "(fn mk () (closure ((int)) int)
-                 (return (closure ((b int)) int () (return b))))
-               (fn f () void (var c _ (mk)))"
-              "struct ƛint_int c = mk()"))
-    (test-assert "and it is callable once inferred"
-      (emits? "(fn mk () (closure ((int)) int)
-                 (return (closure ((b int)) int () (return b))))
-               (fn f () int (var c _ (mk)) (return (c 1)))"
-              "ƛint_int_call(c, 1)"))
-    ;; C's usual arithmetic conversions, far enough to answer `_'
-    (test-assert "floating beats integral"
-      (emits? (in-fn "(var d double 1.0) (var x _ (+ a d))") "double x = a + d"))
-    (test-assert "the wider integer wins"
-      (emits? (in-fn "(var l long 1) (var x _ (+ a l))") "long x = a + l"))
-    (test-assert "double beats float"
-      (emits? (in-fn "(var g float 1.0) (var d double 1.0) (var x _ (+ g d))")
-              "double x = g + d"))
-    (test-assert "and same-width operands stay put"
-      (emits? (in-fn "(var g float 1.0) (var x _ (+ g g))") "float x = g + g"))
-    (test-assert "a pointer operand makes it pointer arithmetic"
-      (emits? "(struct p ((a int)))
-               (fn f ((s (struct p))) void (var x _ (+ (& s) 1)))"
-              "struct p* x = &s + 1"))
-    ;; a written type that cannot match what the initializer gives
-    (test-assert "a mismatch is reported, not papered over"
-      (reports? (in-fn "(var p (* _) 42)") "type mismatch"))
-    ;; a wildcard that cannot be answered is an error, not a guess
-    (test-assert "with no initializer there is nothing to infer from"
-      (reports? (in-fn "(var x _)") "cannot infer the type"))
-    (test-assert "nor from a name the compiler never saw declared"
-      (reports? (in-fn "(var x _ (never-declared))") "cannot infer the type")))
-
-  ;; `(car res)' on the expansion assumed it was a pair, so a macro
-  ;; computing a value rather than building a form crashed the compiler.
-  (test-group "macro expanding to an atom"
-    (test-assert "a number"
-      (emits? "(defmacro (two) 2) (fn f () int (return (two)))"
-              "return 2;"))
-    (test-assert "a string"
-      (emits? "(defmacro (who) \"sex\") (fn f () void (g (who)))"
-              "g(\"sex\")"))
-    ;; a symbol expansion can stand where a type does, which is what
-    ;; makes a macro able to compute one
-    (test-assert "a symbol, used as a type"
-      (emits? "(defmacro (ty) 'int) (fn f () void (var x (ty) 0))"
-              "int x = 0"))
-    ;; ...and nothing at all, for a macro that only registers something
-    (test-assert "nothing, at toplevel"
-      (emits? "(defmacro (quiet) (list)) (quiet) (fn f () int (return 1))"
-              "return 1;"))
-    (test-assert "nothing, in a body"
-      (emits? "(defmacro (quiet) (list)) (fn f () int (quiet) (return 1))"
-              "return 1;"))
-    ;; several forms need `$', which is what tells a splice from a call
-    (test-assert "$ splices"
-      (emits? "(defmacro (pair) (list '$ '(fn a () int (return 1))
-                                         '(fn b () int (return 2))))
-               (pair)"
-              "b (void)"))
-    (test-assert "and ($) is nothing at all"
-      (emits? "(defmacro (quiet) (list '$)) (quiet) (fn f () int (return 1))"
-              "return 1;"))
-    ;; without `$' a list is one form, so a head that is itself a form
-    ;; stays a call rather than becoming two statements
-    (test-assert "a computed callee stays one form"
-      (emits? "(fn mk () (closure ((int)) int)
-                 (return (closure ((b int)) int () (return b))))
-               (defmacro (apply-it x) `((mk) ,x))
-               (fn f () int (return (apply-it 5)))"
-              "ƛint_int_call(mk(), 5)"))
-    ;; spliced, it would have become two forms in the `return' -- the
-    ;; comma operator, and the wrong answer
-    (test-assert "rather than two forms in its context"
-      (not (emits? "(fn mk () (closure ((int)) int)
-                      (return (closure ((b int)) int () (return b))))
-                    (defmacro (apply-it x) `((mk) ,x))
-                    (fn f () int (return (apply-it 5)))"
-                   "return mk(), 5"))))
-
-  ;; A unary expression parenthesised its operand rather than itself, so
-  ;; the parens landed inside: `*(p).x', which C reads as `*(p.x)'.
-  (test-group "unary operand precedence"
-    (test-assert "member access through a dereference"
-      (emits? "(struct pt ((x int))) (fn f ((p (* (struct pt)))) int (return (. (* p) x)))"
-              "(*p).x"))
-    (test-assert "and not with the parens inside"
-      (not (emits? "(struct pt ((x int))) (fn f ((p (* (struct pt)))) int (return (. (* p) x)))"
-                   "*(p).x")))
-    (test-assert "member access through a cast"
-      (emits? (in-fn "(var n int (. (* (cast a (* (struct s)))) f))")
-              "(*(struct s*)a).f"))
-    ;; ...without gaining parens where none are due
-    (test-assert "a bare dereference is left alone"
-      (emits? (in-fn "(var p (* int) 0) (= a (* p))") "a = *p"))
-    (test-assert "so is address-of in an argument"
-      (emits? (in-fn "(g (& a))") "g(&a)"))
-    (test-assert "and negation beside a binary operator"
-      (emits? (in-fn "(var n int (+ (- a) b))") "-a + b")))
-
-  ;; An array bound was taken only when it was an integer literal, so a
-  ;; symbolic one fell into the type: `(¤ int N)' came out `int N a[]'.
-  (test-group "array bounds"
-    (test-assert "a symbolic bound"
-      (emits? "(define N 4) (struct s ((a (¤ int N))))" "int a[N]"))
-    (test-assert "an expression bound"
-      (emits? "(define N 4) (struct s ((a (¤ char (* 2 N)))))" "char a[2 * N]"))
-    (test-assert "an integer bound still works"
-      (emits? "(struct s ((a (¤ int 4))))" "int a[4]"))
-    ;; a multi-word type is keywords all the way down, so a trailing
-    ;; keyword belongs to the type and leaves the array unsized
-    (test-assert "a multi-word type is not a bound"
-      (emits? "(struct s ((a (¤ unsigned int))))" "unsigned int a[]"))
-    ;; ...and a tag always follows its keyword
-    (test-assert "nor is an aggregate tag"
-      (emits? "(struct t ((z int))) (struct s ((a (¤ struct t))))" "struct t a[]"))
-    (test-assert "nor one behind a pointer"
-      (emits? "(struct t ((z int))) (struct s ((a (¤ * struct t))))" "struct t* a[]"))))

tests/exit-code/Makefile

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

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

@@ -1,4 +0,0 @@
-;;; Rejected by the writer, so emit-c throws: there is a temporary .c
-;;; by then, and it must not survive.
-(fn f () void
-  (var p (* (* char))))

tests/fmt-c-writer.module.scm

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

tests/fmt-c-writer.scm

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

tests/infer.module.scm

@@ -1,45 +0,0 @@
-(module infer
-    (;; The IR
-     tvar?
-     tvar-id
-     tvar-classes
-     tvar-rigid?
-     fresh-tvar
-     fresh-rigid-tvar
-
-     prim-type? prim-name prim-quals make-prim
-     ptr-type? ptr-target ptr-quals make-ptr
-     array-type? array-elt array-size make-array-type
-     fn-type? fn-ret fn-args fn-variadic? make-fn-type
-     agg-type? agg-kind agg-name agg-spelling agg-quals make-agg
-     alias-type? alias-name alias-expansion alias-quals make-alias
-     unknown-type? the-unknown-type
-
-     resolve
-     underlying
-     c-primitive?
-     type-quals
-     free-tvars
-     decay
-
-     ;; The boundary
-     parse-type
-     unparse-type
-
-     ;; Constraints
-     register-class!
-     add-instance!
-     entails?
-     default-tvar!
-     default-type-variables!
-
-     ;; Unification
-     unify
-
-     ;; Type schemes
-     scheme? scheme-vars scheme-constraints scheme-type
-     make-scheme
-     generalize
-     instantiate
-     substitute)
-  "../infer.scm")

tests/infer.scm

@@ -1,319 +0,0 @@
-;;; Type inference, layer 0.
-;;;
-;;; Names registered in the type database are prefixed, since the
-;;; database is one table shared by every suite in the linked binary.
-
-(import infer types (chicken sort))
-
-;;; Parse and print a surface type again. Everything in this suite goes
-;;; through this pair, which is deliberate: they are the only thing the
-;;; rest of the compiler will ever see of the IR.
-(define (round-trip surface)
-  (unparse-type (parse-type surface)))
-
-(test-group "infer"
-
-  (test-group "round-trip"
-    ;; Every spelling below appears in example/ or tests/, or is one
-    ;; the C writer documents in walk-type. `type-match' compares types
-    ;; with equal?, so a near miss here is not a cosmetic bug -- it is
-    ;; a reflection macro silently falling into its else branch.
-    (for-each
-     (lambda (surface)
-       (test (conc "round-trips: " surface) surface (round-trip surface)))
-     '(int
-       void
-       char
-       float
-       double
-       size-t
-       GLfloat
-       (unsigned int)
-       (long long)
-       (const int)
-       (const char)
-       (* char)
-       (* void)
-       (* const char)
-       (* * char)
-       (* const * const char)
-       (const * const char)
-       (* FILE)
-       (* SDL-Window)
-       (struct point)
-       (struct list-int)
-       (union value)
-       (enum mood)
-       (const struct list-int)
-       (* struct list-int)
-       (* const struct point)
-       (¤ int 16)
-       (¤ char 512)
-       (¤ GLfloat 15)
-       (¤ float)
-       (¤ * const char)
-       (¤ * const struct res 32)
-       (¤ (¤ const char))
-       (fn () void)
-       (fn ((int)) int)
-       (fn ((int) (int)) int)
-       (fn ((* const char)) size-t)
-       (fn ((* const char) (...)) int)
-       (fn ((¤ float 4)) void)))
-
-    ;; Grouping parens are not part of the type, so these come back
-    ;; canonicalised rather than verbatim -- which is the whole reason
-    ;; unparse-type exists rather than "keep what was written".
-    (test "a grouped element is the same array" '(¤ int 16) (round-trip '(¤ (int) 16)))
-    (test "a grouped base is the same pointer" '(* const char)
-          (round-trip '(* (const char))))
-    (test "a grouped aggregate keeps its qualifier" '(const struct point)
-          (round-trip '(const (struct point))))
-
-    ;; A typedef is transparent to unification and opaque to printing:
-    ;; the generated declaration has to say what the programmer said.
-    (add-typedef 'i-handle '(typedef i-handle int))
-    (test "a typedef prints as itself" 'i-handle (round-trip 'i-handle))
-    (test "and qualified, as itself" '(const i-handle) (round-trip '(const i-handle)))
-    (test "and under a pointer" '(* i-handle) (round-trip '(* i-handle))))
-
-  (test-group "wildcards"
-    (test "a bare _ is a variable" '_ (round-trip '_))
-    (test "and composes under a pointer" '(* _) (round-trip '(* _)))
-    (test "and inside an array" '(¤ _ 4) (round-trip '(¤ _ 4)))
-    (test "and in a signature" '(fn ((_)) _) (round-trip '(fn ((_)) _)))
-
-    ;; Each _ is its own variable: solving one must not solve the rest.
-    (let ((t (parse-type '(fn ((_)) _))))
-      (unify (car (fn-args t)) (parse-type 'int) #f)
-      (test "one hole at a time" '(fn ((int)) _) (unparse-type t))))
-
-  (test-group "structure"
-    (test-assert "a pointer is a pointer" (ptr-type? (parse-type '(* char))))
-    (test "and knows what it points at" 'char
-          (unparse-type (ptr-target (parse-type '(* char)))))
-    (test "quals sit on the level they were written at" '(const)
-          (ptr-quals (parse-type '(const * char))))
-    (test "an unsized array has no size" #f (array-size (parse-type '(¤ int))))
-    (test "a sized one does" 16 (array-size (parse-type '(¤ int 16))))
-    (test "an aggregate is nominal" 'point (agg-name (parse-type '(struct point))))
-    (test-assert "a variadic signature says so"
-                 (fn-variadic? (parse-type '(fn ((* const char) (...)) int))))
-    (test-assert "and a plain one does not"
-                 (not (fn-variadic? (parse-type '(fn ((int)) int)))))
-
-    ;; decay: the conversion C performs at a call site, an operand of
-    ;; `+', or the left half of a subscript.
-    (test "an array decays to a pointer" '(* int) (unparse-type (decay (parse-type '(¤ int 16)))))
-    (test "a function decays to a pointer to itself" '(* (fn ((int)) int))
-          (unparse-type (decay (parse-type '(fn ((int)) int)))))
-    (test "anything else is left alone" 'int (unparse-type (decay (parse-type 'int)))))
-
-  (test-group "unification"
-    (test-assert "a type unifies with itself"
-                 (unify (parse-type 'int) (parse-type 'int) #f))
-    (test-error "and not with another one"
-                (unify (parse-type 'int) (parse-type 'char) #f))
-
-    (let ((a (fresh-tvar)))
-      (unify a (parse-type '(* const char)) #f)
-      (test "a variable takes the shape it is unified with"
-            '(* const char) (unparse-type a)))
-
-    ;; The point of the exercise: `(var p (* _) (& x))' with x : int.
-    (let ((p (parse-type '(* _))))
-      (unify p (parse-type '(* int)) #f)
-      (test "a partial type is completed by one step" '(* int) (unparse-type p)))
-
-    (let ((a (fresh-tvar))
-          (b (fresh-tvar)))
-      (unify a b #f)
-      (unify b (parse-type 'double) #f)
-      (test "two variables joined then solved" 'double (unparse-type a)))
-
-    (test-error "structure has to match"
-                (unify (parse-type '(* int)) (parse-type '(* char)) #f))
-    (test-error "and arity"
-                (unify (parse-type '(fn ((int)) int))
-                       (parse-type '(fn ((int) (int)) int)) #f))
-    (test-error "and aggregates are told apart by name"
-                (unify (parse-type '(struct point)) (parse-type '(struct box)) #f))
-    (test-error "and by kind"
-                (unify (parse-type '(struct point)) (parse-type '(union point)) #f))
-
-    ;; An unwritten array length constrains nothing, the way it does
-    ;; not in C either.
-    (test-assert "an unsized array unifies with a sized one"
-                 (unify (parse-type '(¤ int)) (parse-type '(¤ int 16)) #f))
-    (test-error "but two written lengths must agree"
-                (unify (parse-type '(¤ int 4)) (parse-type '(¤ int 16)) #f))
-
-    ;; A typedef unifies as whatever it stands for.
-    (add-typedef 'i-count '(typedef i-count int))
-    (test-assert "a typedef unifies with its target"
-                 (unify (parse-type 'i-count) (parse-type 'int) #f))
-    (let ((a (fresh-tvar)))
-      (unify a (parse-type 'i-count) #f)
-      (test "and keeps its name when it is the one printed"
-            'i-count (unparse-type a)))
-
-    (test-group "the unknown type"
-      (test-assert "? is consistent with anything"
-                   (unify the-unknown-type (parse-type '(struct point)) #f))
-      (test-assert "in either order"
-                   (unify (parse-type 'int) the-unknown-type #f))
-      ;; ...and binds nothing. Degrading to ? is what keeps an
-      ;; unparsed C declaration from poisoning everything it touches.
-      (let ((a (fresh-tvar)))
-        (unify a the-unknown-type #f)
-        (test "a variable met with ? stays open" '_ (unparse-type a))))
-
-    (test-group "occurs check"
-      ;; Unreachable without recursive types, and the alternative to
-      ;; having it is not an error but a hang.
-      (let ((a (fresh-tvar)))
-        (test-error "a variable may not contain itself"
-                    (unify a (make-ptr a (list)) #f))))
-
-    (test-group "rigid variables"
-      (let ((r (fresh-rigid-tvar))
-            (a (fresh-tvar)))
-        (test-error "a type parameter does not unify with a type"
-                    (unify r (parse-type 'int) #f))
-        (test-assert "an ordinary variable binds to it instead"
-                     (unify a r #f))
-        ;; An unsolved variable resolves to itself.
-        (test-assert "it is still open" (tvar? (resolve r))))
-      ;; ...and the same the other way round: it is which side is free
-      ;; that decides, not which side was written first.
-      (let ((r (fresh-rigid-tvar))
-            (a (fresh-tvar)))
-        (test-assert "rigid first binds the free one" (unify r a #f))
-        (test-assert "to the parameter itself" (eq? r (resolve a))))
-      (let ((r1 (fresh-rigid-tvar))
-            (r2 (fresh-rigid-tvar)))
-        (test-error "two parameters do not unify with each other"
-                    (unify r1 r2 #f)))))
-
-  (test-group "constraints"
-    (test #t (entails? 'numeric (parse-type 'int)))
-    (test #t (entails? 'numeric (parse-type '(unsigned long))))
-    (test #t (entails? 'integral (parse-type 'char)))
-    (test #f (entails? 'integral (parse-type 'double)))
-    (test #t (entails? 'floating (parse-type 'double)))
-    (test #f (entails? 'floating (parse-type 'int)))
-    (test #f (entails? 'numeric (parse-type '(* char))))
-    (test #t (entails? 'scalar (parse-type '(* char))))
-    (test #f (entails? 'numeric (parse-type 'void)))
-
-    (add-enum 'i-mood '(enum i-mood (glad sad)))
-    (test "an enum is an integer" #t (entails? 'integral (parse-type '(enum i-mood))))
-
-    ;; The third answer, and the important one. A name from a header
-    ;; might well be numeric; #f would reject working programs and #t
-    ;; would invent knowledge.
-    (test "an unparsed C name is not known either way"
-          'unknown (entails? 'numeric (parse-type 'size-t)))
-    (test "nor is an open variable" 'unknown (entails? 'numeric (fresh-tvar)))
-    (test "? entails nothing, but says so quietly"
-          'unknown (entails? 'numeric the-unknown-type))
-
-    ;; A typedef is entailed by what it resolves to, so an alias cannot
-    ;; sneak past a constraint its target would fail.
-    (add-typedef 'i-len '(typedef i-len int))
-    (test "a typedef is judged by its target" #t (entails? 'numeric (parse-type 'i-len)))
-
-    ;; A constrained variable checks its classes at the moment it is
-    ;; solved, not at the end.
-    (let ((a (fresh-tvar '(numeric))))
-      (test-error "solving to a type that fails the class is an error"
-                  (unify a (parse-type '(* char)) #f)))
-    (let ((a (fresh-tvar '(numeric))))
-      (test-assert "and to one that satisfies it is not"
-                   (unify a (parse-type 'double) #f)))
-    ;; ...but an unparsed name is not a failure, it is an absence of
-    ;; knowledge, and must stay silent.
-    (let ((a (fresh-tvar '(numeric))))
-      (test-assert "an unparsed C name does not trip a constraint"
-                   (unify a (parse-type 'GLuint) #f)))
-
-    ;; Joining two variables joins what is known about both.
-    (let ((a (fresh-tvar '(numeric)))
-          (b (fresh-tvar '(integral))))
-      (unify a b #f)
-      (test "constraints merge when variables do"
-            '("integral" "numeric")
-            (sort (map symbol->string (tvar-classes b)) string<?)))
-
-    (test-group "defaulting"
-      (let ((a (fresh-tvar '(numeric))))
-        (default-type-variables! a #f)
-        (test "an open numeric is an int" 'int (unparse-type a)))
-      (let ((a (fresh-tvar '(floating))))
-        (default-type-variables! a #f)
-        (test "an open floating is a double" 'double (unparse-type a)))
-      (let ((a (fresh-tvar)))
-        (test "a variable with nothing known about it cannot be defaulted"
-              #f (default-type-variables! a #f))
-        (test "and stays a hole, for the caller to complain about"
-              '_ (unparse-type a)))
-      ;; Defaulting reaches into the structure, since the hole may be
-      ;; anywhere: `(var p (* _) ...)'.
-      (let ((t (parse-type '(* _))))
-        (unify (ptr-target t) (fresh-tvar '(numeric)) #f)
-        (default-type-variables! t #f)
-        (test "and it reaches inside a type" '(* int) (unparse-type t))))
-
-    (test-group "user classes"
-      ;; A trait bound is the same shape as `numeric', discharged by
-      ;; the same procedure -- that is the point of one representation.
-      ;; It differs in two rules, and both are stated while there is
-      ;; still only one kind of constraint to state them about.
-      (register-class! 'i-ord #f #f #t)
-      (add-struct 'i-circle '(struct i-circle ((r int))))
-      (test "no instance, no entailment" #f (entails? 'i-ord (parse-type '(struct i-circle))))
-      (add-instance! 'i-ord (parse-type '(struct i-circle)))
-      (test "and with one, entailment" #t (entails? 'i-ord (parse-type '(struct i-circle))))
-      ;; Instances key on the resolved type, so an alias cannot be
-      ;; registered twice under two names.
-      (add-typedef 'i-circle-alias '(typedef i-circle-alias (struct i-circle)))
-      (test "an alias of an instance is the same instance"
-            #t (entails? 'i-ord (parse-type 'i-circle-alias)))
-      ;; Decision 2: static dispatch cannot select an instance for a
-      ;; type it does not know, so a strict class says no to ? rather
-      ;; than shrugging the way `numeric' does.
-      (test "a strict class refuses ?" #f (entails? 'i-ord the-unknown-type))
-      (test "where a lenient one abstains" 'unknown (entails? 'numeric the-unknown-type))
-      ;; ...and it has no default to fall back on.
-      (let ((a (fresh-tvar '(i-ord))))
-        (test-error "an unresolved user constraint is an error, not a guess"
-                    (default-type-variables! a #f)))))
-
-  (test-group "schemes"
-    ;; Nothing generalizes yet. The shape is here because a scheme
-    ;; without a constraint list is the wrong shape for every bounded
-    ;; generic, and because instantiation is how a generic body gets
-    ;; fresh cells instead of a second type for the same one.
-    (let* ((a (fresh-tvar '(numeric)))
-           (id (make-fn-type a (list a) #f))
-           (s (generalize id (list))))
-      (test "the free variable is quantified" 1 (length (scheme-vars s)))
-      (test "carrying its class as the scheme's context"
-            '((numeric)) (list (map car (scheme-constraints s))))
-
-      (let ((one (instantiate s))
-            (two (instantiate s)))
-        (test "an instantiation is still open" '(fn ((_)) _) (unparse-type one))
-        (unify (fn-ret one) (parse-type 'int) #f)
-        (test "solving one instantiation" '(fn ((int)) int) (unparse-type one))
-        (test "leaves the other alone" '(fn ((_)) _) (unparse-type two))
-        (test "and the scheme itself untouched" '(fn ((_)) _) (unparse-type id))))
-
-    (let* ((a (fresh-tvar))
-           (b (fresh-tvar))
-           (s (generalize (make-fn-type a (list b) #f) (list b))))
-      (test "a variable free in the environment is not quantified"
-            1 (length (scheme-vars s)))
-      (let ((inst (instantiate s)))
-        (unify (car (fn-args inst)) (parse-type 'char) #f)
-        (test "so instantiating solves it for everyone" 'char (unparse-type b))))))

tests/line-directives.scm

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

tests/modules/Makefile

@@ -1,38 +0,0 @@
-# Multi-module linking.
-#
-# Modules are only testable end to end, and nothing else in the suite
-# links more than one translation unit. Three things have to hold at
-# once: an imported `pub fn' comes out as a prototype with external
-# linkage, an imported `pub var' as an extern declaration, and the
-# module's object survives being passed after `--'. Get any of them
-# wrong and this fails to link -- or, in the `pub var' case, links and
-# quietly counts into a private copy.
-#
-# It also checks what only a second translation unit can check: that an
-# imported type reaches the type database, by expanding a macro that
-# reads the imported struct's fields; and that a closure type crossing
-# the boundary works both ways -- one built in the module and called
-# here, one built here and called there, through a code pointer that is
-# static in the other object.
-#
-# The public forms carry comments in their headers, which the reduction
-# to a prototype and to an extern both have to look past.
-
-SEXC ?= ../../sexc
-
-EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1\nclosure 15 21 201
-
-check:
-	@$(SEXC) greet.sex -c -o greet.o
-	@$(SEXC) greet-app.sex -o greet-app -- greet.o
-	@if [ "`./greet-app`" = "`printf '$(EXPECTED)\n'`" ]; then \
-		echo "modules ok"; \
-	else \
-		echo "modules FAILED, got:"; ./greet-app; $(MAKE) clean; exit 1; \
-	fi
-	@$(MAKE) --no-print-directory clean
-
-clean:
-	@rm -f greet.o greet-app
-
-.PHONY: check clean

tests/modules/greet-app.sex

@@ -1,36 +0,0 @@
-;;; Uses the greet module. Build both, then link them:
-;;;
-;;;   ./sexc example/greet.sex -c -o greet.o
-;;;   ./sexc example/greet-app.sex -o greet-app -- greet.o
-;;;
-;;; `(import greet)' pastes greet's public declarations here: `greet'
-;;; as a prototype and `greet-count' as an extern. Both keep external
-;;; linkage, so they refer to the one definition in greet.o rather than
-;;; to private copies.
-;;;
-;;; Also check that import populates type-database, by means of
-;;; describe-fields macro, which should work on imported type.
-
-(include stdio.h)
-
-(import greet)
-
-(pub fn main () int
-  (greet "world")
-  (greet "sex")
-  (printf "%d greetings\n" greet-count)
-  (describe-fields greeting)
-  (printf "\n")
-  ;; ...and through the imported typedef for it
-  (describe-fields greeting-t)
-  (printf "\n")
-  (var m (enum mood) grumpy)
-  (printf "mood %d\n" m)
-
-  (var add-10 (closure ((int)) int) (make-adder 10))
-  (printf "closure %d %d" (add-10 5) (apply-twice add-10 1))
-  (var base int 100)
-  (var here (closure ((int)) int)
-       (closure ((x int)) int (base) (return (+ base x))))
-  (printf " %d\n" (apply-twice here 1))
-  (return 0))

tests/modules/greet.sex

@@ -1,53 +0,0 @@
-;;; A module. Everything marked `pub' forms its public interface;
-;;; everything else is private to this file.
-;;;
-;;; Importing a module does not link it: it pastes the declarations, so
-;;; the compiled object still has to be handed to the C compiler. See
-;;; greet-app.sex.
-
-(include stdio.h)
-
-(pub var greet-count ;; a comment in the header of a public form is
-                     ;; not part of it: what the importer is given has
-                     ;; to be `extern int greet-count', not a form
-                     ;; counted off by one
-  int 0)
-
-(pub struct greeting
-  "A greeting to print."
-  ((text (* const char)) (times int)))
-
-(pub enum mood (cheerful grumpy))
-
-(pub typedef greeting-t (struct greeting))
-
-;;; Compile-time reflection across the module boundary: both the macro
-;;; and the struct it asks about are exported, and the importing unit
-;;; has to know the struct's fields to expand this.
-(pub defmacro (describe-fields type)
-  `(do ,@(map-fields type
-           (lambda (name field-type)
-             `(printf "%s " ,(symbol->string name))))))
-
-(pub fn greet ;; ...and here the prototype would lose its return type
-  ((name (* const char))) void
-  "Print a greeting for NAME."
-  (++ greet-count)
-  (printf "hello, %s\n" name))
-
-;;; A closure type crossing the boundary. Both units generate the
-;;; struct for this signature independently, so they have to agree on
-;;; its tag and its layout, or the value is passed wrong and nothing
-;;; says so.
-(pub fn make-adder ((n int)) (closure ((int)) int)
-  (return (closure ((b int)) int (n)
-            (return (+ n b)))))
-
-;;; The other direction: a closure built by the importer, whose code
-;;; pointer is static in *its* object, called from here
-(pub fn apply-twice ((f (closure ((int)) int)) (x int)) int
-  (return (f (f x))))
-
-;;; Not `pub': invisible to importers, and static in the generated C.
-(fn unused-helper () void
-  (printf "private\n"))

tests/reader.module.scm

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

tests/reader.scm

@@ -1,102 +0,0 @@
-(import (chicken port)
-        reader)
-
-(define-syntax feature-test
-  (syntax-rules ()
-    ((feature-test result features string)
-     (test result
-           (parameterize ((current-features 'features))
-             (with-input-from-string string
-               (lambda () (read-raw-forms 'stdin))))))))
-
-(define-syntax reader-test
-  (syntax-rules ()
-    ((reader-test result string)
-     (test result
-           (with-input-from-string string
-             (lambda () (read-raw-forms 'stdin)))))))
-
-(test-group "reader"
-  ;; []-syntax. For array types and array access expressions
-  (reader-test '((¤ * char)) "[* char]")
-  (reader-test '((¤ * * char const 512)) "[* * char const 512]")
-  (reader-test '((¤)) "[]")
-  (reader-test '((¤ (¤))) "[[]]")
-  (reader-test '((¤ (¤ const char))) "[[const char]]")
-
-  ;; leading `.' becomes the dot-access operator
-  (reader-test '((dot-access obj field)) "(. obj field)")
-  (reader-test '((dot-access obj method a b)) "(. obj method a b)")
-  (reader-test '((dot-access a b)) "(.  a  b)")
-  ;; nested leading dot
-  (reader-test '((foo (dot-access a b))) "(foo (. a b))")
-
-  ;; dotted pairs are preserved (only a *leading* dot is special)
-  (reader-test '((a . b)) "(a . b)")
-  (reader-test '((a b . c)) "(a b . c)")
-  (reader-test '((quote (a . b))) "'(a . b)")
-  ;; a `.'-prefixed symbol is an ordinary symbol, not dot-access
-  (reader-test '((.field obj)) "(.field obj)")
-
-  ;; `;' comments are preserved as (comment "...") forms
-  (reader-test '((comment " hi")) "; hi")
-  (reader-test '((comment ";; Prototypes")) ";;; Prototypes")
-  (reader-test '((foo (comment " c") bar)) "(foo ; c\n bar)")
-  ;; a trailing top-level comment is its own form
-  (reader-test '((a b) (comment " t")) "(a b) ; t")
-  ;; a `;' inside a string is not a comment
-  (reader-test '("a;b") "\"a;b\"")
-
-  ;; #+ / #- feature expressions. What does not apply is read and
-  ;; dropped, so it never reaches the compiler at all
-  (feature-test '((a)) (linux) "#+linux (a)")
-  (feature-test '()    (macosx) "#+linux (a)")
-  (feature-test '()    (linux) "#-linux (a)")
-  (feature-test '((a)) (macosx) "#-linux (a)")
-  ;; the guarded datum can be anything, not only a list
-  (feature-test '(42) (x) "#+x 42")
-  (feature-test '("s") (x) "#+x \"s\"")
-
-  ;; and / or / not
-  (feature-test '((a)) (unix linux) "#+(and unix linux) (a)")
-  (feature-test '()    (unix) "#+(and unix linux) (a)")
-  (feature-test '((a)) (unix) "#+(or linux unix) (a)")
-  (feature-test '()    (bsd)  "#+(or linux unix) (a)")
-  (feature-test '((a)) (unix) "#+(and unix (not macosx)) (a)")
-  (feature-test '()    (unix macosx) "#+(and unix (not macosx)) (a)")
-  ;; (and) is true and (or) is false, as they are in CL
-  (feature-test '((a)) () "#+(and) (a)")
-  (feature-test '()    () "#+(or) (a)")
-
-  ;; a guard inside a form, including as the last element -- dropping
-  ;; continues with the next token, so the closing paren still arrives
-  (feature-test '((f 1 3)) (a) "(f #+a 1 #-a 2 3)")
-  (feature-test '((f 2 3)) (b) "(f #+a 1 #-a 2 3)")
-  (feature-test '((f 1))   (a) "(f #+a 1 #+b 2)")
-  (feature-test '((f))     (b) "(f #+a 1)")
-  ;; ...and as the last form in the file
-  (feature-test '((a)) (x) "(a) #+y (b)")
-
-  ;; guards nest
-  (feature-test '((a)) (x y) "#+x #+y (a)")
-  (feature-test '((b)) (x) "#+x #+y (a) (b)")
-  ;; ...and the inner one may leave nothing behind: the end of the
-  ;; file, or the paren closing the list, is what the outer one then
-  ;; produces, and neither is an error
-  (feature-test '()      (x) "#+x #+y (a)")
-  (feature-test '((f))   (x) "(f #+x #+y 1)")
-  (feature-test '((f 2)) (x) "(f #+x #+y 1 2)")
-  (feature-test '((a))   (x) "(a) #+x #+y (b)")
-
-  ;; a comment between a guard and the form it guards describes the
-  ;; guard. Taking it for the guarded datum would leave the form itself
-  ;; unconditional
-  (feature-test '((a)) (x) "#+x ;; why\n (a)")
-  (feature-test '()    (y) "#+x ;; why\n (a)")
-  (feature-test '((b)) (y) "#+x ;; why\n (a) (b)")
-  ;; a comment after the guarded form is an ordinary form, and stays
-  (feature-test '((comment "; tail")) (y) "#+x (a) ;; tail")
-
-  ;; a feature the program was not given is simply absent
-  (feature-test '() () "#+anything (a)")
-)

tests/run.scm

@@ -1,16 +0,0 @@
-(import
-  test)
-
-(include "basic.scm")
-(include "semen.scm")
-(include "reader.scm")
-(include "fmt-c-writer.scm")
-(include "utils.scm")
-(include "line-directives.scm")
-(include "codegen.scm")
-(include "args.scm")
-(include "types.scm")
-(include "infer.scm")
-
-;;; Should be the last in the test suite
-(test-exit)

tests/semen.module.scm

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

tests/semen.scm

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

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

tests/sex-modules.module.scm

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

tests/sex-programs/c99.sex

@@ -1,28 +0,0 @@
-(compilation "-- -std=c99 -pedantic-errors")
-(input)
-(output "c99: 42")
-(return 0)
-
-;;; The closure environment is part of the ABI, so its union is declared
-;;; in every translation unit whether or not one is used. That put
-;;; whatever it was written with into every program: `max_align_t' named
-;;; the alignment in one word, and made C11 the floor for a program with
-;;; no closure in it at all.
-;;;
-;;; The widest built-ins say the same thing -- a union is aligned for the
-;;; strictest of its members -- and say it in C99.
-;;;
-;;; Closures themselves still want C11 for the `_Static_assert' that
-;;; checks the captures fit, so this program keeps clear of them.
-
-(include stdio.h)
-
-(struct point ((x int) (y int)))
-
-(fn area ((p (struct point))) int
-  (return (* (. p x) (. p y))))
-
-(pub fn main () int
-  (var p (struct point) #((struct point) : 6 7))
-  (printf "c99: %d\n" (area p))
-  (return 0))

tests/sex-programs/closure-signatures.sex

@@ -1,52 +0,0 @@
-(input)
-(output "one argument of two words: 7"
-        "two arguments of one: 7"
-        "unsigned, one argument: 9"
-        "unsigned, two arguments: 3"
-        "captured global: 12"
-        "captured function: 8")
-(return 0)
-
-;;; A closure's struct is named after its signature, so that two
-;;; translation units agree on it without sharing a header. The name is
-;;; built by flattening the argument list, and flattening loses where one
-;;; argument ends and the next begins: `((long long))' and
-;;; `((long) (long))' are different signatures that used to mangle alike,
-;;; and the second quietly reused the first one's struct.
-;;;
-;;; A capture that borrows a name reads it from wherever the name is
-;;; declared, a global or a function included.
-
-(include stdio.h)
-
-(var scale int 3)
-
-(fn double-it ((n int)) int
-  (return (* n 2)))
-
-(pub fn main () int
-  (var one-wide (closure ((long long)) int)
-       (closure ((a (long long))) int () (return (cast a int))))
-  (printf "one argument of two words: %d\n" (one-wide 7))
-
-  (var two-longs (closure ((long) (long)) int)
-       (closure ((a long) (b long)) int () (return (cast (+ a b) int))))
-  (printf "two arguments of one: %d\n" (two-longs 3 4))
-
-  (var one-unsigned (closure ((unsigned int)) int)
-       (closure ((a (unsigned int))) int () (return (cast a int))))
-  (printf "unsigned, one argument: %d\n" (one-unsigned 9))
-
-  (var two-unsigned (closure ((unsigned) (int)) int)
-       (closure ((a unsigned) (b int)) int () (return (+ (cast a int) b))))
-  (printf "unsigned, two arguments: %d\n" (two-unsigned 1 2))
-
-  ;; a capture names what it borrows, and the name need not be a local
-  (var scaled (closure ((int)) int)
-       (closure ((x int)) int (scale) (return (* x scale))))
-  (printf "captured global: %d\n" (scaled 4))
-
-  (var doubled (closure ((int)) int)
-       (closure ((x int)) int (double-it) (return (double-it x))))
-  (printf "captured function: %d\n" (doubled 4))
-  (return 0))

tests/sex-programs/closures.sex

@@ -1,121 +0,0 @@
-(input)
-(output "Adders: 15 25"
-        "Two captures: 47"
-        "No captures: 7"
-        "Through a parameter: 110"
-        "From an array: 1 2 3"
-        "Index evaluated once: 21 i 1"
-        "Through a struct member: 8"
-        "Shadowed in a block: 9 then 15"
-        "Nested: 33"
-        "Named capture: 7"
-        "Captured pointer: 11 then 12"
-        "From a bare fn: 20 42 7")
-(return 0)
-
-;;; A closure is a code pointer beside its captures, so what this
-;;; checks is that the captures survive the lifting -- that two
-;;; closures of one shape keep their own environments, that a closure
-;;; outlives the call that built it, and that calling one through a
-;;; parameter, an array element or a struct member resolves the same
-;;; way as through a local.
-;;;
-;;; A receiver is also an ordinary expression: `[table (++ i)]' has to
-;;; evaluate its index exactly once, the way it would for an array of
-;;; function pointers.
-
-(include stdio.h)
-
-(fn double-it ((n int)) int
-  (return (* n 2)))
-
-;;; a bare function is a closure that captures nothing, so it converts
-;;; wherever one is expected -- here a declared return type
-(fn as-closure () (closure ((int)) int)
-  (return double-it))
-
-(fn make-adder ((n int)) (closure ((int)) int)
-  (return (closure ((b int)) int (n)
-            (return (+ n b)))))
-
-(fn make-affine ((k int) (b int)) (closure ((int)) int)
-  (return (closure ((x int)) int (k b)
-            (return (+ (* k x) b)))))
-
-(fn make-const-7 () (closure () int)
-  (return (closure () int ()
-            (return 7))))
-
-;;; A closure arriving as a parameter: its type is written, so the call
-;;; resolves without knowing where it came from
-(fn apply-twice ((f (closure ((int)) int)) (x int)) int
-  (return (f (f x))))
-
-(struct handlers ((on-tick (closure ((int)) int))))
-
-(pub fn main () int
-  (var add-10 (closure ((int)) int) (make-adder 10))
-  (var add-20 (closure ((int)) int) (make-adder 20))
-  (printf "Adders: %d %d\n" (add-10 5) (add-20 5))
-
-  (var affine (closure ((int)) int) (make-affine 5 2))
-  (printf "Two captures: %d\n" (affine 9))
-
-  (var seven (closure () int) (make-const-7))
-  (printf "No captures: %d\n" (seven))
-
-  (printf "Through a parameter: %d\n" (apply-twice (make-adder 50) 10))
-
-  (var table (¤ (closure ((int)) int) 3))
-  (var i int 0)
-  (for (= i 0) (< i 3) (++ i)
-       (= (¤ table i) (make-adder i)))
-  (printf "From an array: %d %d %d\n"
-          ((¤ table 0) 1) ((¤ table 1) 1) ((¤ table 2) 1))
-
-  ;; the index must be evaluated once, so `i' ends at 1 and not 2 --
-  ;; read in a separate statement, since reading and bumping it in one
-  ;; printf would be unsequenced whatever the closure did
-  (= i 0)
-  (var once int ([table (++ i)] 20))
-  (printf "Index evaluated once: %d i %d\n" once i)
-
-  (var h (struct handlers) #((struct handlers) : .on-tick (make-adder 5)))
-  (printf "Through a struct member: %d\n" ((. h on-tick) 3))
-
-  ;; a block opens a scope: the inner `add-10' ends with it, and the
-  ;; call after it is the closure again
-  (do (var add-10 int 9)
-      (printf "Shadowed in a block: %d then " add-10))
-  (printf "%d\n" (add-10 5))
-
-  ;; a closure built inside a closure, capturing that one's capture
-  (var outer (closure ((int)) int)
-       (closure ((x int)) int ()
-         (var inner (closure ((int)) int) (make-adder x))
-         (return (inner 3))))
-  (printf "Nested: %d\n" (outer 30))
-
-  ;; a capture can name what it holds rather than borrow a variable's
-  ;; name, and the expression is evaluated where the closure is written
-  (var pt (struct handlers))
-  (var sum-once (closure () int)
-       (closure () int ((sum (+ 3 4))) (return sum)))
-  (printf "Named capture: %d\n" (sum-once))
-
-  ;; capturing a pointer is how by-reference is spelled; the caller owns
-  ;; what it points at
-  (var counter int 11)
-  (var peek (closure () int)
-       (closure () int ((at (& counter))) (return (* at))))
-  (printf "Captured pointer: %d then " (peek))
-  (++ counter)
-  (printf "%d\n" (peek))
-
-  ;; ...and in an initializer, as an argument, and as a return
-  (var from-fn (closure ((int)) int) double-it)
-  (printf "From a bare fn: %d %d %d\n"
-          (apply-twice from-fn 5)
-          ((as-closure) 21)
-          (apply-twice (lambda ((n int)) int (return (+ n 1))) 5))
-  (return 0))

tests/sex-programs/comments.sex

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

tests/sex-programs/compound-literals.sex

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

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

tests/sex-programs/features.sex

@@ -1,23 +0,0 @@
-(compilation "--features=test-on")
-(input)
-(output "selected" "on" "and-not")
-(return 0)
-
-;;; #+ and #- pick what the compiler gets to see. `test-on' is handed
-;;; to sexc by the (compilation ...) form above, so this program reads
-;;; the same way on every platform.
-
-(include stdio.h)
-
-#+test-on (define GREETING "on")
-#-test-on (define GREETING "off")
-
-#-test-on (pub fn main () int (puts "the whole function is dropped") (return 1))
-
-(pub fn main () int
-  ;; ...and inside a form, not only at toplevel
-  (puts #+test-on "selected" #-test-on "rejected")
-  (puts GREETING)
-  #+(and test-on (not test-off)) (puts "and-not")
-  #-test-on (puts "never printed")
-  (return 0))

tests/sex-programs/fixpoint.sex

@@ -1,61 +0,0 @@
-(input)
-(output "direct: 120"
-        "fac: 120 3628800"
-        "fib: 55 6765"
-        "applied on the spot: 120")
-(return 0)
-
-;;; A fixed point built out of closures, which is the hardest thing to
-;;; ask of them: recursion with no recursive function anywhere, only
-;;; self-application.
-;;;
-;;; Self-application needs `x x' and so a recursive type, which is
-;;; spelled here by routing it through a named struct whose field is a
-;;; closure whose own signature mentions that struct. The generated
-;;; closure struct is written before `struct rec' is, so this only
-;;; compiles because a forward declaration is emitted ahead of both.
-;;;
-;;; Note what `fix' captures: a *pointer* to the knot, not the knot. A
-;;; closure is a code pointer beside N bytes of environment, so
-;;; capturing one by value would need N >= 8 + N. No budget makes that
-;;; true, and the static assertion says so rather than letting it
-;;; corrupt anything.
-
-(include stdio.h)
-
-(struct rec ((f (closure (((* (struct rec))) (int)) int))))
-
-;;; Takes a step that expects itself, returns an ordinary closure with
-;;; the self-application hidden inside
-(fn fix ((step (* (struct rec)))) (closure ((int)) int)
-  (return (closure ((n int)) int (step)
-            (return ((-> step f) step n)))))
-
-(pub fn main () int
-  (var fac-knot (struct rec))
-  (= (. fac-knot f)
-     (closure ((self (* (struct rec))) (n int)) int ()
-       (if (<= n 1) (return 1))
-       (return (* n ((-> self f) self (- n 1))))))
-
-  ;; the knot applied to itself directly, without fix
-  (printf "direct: %d\n" ((. fac-knot f) (& fac-knot) 5))
-
-  (var fib-knot (struct rec))
-  (= (. fib-knot f)
-     (closure ((self (* (struct rec))) (n int)) int ()
-       (if (< n 2) (return n))
-       (return (+ ((-> self f) self (- n 1))
-                  ((-> self f) self (- n 2))))))
-
-  ;; one combinator, two different recursions
-  (var fac (closure ((int)) int) (fix (& fac-knot)))
-  (var fib (closure ((int)) int) (fix (& fib-knot)))
-  (printf "fac: %d %d\n" (fac 5) (fac 10))
-  (printf "fib: %d %d\n" (fib 10) (fib 20))
-
-  ;; the combinator's result invoked where it is returned, with no
-  ;; intervening `var' -- the receiver's type is the return type of the
-  ;; signature it came from, which is what the name table records
-  (printf "applied on the spot: %d\n" ((fix (& fac-knot)) 5))
-  (return 0))

tests/sex-programs/hello-world.sex

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

tests/sex-programs/inference.sex

@@ -1,178 +0,0 @@
-(input)
-(output "15"
-        "42 0.25"
-        "(5, 7)"
-        "(1, 2)"
-        "3"
-        "(5, 7)"
-        "0 1 4 9 "
-        "4"
-        "42"
-        "<closure of 0: 10>"
-        "42"
-        "2 1"
-        "Hello from Sex!")
-(return 0)
-
-;;; Both halves of inference, from the two sides that read the same
-;;; answers: `_' in a type means "work it out", and `type-of' hands a
-;;; macro the type of an expression.
-;;;
-;;; This was written as a draft before either existed, to be read
-;;; before it was built. It is registered now.
-;;;
-;;; Two features, one mechanism:
-;;;
-;;;   `_' in a type means "work it out", and
-;;;   `type-of' hands a macro the type of an expression.
-;;;
-;;; Both are the same solved constraint store, read from two sides.
-
-(include stdio.h)
-(include string.h)
-
-;;; `(include string.h)' is for the C compiler; it tells Sex nothing.
-;;; A signature has to be written before `_' can be resolved from a
-;;; call to `strlen' -- without one the call's type is `?', and a `_'
-;;; that resolves to `?' is an error, not a silent int.
-(extern fn strlen ((s (* const char))) size-t)
-
-(struct point ((x int) (y int)))
-
-(fn midpoint ((a (* const struct point)) (b (* const struct point))) (struct point)
-  (var m (struct point))
-  ;; No `_' here: `m' has no initializer to infer from. Inference fills
-  ;; in a type, it does not invent one.
-  (= (. m x) (/ (+ (-> a x) (-> b x)) 2))
-  (= (. m y) (/ (+ (-> a y) (-> b y)) 2))
-  (return m))
-
-;;; The closure's type is written once, in the signature; `_' reads it
-;;; from there at every use.
-(fn make-adder ((n int)) (closure ((int)) int)
-  (return (closure ((b int)) int (n)
-            (return (+ n b)))))
-
-;;; A macro that asks what it was handed.
-;;;
-;;; `type-of' returns a *surface* type -- the same spelling the type
-;;; database hands to `map-fields' -- so it composes with the
-;;; `type-match' that already exists, and dispatch over a user struct
-;;; costs nothing extra.
-(defmacro (print x)
-  (type-match (type-of x)
-    (int             `(printf "%d\n" ,x))
-    (size-t          `(printf "%zu\n" ,x))
-    (double          `(printf "%g\n" ,x))
-    ((* const char)  `(printf "%s\n" ,x))
-    ;; NOTE: ,x twice -- a macro that duplicates its argument still has
-    ;; to think about evaluating it twice. Inference does not fix that.
-    ((struct point)  `(printf "(%d, %d)\n" (. ,x x) (. ,x y)))
-    ;; a closure is a type like any other, so it dispatches like one --
-    ;; and `_' saves a clause per signature
-    ((closure _ int) `(printf "<closure of 0: %d>\n" (,x 0)))
-    (else (error "print: don't know how to print" (type-of x)))))
-
-;;; The temporary's type is the thing the macro could not write down
-;;; before. Either spelling works -- `_' is the lazier one, and it is
-;;; inferred in the expansion's own scope.
-(defmacro (swap a b)
-  `(do (var tmp _ ,a)
-       (= ,a ,b)
-       (= ,b tmp)))
-
-(pub fn main () int
-  ;; Written out, for contrast with everything below it.
-  (var greeting (* const char) "Hello from Sex!")
-
-  ;; size-t, from the signature above -- not int, and not a guess.
-  (var n _ (strlen greeting))
-  (printf "%zu\n" n)
-
-  ;; Literals carry a constraint, not a type: the int-ish one defaults
-  ;; to int, and the mixed division joins to double the way C does.
-  (var count _ (+ 20 22))
-  (var half  _ (/ 1.0 4))
-  (printf "%d %g\n" count half)
-
-  ;; An aggregate initializer has no type of its own, so the type flows
-  ;; in and has to be written. `(var origin _ #(3 4))' is an error --
-  ;; there is nothing to infer from.
-  (var origin (struct point) #(3 4))
-  (var corner (struct point) #(7 10))
-
-  ;; A compound literal is the way out of that rule: the `:' is where an
-  ;; initializer stops needing a type from its context, so `_' has
-  ;; something to read after all.
-  (var centre _ #((struct point) : 5 7))
-  (print centre)
-
-  ;; ...and the same designated, which names fields instead of counting
-  ;; positions.
-  (var offset _ #((struct point) : .x 1 .y 2))
-  (print offset)
-
-  ;; A partial type: "a pointer to something". The something arrives
-  ;; from the initializer. This is why the wildcard lives in the type
-  ;; grammar rather than beside it -- it composes.
-  (var p (* _) (& origin))
-
-  ;; Member access reads the same type database the macros do.
-  (var x _ (-> p x))
-  (printf "%d\n" x)
-
-  ;; A call into a function Sex has actually parsed: the return type is
-  ;; the whole answer, and `print' then dispatches on it.
-  (var mid _ (midpoint (& origin) (& corner)))
-  (print mid)
-
-  ;; The loop variable, which is where `_' earns its keep most often.
-  (for (var i _ 0) (< i 4) (++ i)
-       (printf "%d " (* i i)))
-  (printf "\n")
-
-  ;; Four of something: the element type is fixed by the initializer,
-  ;; the count by the type. Subscripting gives the element type back.
-  (var squares [_ 4] #(0 1 4 9))
-  (print [squares 2])
-
-  ;; A closure's type comes from the signature that produced it, and
-  ;; calling one needs that type and nothing else.
-  (var add-10 _ (make-adder 10))
-  (print (add-10 32))
-  (print add-10)
-
-  ;; ...including where it is returned, with no name in between.
-  (print ((make-adder 20) 22))
-
-  ;; A macro writing a declaration it could not have written before.
-  (var a _ 1)
-  (var b _ 2)
-  (swap a b)
-  (printf "%d %d\n" a b)
-
-  (print greeting)
-  (return 0))
-
-;;; Open questions this draft raises, to settle before Layer 2 ships:
-;;;
-;;; 1. SETTLED. `type-match' took `_' on the pattern side, so
-;;;    `(closure _ int)' above is one clause rather than one per
-;;;    signature, and `(* _)' and `(¤ _ _)' say "any pointer" and "any
-;;;    array". A `_' written last takes the rest, since a type's words
-;;;    are spread and not nested: `(* const char)' is three elements.
-;;;    Nothing destructures -- a macro body is Scheme and a type is a
-;;;    list, so `(caddr (type-of x))' reads an array's length.
-;;;
-;;; 2. SETTLED, allowed. `[_ 4]' against `#(0 1 4 9)' unifies each
-;;;    element with the hole, so the element type comes from the
-;;;    literals and the length stays as written -- `[_ 10]' with two
-;;;    initializers is still ten. Elements that disagree are a type
-;;;    mismatch. A bare `_' is still refused: `#(0 1 4 9)' has no type
-;;;    of its own, only elements.
-;;;
-;;; 3. POSTPONED to the standard library design. `(extern fn strlen
-;;;    ...)' above duplicates string.h, which is the same bargain every
-;;;    FFI makes, but it is where "no C header parsing" starts costing
-;;;    the user something. A `sex/libc' module of prototypes is the
-;;;    obvious answer and belongs with the rest of the stdlib.

tests/sex-programs/lambdas.sex

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

tests/sex-programs/list-macros.sex

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

tests/sex-programs/lists.sex

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

tests/sex-programs/operators.sex

@@ -1,90 +0,0 @@
-(input)
-(output "logical: 1 1 0"
-        "bitwise: 7 2 5"
-        "shifts: 48 0 12"
-        "increment: 7"
-        "decayed: 2 2 there"
-        "unsigned wins either way: 4294967295 4294967295"
-        "toplevel: 1 2.5 hi 12"
-        "closure in place: 5"
-        "a type is not a call: 7")
-(return 0)
-
-;;; The walk types an expression by its head, and the heads it had a
-;;; rule for were the ones inference was written against. `&&', the
-;;; bitwise operators, the shifts and `++' were not among them and each
-;;; stopped with `cannot infer'.
-;;;
-;;; The rest of this is the same mistake in three other places: an array
-;;; is a pointer the moment it is an operand, a rank tie is not decided
-;;; by which operand was written first, and `_' is not a local's
-;;; privilege.
-
-(include stdio.h)
-
-(fn area ((w int) (h int)) int
-  (return (* w h)))
-
-;;; a toplevel `_' reads the same table a local's does, so it can name
-;;; anything declared above it
-(var n _ 1)
-(var d _ 2.5)
-(var s _ "hi")
-(var a _ (+ 3 (* 3 3)))
-
-(fn make-adder ((k int)) (closure ((int)) int)
-  (return (closure ((b int)) int (k) (return (+ k b)))))
-
-(pub fn main () int
-  (var x int 6)
-  (var y int 3)
-  (var ok _ (&& x y))
-  (var orr _ (|| x y))
-  (var neg _ (! x))
-  (printf "logical: %d %d %d\n" ok orr neg)
-
-  (var bor _ (| x y))
-  (var band _ (& x y))
-  (var bxor _ (^ x y))
-  (printf "bitwise: %d %d %d\n" bor band bxor)
-
-  ;; a shift is the promoted left operand, not a join: the right one
-  ;; says only how far
-  (var c char 12)
-  (var shl _ (<< x y))
-  (var shr _ (>> x y))
-  (var wide _ (>> c 0))
-  (printf "shifts: %d %d %d\n" shl shr wide)
-
-  ;; ...and an increment is the operand, unpromoted
-  (var inc _ (++ x))
-  (printf "increment: %d\n" inc)
-
-  ;; an array operand decays, so this is a pointer and not an array
-  (var xs (¤ int 4) #(1 2 3 4))
-  (var p _ (+ xs 1))
-  (var q _ (+ 1 xs))
-  (var names (¤ (* const char) 2) #("hi" "there"))
-  (var np _ (+ names 1))
-  (printf "decayed: %d %d %s\n" (* p) (* q) (* np))
-
-  ;; at equal rank C takes the unsigned operand, whichever side it is on
-  (var i int -1)
-  (var u (unsigned int) 1)
-  (var u1 _ (+ i u))
-  (var u2 _ (+ u i))
-  (printf "unsigned wins either way: %u %u\n" (- u1 1) (- u2 1))
-
-  (printf "toplevel: %d %g %s %d\n" n d s a)
-
-  ;; a closure literal is its own type, so it can be called where it is
-  ;; written, the way a lambda already could
-  (printf "closure in place: %d\n"
-          ((closure ((v int)) int () (return v)) 5))
-
-  ;; a `fn' type's parameter list looks exactly like a call; with a
-  ;; closure named `f' in scope it used to be read as one
-  (var f (closure ((int)) int) (make-adder 1))
-  (var fp (fn ((f int) (g int)) int) area)
-  (printf "a type is not a call: %d\n" (f 6))
-  (return 0))

tests/sex-programs/serialize.sex

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

tests/sex-programs/type-shapes.sex

@@ -1,72 +0,0 @@
-(input)
-(output "aggregate element: 3 4"
-        "pointer element: there"
-        "multi-word element: 9"
-        "through a pointer: 55"
-        "unsized of a typedef: 1 2"
-        "unsized of a pointer: 5"
-        "unnamed parameters: 7 -1 2")
-(return 0)
-
-;;; Three questions about a written type that used to be answered in
-;;; three places and disagreed: is `(a b)' a named parameter or a bare
-;;; type, is the last element of a `¤' its bound or the last word of
-;;; its element type, and what is one element of an array.
-;;;
-;;; They are one question -- where does the type end -- so the answer
-;;; lives in `types' and everything else asks it.
-
-(include stdio.h)
-
-(struct point ((x int) (y int)))
-
-(typedef small int)
-
-;;; a parameter that names nothing is a type, however many words it
-;;; takes: `(unsigned int)' is one of them, not a `unsigned' called
-;;; `int'
-(fn width ((n unsigned int)) int
-  (return (cast n int)))
-
-(fn sign ((c const char)) int
-  (if (== c #\a) (return -1))
-  (return 1))
-
-(fn twice ((n small)) int
-  (return (* n 2)))
-
-(pub fn main () int
-  ;; an element keeps every word of its type, tag and all
-  (var pts (¤ (struct point) 2) #(#((struct point) : 1 2)
-                                  #((struct point) : 3 4)))
-  (var p _ (¤ pts 1))
-  (printf "aggregate element: %d %d\n" (. p x) (. p y))
-
-  (var names (¤ (* const char) 2) #("hi" "there"))
-  (var s _ (¤ names 1))
-  (printf "pointer element: %s\n" s)
-
-  (var nums (¤ unsigned int 3) #(7 8 9))
-  (var u _ (¤ nums 2))
-  (printf "multi-word element: %u\n" u)
-
-  ;; subscripting a pointer answers the same as subscripting an array
-  (var q (* (struct point)) (& (¤ pts 0)))
-  (var r _ (¤ q 1))
-  (printf "through a pointer: %d\n" (+ (. r x) (* 13 (. r y))))
-
-  ;; the last word of an unsized array's type is not its bound: neither
-  ;; a typedef name nor the target of a `*' can be one
-  (var tail (¤ const small) #(1 2))
-  (printf "unsized of a typedef: %d %d\n" (¤ tail 0) (¤ tail 1))
-
-  (var one size-t 5)
-  (var sizes (¤ * size-t) #((& one)))
-  (var w _ (¤ sizes 0))
-  (printf "unsized of a pointer: %d\n" (cast (* w) int))
-
-  ;; the same question in type position: `(fn ((unsigned int)) int)'
-  ;; takes one parameter, not two
-  (var fp (fn ((unsigned int)) int) width)
-  (printf "unnamed parameters: %d %d %d\n" (fp 7) (sign #\a) (twice 1))
-  (return 0))

tests/sex-programs/unicode.sex

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

tests/sex-programs/unnamed-params.sex

@@ -1,51 +0,0 @@
-(input)
-(output "one word: 7"
-        "pointer: 2"
-        "aggregate: 3"
-        "array: 2.5"
-        "variadic: 1 two")
-(return 0)
-
-;;; A parameter that names nothing still has to reach the C writer as a
-;;; type and a name, the name being absent. Handed the bare type
-;;; instead, fmt-c read the type's own second word as the name -- so
-;;; `(* const char)' came out `const char', which is a different
-;;; function -- and a one-word type had no second word to read at all.
-
-(include stdio.h)
-(include stdarg.h)
-
-(struct point ((x int) (y int)))
-
-;;; declared here rather than included, so the prototype we emit is the
-;;; one the C compiler checks the call against
-(extern fn abs ((int)) int)
-(extern fn strlen ((* const char)) size-t)
-
-(fn origin-x ((p (* (struct point)))) int
-  (return (. (* p) x)))
-
-(fn second-of ((xs (¤ float 4))) float
-  (return (¤ xs 1)))
-
-(fn say ((fmt (* const char)) ...) void
-  (var ap va-list)
-  (va-start ap fmt)
-  (vprintf fmt ap)
-  (va-end ap))
-
-(pub fn main () int
-  (printf "one word: %d\n" (abs -7))
-  (printf "pointer: %d\n" (cast (strlen "hi") int))
-
-  ;; the same parameter lists written as types
-  (var p (struct point) #((struct point) : 3 4))
-  (var f (fn ((* (struct point))) int) origin-x)
-  (printf "aggregate: %d\n" (f (& p)))
-
-  (var xs (¤ float 4) #(1.5 2.5 3.5 4.5))
-  (var g (fn ((¤ float 4)) float) second-of)
-  (printf "array: %g\n" (g xs))
-
-  (say "variadic: %d %s\n" 1 "two")
-  (return 0))

tests/sex-programs/wildcards.sex

@@ -1,109 +0,0 @@
-(input)
-(output "literals: 42 3.5 hello"
-        "calls: 12"
-        "members: 1 2.5"
-        "pointers: 1 2.5"
-        "arrays: 30"
-        "loop: 0 1 2"
-        "shadowed: 9 then 42"
-        "still an int: 200"
-        "partial: 1 2.5"
-        "joined: 43.5 84 49 1"
-        "promoted: 200 60000 3705032704"
-        "from elements: 4 9 0")
-(return 0)
-
-;;; `_' as a type means "work it out from the initializer". What the
-;;; pass can answer comes from declarations -- Sex writes a type at
-;;; every binding site -- and from the signature of whatever a call
-;;; names. A partial type like `(* _)' is solved by unifying what was
-;;; written against what the initializer gives, so only the wildcard
-;;; inside the spelling is filled in.
-
-(include stdio.h)
-
-(struct point ((x int) (y float)))
-
-(fn area ((w int) (h int)) int
-  (return (* w h)))
-
-(pub fn main () int
-  (var n _ 42)
-  (var f _ 3.5)
-  (var s _ "hello")
-  (printf "literals: %d %g %s\n" n f s)
-
-  (var a _ (area 3 4))
-  (printf "calls: %d\n" a)
-
-  (var p (struct point) #((struct point) : .x 1 .y 2.5))
-  (var px _ (. p x))
-  (var py _ (. p y))
-  (printf "members: %d %g\n" px py)
-
-  (var pp _ (& p))
-  (printf "pointers: %d %g\n" (-> pp x) (-> pp y))
-
-  (var table (¤ int 3))
-  (= (¤ table 0) 10)
-  (= (¤ table 1) 20)
-  (var first _ (¤ table 0))
-  (var second _ (¤ table 1))
-  (printf "arrays: %d\n" (+ first second))
-
-  ;; a for opens a scope, and its initializer is declared inside it
-  (printf "loop:")
-  (for (var i _ 0) (< i 3) (++ i)
-       (printf " %d" i))
-  (printf "\n")
-
-  ;; a block's declarations end with it, and so do the declarations of
-  ;; everything else C brackets -- a `while' body is a block with no
-  ;; `do' written around it
-  (do (var n _ 9)
-      (printf "shadowed: %d then " n))
-  (printf "%d\n" n)
-
-  (var wide int 200)
-  (while false (var wide char 1) (printf "%d" wide))
-  (if false (do (var wide char 1) (printf "%d" wide)))
-  ;; a statement before the declaration: a label may not be followed by
-  ;; one until C23
-  (switch a (case 1 (printf "") (var wide char 1) (printf "%d" wide) (break)))
-  ;; a copy, not a sum: an arithmetic result would be promoted to `int'
-  ;; whatever leaked, and say nothing
-  (var copy _ wide)
-  (printf "still an int: %d\n" copy)
-
-  ;; a wildcard inside a written type: only it is solved
-  (var pp2 (* _) (& p))
-  (printf "partial: %d %g\n" (-> pp2 x) (-> pp2 y))
-
-  ;; C's usual arithmetic conversions, far enough to answer `_'
-  (var d double 1.5)
-  (var l long 7)
-  (var g float 0.5)
-  (var mixed _ (+ n d))
-  (var same _ (+ n n))
-  (var wider _ (+ n l))
-  (var single _ (+ g g))
-  (printf "joined: %g %d %ld %g\n" mixed same wider single)
-
-  ;; ...including the promotions, which two operands of one narrow type
-  ;; are exactly where they show: `char' + `char' is an `int'
-  (var c1 char 100)
-  (var c2 char 100)
-  (var h1 short 30000)
-  (var narrow _ (+ c1 c2))
-  (var narrower _ (+ h1 h1))
-  (var kept (unsigned int) 4000000000)
-  (var unpromoted _ (+ kept kept))
-  (printf "promoted: %d %d %u\n" narrow narrower unpromoted)
-
-  ;; a brace initializer has no type of its own, but its elements solve
-  ;; the hole in the array type around it -- and the length stays as
-  ;; written, whether or not every slot is initialized
-  (var squares (¤ _ 4) #(0 1 4 9))
-  (var sparse (¤ _ 8) #(0 1))
-  (printf "from elements: %d %d %d\n" (¤ squares 2) (¤ squares 3) (¤ sparse 7))
-  (return 0))

tests/sexc.module.scm

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

tests/types.module.scm

@@ -1,28 +0,0 @@
-(module types
-    (add-struct
-     add-union
-     add-enum
-     add-typedef
-     add-define
-
-     type-match
-     type-pattern-matches?
-     map-fields
-
-     add-name-type!
-     get-name-type
-     type-of
-     current-type-of
-     get-return-type
-
-     get-type-info
-     get-tag-info
-     get-fields
-     get-underlying-type
-
-     type-head?
-     named-arg?
-     typedef-name?
-     array-bound?
-     array-element-type)
-  "../types.scm")

tests/types.scm

@@ -1,220 +0,0 @@
-;;; The type database.
-;;;
-;;; Names here are prefixed so they cannot collide with the types the
-;;; other suites register: the database is one table in the linked
-;;; binary, and semen fills it in whenever a suite compiles a struct.
-
-(import types)
-
-(test-group "types"
-
-  (add-struct 't-point '(struct t-point ((x int) (y int))))
-  (test "fields come back as (name type)"
-        '((x int) (y int))
-        (get-fields 't-point))
-  (test "and the whole entry is tagged"
-        '(struct t-point ((x int) (y int)))
-        (get-type-info 't-point))
-
-  ;; Fields are written with the type last, so one entry can declare
-  ;; several names. They come back as one field each.
-  (add-struct 't-settings
-              '(pub struct t-settings ((x y w h u32) (title (* const char)))))
-  (test "names sharing a type are split apart"
-        '((x u32) (y u32) (w u32) (h u32) (title (* const char)))
-        (get-fields 't-settings))
-
-  (add-struct 't-commented '(struct t-commented ((comment " hi") (a int))))
-  (test "a comment among the fields is not a field"
-        '((a int))
-        (get-fields 't-commented))
-
-  (add-union 't-value '(union t-value ((i int) (f float))))
-  (test "unions have fields too"
-        '((i int) (f float))
-        (get-fields 't-value))
-
-  (add-enum 't-color '(enum t-color (red green blue)))
-  (test "enums keep their values"
-        '(enum t-color (red green blue))
-        (get-type-info 't-color))
-  (test "but have no fields"
-        #f
-        (get-fields 't-color))
-
-  (add-typedef 't-u8 '(typedef t-u8 uint8-t))
-  (test "a typedef resolves to its target"
-        'uint8-t
-        (get-underlying-type 't-u8))
-  (add-typedef 't-byte '(typedef t-byte t-u8))
-  (test "and chains are followed to the end"
-        'uint8-t
-        (get-underlying-type 't-byte))
-  (test "a struct is not a typedef"
-        #f
-        (get-underlying-type 't-point))
-
-  ;; Reflection through an alias. Both spellings of the target occur:
-  ;; (typedef point-t point) and (typedef point-t (struct point)).
-  (add-typedef 't-point-t '(typedef t-point-t t-point))
-  (test "a typedef to a struct has the struct's fields"
-        '((x int) (y int))
-        (get-fields 't-point-t))
-  (add-typedef 't-point-s '(typedef t-point-s (struct t-point)))
-  (test "written the other way round too"
-        '((x int) (y int))
-        (get-fields 't-point-s))
-  (add-typedef 't-point-2 '(typedef t-point-2 t-point-t))
-  (test "and through a chain of them"
-        '((x int) (y int))
-        (get-fields 't-point-2))
-  (test "map-fields follows an alias as well"
-        '((x int) (y int))
-        (map-fields 't-point-t (lambda (name type) (list name type))))
-  (add-typedef 't-color-t '(typedef t-color-t t-color))
-  (test "an aliased enum is still named as it was declared"
-        '((red (enum t-color)) (green (enum t-color)) (blue (enum t-color)))
-        (map-fields 't-color-t (lambda (name type) (list name type))))
-  (test "a typedef to a primitive has no fields"
-        #f
-        (get-fields 't-u8))
-
-  ;; C keeps typedefs and ordinary identifiers apart, and the canonical way
-  ;; to declare a struct uses both names at once. Neither declaration
-  ;; may stand on the other.
-  (add-struct 't-node '(struct t-node ((next (* t-node)) (v int))))
-  (add-typedef 't-node '(typedef t-node (struct t-node)))
-  (test "a typedef of a struct's own name keeps the struct reachable"
-        '((next (* t-node)) (v int))
-        (get-fields 't-node))
-  (test "and the tag is there under its own name"
-        '(struct t-node ((next (* t-node)) (v int)))
-        (get-tag-info 't-node))
-  (add-struct 't-rect '(struct t-rect ((w int) (h int))))
-  (add-define 't-rect '(define t-rect 3))
-  (test "a define of a tag's name does not hide the fields"
-        '((w int) (h int))
-        (get-fields 't-rect))
-
-  ;; A type built over a struct is not that struct. Handing back the
-  ;; element's fields would have a macro write v->x for an array
-  (add-typedef 't-points '(typedef t-points (¤ t-point 4)))
-  (test "an array of a struct has no fields of its own"
-        #f
-        (get-fields 't-points))
-  (add-typedef 't-point-p '(typedef t-point-p (* t-point)))
-  (test "nor does a pointer to one"
-        #f
-        (get-fields 't-point-p))
-  (add-typedef 't-cb '(typedef t-cb (fn ((t-point)) void)))
-  (test "nor a function type over one"
-        #f
-        (get-fields 't-cb))
-
-  ;; A typedef can be written to lead back to itself. Resolving it must
-  ;; stop rather than spin
-  (add-typedef 't-loop-a '(typedef t-loop-a t-loop-b))
-  (add-typedef 't-loop-b '(typedef t-loop-b t-loop-a))
-  (test "a typedef cycle terminates"
-        't-loop-a
-        (get-underlying-type 't-loop-a))
-  (test "and has no fields"
-        #f
-        (get-fields 't-loop-a))
-
-  ;; A #define keeps its value forms -- there can be more than one.
-  (add-define 't-maxn '(define t-maxn 8))
-  (test "defines are recorded"
-        '(define t-maxn (8))
-        (get-type-info 't-maxn))
-
-  ;; map-fields walks an aggregate, handing each field to a function.
-  (test "map-fields visits every field"
-        '((x int) (y int))
-        (map-fields 't-point (lambda (name type) (list name type))))
-  (test "and splits shared names apart too"
-        '(x y w h title)
-        (map-fields 't-settings (lambda (name type) name)))
-  ;; An enumerator's type is the enum itself.
-  (test "enum values are fields whose type is the enum"
-        '((red (enum t-color)) (green (enum t-color)) (blue (enum t-color)))
-        (map-fields 't-color (lambda (name type) (list name type))))
-  (test "a typedef has no fields to map"
-        #f
-        (map-fields 't-u8 (lambda (name type) name)))
-  (test "nor does an undeclared name"
-        #f
-        (map-fields 't-nothing (lambda (name type) name)))
-
-  ;; type-match compares whole types, since a type is a form.
-  (test "a bare type matches"      'yes (type-match 'int (int 'yes) (else 'no)))
-  (test "so does a compound one"   'yes (type-match '(* const char)
-                                                    (int 'no)
-                                                    ((* const char) 'yes)
-                                                    (else 'no)))
-  ;; The [int 10] of the docstring is Sex notation: the Sex reader turns
-  ;; brackets into a ¤ form, while CHICKEN reads them as plain parens.
-  ;; In a .scm file the array type has to be written out.
-  (test "and an array"             'yes (type-match '(¤ int 10)
-                                                    ((¤ int 10) 'yes)
-                                                    (else 'no)))
-  (test "else catches the rest"    'no  (type-match '(* void) (int 'yes) (else 'no)))
-  (test "a near miss does not match" 'no (type-match '(¤ int 20)
-                                                     ((¤ int 10) 'yes)
-                                                     (else 'no)))
-  (test "no clause matching and no else is #f"
-        #f
-        (type-match 'float (int 'yes)))
-
-  ;; `_' in a pattern matches anything in that position; written last it
-  ;; takes the rest, since a type's words are spread and not nested
-  (test "a wildcard matches an atom"
-        'yes (type-match 'int (_ 'yes) (else 'no)))
-  (test "a pointer to anything"
-        'yes (type-match '(* int) ((* _) 'yes) (else 'no)))
-  (test "including one spelled with qualifiers"
-        'yes (type-match '(* const char) ((* _) 'yes) (else 'no)))
-  (test "an array of anything, any length"
-        'yes (type-match '(¤ int 4) ((¤ _ _) 'yes) (else 'no)))
-  (test "but a sized pattern does not match an unsized array"
-        'no (type-match '(¤ int) ((¤ _ _) 'yes) (else 'no)))
-  (test "an aggregate of any tag"
-        'yes (type-match '(struct point) ((struct _) 'yes) (else 'no)))
-  (test "and the keyword still has to agree"
-        'no (type-match '(union point) ((struct _) 'yes) (else 'no)))
-  (test "a closure of any signature"
-        'yes (type-match '(closure ((float)) int) ((closure _ _) 'yes) (else 'no)))
-  (test "an exact pattern is still exact"
-        'no (type-match '(* int) ((* const char) 'yes) (else 'no)))
-
-  (test "an undeclared name has no entry"
-        #f
-        (get-type-info 't-never-declared))
-  (test "and no fields"
-        #f
-        (get-fields 't-never-declared))
-
-  ;; What type a *name* has -- the third table, which functions and
-  ;; variables share because a function type has a surface spelling
-  (add-name-type! 't-sum '(fn ((int) (int)) int))
-  (add-name-type! 't-origin '(struct t-point))
-  (test "a function's signature comes back whole"
-        '(fn ((int) (int)) int)
-        (get-name-type 't-sum))
-  (test "and a variable's type"
-        '(struct t-point)
-        (get-name-type 't-origin))
-  (test "the return type is what a call site wants"
-        'int
-        (get-return-type 't-sum))
-  (test "a variable has no return type"
-        #f
-        (get-return-type 't-origin))
-  ;; not an error: this is how a name from an included C header looks,
-  ;; and the caller decides what to make of it
-  (test "an undeclared name has no type"
-        #f
-        (get-name-type 't-never-declared))
-  (test "nor a return type"
-        #f
-        (get-return-type 't-never-declared)))

tests/utils.module.scm

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

tests/utils.scm

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

tools/sextest/Makefile

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

tools/sextest/README.org

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

tools/sextest/hello-sextest.sex

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

tools/sextest/reader.module.scm

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

tools/sextest/sextest.scm

@@ -1,199 +0,0 @@
-(import scheme
-        (scheme base)                   ; let-values
-        brev-separate
-        (chicken base)
-        (chicken file)
-        (chicken io)
-        (chicken pathname)
-        (chicken port)
-        (chicken process)
-        (chicken process-context)
-        (chicken string)                ; string-split
-        fmt
-        getopt-long
-        reader                          ; read-raw-forms, shared with sexc
-        srfi-1
-        srfi-13)                        ; string-prefix?
-
-(define (print-help)
-  (fmt #t "Usage: sextest [options] filename" nl
-       "Options:" nl
-       (usage opts-grammar) nl))
-
-(define (split-settings contents)
-  (foldl (lambda (acc elt)
-           (case (car elt)
-             ((compilation input output return)
-              (cons
-               (append (car acc) (list elt))
-               (cdr acc)))
-             (else
-              (cons
-               (car acc)
-               (append (cdr acc) (list elt))))))
-         (cons (list) (list))
-         contents))
-
-;;; The feature flags of the (compilation ...) form, which we have to
-;;; honour ourselves: the program is read here and printed back out for
-;;; sexc, so #+ and #- are resolved on this side.
-;;;
-;;; Returns the named features and whether the host's own are in play
-(define (compilation-features settings)
-  (let ((compilation (assoc 'compilation settings)))
-    (let loop ((flags (if compilation
-                          (string-split (cadr compilation))
-                          (list)))
-               (features (list))
-               (platform #t))
-      (define (add names rest)
-        (loop rest
-              (append features (map string->symbol (string-split names ",")))
-              platform))
-      (cond
-       ((null? flags) (values features platform))
-       ;; past `--' the flags are the C compiler's
-       ((string=? (car flags) "--") (values features platform))
-       ((string=? (car flags) "--no-platform-features")
-        (loop (cdr flags) features #f))
-       ((and (member (car flags) '("-f" "--features")) (pair? (cdr flags)))
-        (add (cadr flags) (cddr flags)))
-       ((string-prefix? "--features=" (car flags))
-        (add (substring (car flags) 11) (cdr flags)))
-       ((string-prefix? "-f" (car flags))
-        (add (substring (car flags) 2) (cdr flags)))
-       (else (loop (cdr flags) features platform))))))
-
-(define (process-file target-path)
-  (let ((first-pass (split-settings (read-raw-forms target-path))))
-    (let-values (((features platform?) (compilation-features (car first-pass))))
-      (if (and (null? features) platform?)
-          first-pass
-          (parameterize ((current-features
-                          (append (if platform? (platform-features) (list))
-                                  features)))
-            (split-settings (read-raw-forms target-path)))))))
-
-(define (compile src compilation sexc)
-  (let ((compiler (or
-                   (and sexc (cdr sexc))
-                   (get-environment-variable "SEXC")
-                   "sexc"))
-        ;; (compilation "--features=x -- -O2") -- one string
-        (flags (if compilation
-                   (string-split (cadr compilation))
-                   (list)))
-        (compiled-file (create-temporary-file)))
-    ;; `process' returns one record; `process-input-port' is named from
-    ;; the child's side, so it is the port we write to.
-    ;;
-    ;; Sex reads no symbol escaping -- `|' is an operator there. Left
-    ;; on, `(|| a b)' leaves here as `(|\|\|| a b)' and reaches sexc
-    ;; as a different symbol.
-    (let* ((proc (process compiler (append (list "-o" compiled-file) flags)))
-           (sexc-stdin (process-input-port proc)))
-      (symbol-escape #f)
-      (with-output-to-port sexc-stdin
-        (fn (map (fn (fmt #t x)) src)))
-      (close-output-port sexc-stdin)
-      (call-with-values
-          (fn (process-wait proc))
-        (lambda (pid exited retcode)
-          (if (= 0 retcode)
-              compiled-file
-              #f))))))
-
-(define (run-and-check file in out ret)
-  (let* ((proc (process file))
-         (out-port (process-output-port proc))   ; the program's stdout
-         (in-port  (process-input-port proc)))   ; the program's stdin
-    (let ()
-      (when in
-        (with-output-to-port in-port
-          (fn (map (fn (fmt #t x))
-                   (cdr in))))
-        (close-output-port in-port))
-      (let ((out-lines
-             (with-input-from-port out-port
-               (fn
-                (let loop ((line (read-line))
-                           (lines (list)))
-                  (if (eof-object? line)
-                      (reverse lines)
-                      (loop (read-line)
-                            (cons line lines)))))))
-            (ret-code
-             (call-with-values
-                 ;; TODO: what if the program hangs
-                 ;; we need some kind of timeout mechanism
-                 (fn
-                  (process-wait proc))
-               (lambda (pid exited retcode)
-                 retcode))))
-        (and
-         (if (not (= ret-code (cadr ret)))
-             (begin
-               (fmt #t "Retcode differs. Got " ret-code ", expected " (cadr ret) nl)
-               #f)
-             #t)
-
-         (if (not (equal? out-lines (cdr out)))
-             (begin
-               (fmt #t "Output differs. Got " out-lines " expected " (cdr out) nl)
-               #f)
-             #t))))))
-
-(define opts-grammar
-  `((sexc ,(fmt #f "Path to sexc compiler. Defaults to value of SEXC" nl
-                (pad 26) "environment variable, ot if it's empty, to sexc" nl )
-          (required #f)
-          (value #t))
-    (help "Show this help"
-          (required #f)
-          (value #f)
-          (single-char #\h))))
-
-(define (process-test-file sexc path)
-  (set-environment-variable! "SEX_MODULE_PATH"
-                             (normalize-pathname (make-absolute-pathname
-                                                  (current-directory)
-                                                  (pathname-directory path))))
-  (let* ((settings-and-src (process-file path))
-         (settings (car settings-and-src))
-         (src (cdr settings-and-src))
-         (compiled-file (compile src (assoc 'compilation settings) sexc)))
-    (if (not compiled-file)
-        (begin (fmt #t "Failed to compile " path nl)
-               #f)
-        (if (run-and-check
-             compiled-file
-             (assoc 'input settings)
-             (assoc 'output settings)
-             (assoc 'return settings))
-            (begin (fmt #t ".")
-                   #t)
-            (begin (fmt #t ",")
-                   #f)))))
-
-(define (main)
-  (let ((args (getopt-long (command-line-arguments)
-                           opts-grammar)))
-    (when (assoc 'help args)
-      (print-help)
-      (exit 0))
-    (when (null? (cdr (assoc '@ args)))
-      (fmt #t "Missing target file" nl)
-      (print-help)
-      (exit 1))
-    (unless
-        (foldl (lambda (a b) (and a b))
-               #t
-               (map (fn (process-test-file (assoc 'sexc args) x))
-                    (cdr (assoc '@ args))))
-      ;; TODO: add more verbose and human readable output and reporting
-      (fmt #t nl)
-      (exit 2))
-    (fmt #t nl)
-    (exit 0)))
-
-(main)

tools/sextest/utils.module.scm

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

types.module.scm

@@ -1,28 +0,0 @@
-(module types
-    (add-struct
-     add-union
-     add-enum
-     add-typedef
-     add-define
-
-     type-match
-     type-pattern-matches?
-     map-fields
-
-     add-name-type!
-     get-name-type
-     type-of
-     current-type-of
-     get-return-type
-
-     get-type-info
-     get-tag-info
-     get-fields
-     get-underlying-type
-
-     type-head?
-     named-arg?
-     typedef-name?
-     array-bound?
-     array-element-type)
-    "types.scm")

types.scm

@@ -1,315 +0,0 @@
-;;; The type database.
-;;;
-;;; Every named aggregate, typedef and define the semantic engine
-;;; walks past is recorded here, so that macros (or other forms) can
-;;; ask what a type is made of. That is what lets a macro generate
-;;; code from a struct's fields given nothing but its name.
-;;;
-;;; Entries are filled in as toplevel forms are processed, in order, so
-;;; a type has to be declared before the macro that asks about it.
-
-(import
-  scheme
-  (scheme base)
-  (chicken base)
-  srfi-1
-  srfi-69)
-
-;;; Two namespaces: `struct point' and a `point' typedef are separate
-;;; declarations. Tags -- struct, union and enum alike -- share the
-;;; second table between them
-(define +type-db+ (make-hash-table))    ; typedefs and defines
-(define +tag-db+ (make-hash-table))     ; struct, union and enums
-
-;;; What type a *name* has, which neither of the two above records:
-;;;
-;;;   (fn sum ((a int) (b int)) int ...) -> (fn ((int) (int)) int)
-;;;   (var origin (struct point) ...)    -> (struct point)
-(define +name-db+ (make-hash-table))
-
-(define (strip-pub form)
-  (if (eq? (car form) 'pub) (cdr form) form))
-
-(define (comment-form? f)
-  (and (pair? f) (eq? (car f) 'comment)))
-
-;;; Fields are written with the type last and one or more names before
-;;; it, so ((x y int) (p (* char))) describes three fields. Flatten that
-;;; into one (name type) per field, which is what a caller wants.
-(define (normalize-fields fields)
-  (append-map
-   (lambda (field)
-     (if (comment-form? field)
-         (list)
-         (let ((type (last field))
-               (names (drop-right field 1)))
-           (map (lambda (name) (list name type)) names))))
-   (remove comment-form? fields)))
-
-;;; ([pub] struct name (fields ...) . attrs)
-(define (aggregate-fields form)
-  (let ((f (strip-pub form)))
-    (if (and (pair? (cddr f)) (list? (caddr f)))
-        (caddr f)
-        (list))))
-
-(define (add-struct name form)
-  (hash-table-set! +tag-db+ name
-                   (list 'struct name (normalize-fields (aggregate-fields form)))))
-
-(define (add-union name form)
-  (hash-table-set! +tag-db+ name
-                   (list 'union name (normalize-fields (aggregate-fields form)))))
-
-;;; ([pub] enum name (value ...))
-(define (add-enum name form)
-  (let ((f (strip-pub form)))
-    (hash-table-set! +tag-db+ name
-                     (list 'enum name (if (and (pair? (cddr f)) (list? (caddr f)))
-                                          (caddr f)
-                                          (list))))))
-
-;;; ([pub] typedef new-name target)
-(define (add-typedef name form)
-  (hash-table-set! +type-db+ name
-                   (list 'typedef name (last (strip-pub form)))))
-
-;;; (define name value ...) -- a C #define, kept so a macro can read a
-;;; compile-time constant rather than re-parse the source.
-(define (add-define name form)
-  (hash-table-set! +type-db+ name
-                   (list 'define name (cddr (strip-pub form)))))
-
-;;; `(type-of x)' inside a macro body: the type of the expression the
-;;; macro was handed, where `get-name-type' only answers for a name.
-;;; The walker that can answer it lives in `semen', which is compiled
-;;; after this, so it installs itself here for the length of one
-;;; expansion. Outside one there is no scope to ask about, and the
-;;; answer is #f.
-(define current-type-of (make-parameter (lambda (form) #f)))
-
-(define (type-of form) ((current-type-of) form))
-
-(define (add-name-type! name type)
-  (hash-table-set! +name-db+ name type))
-
-;;; #f for a name never declared, which is what `printf' looks like
-;;; until something parses stdio.h. Not an error here; the caller
-;;; decides.
-(define (get-name-type name)
-  (hash-table-ref/default +name-db+ name #f))
-
-;;; What `(make-adder 10)' has for a type: `make-adder's return type,
-;;; or #f when NAME is not a function with a signature on record
-(define (get-return-type name)
-  (let ((type (get-name-type name)))
-    (and (pair? type)
-         (eq? 'fn (car type))
-         (= 3 (length type))
-         (third type))))
-
-(define (get-tag-info name)
-  (hash-table-ref/default +tag-db+ name #f))
-
-;;; First look up the ordinary identifier, then tag of that id when
-;;; no ordinary one was declared, as C does
-(define (get-type-info name)
-  (or (hash-table-ref/default +type-db+ name #f)
-      (get-tag-info name)))
-
-;;; ((name type) ...) for a struct or union, #f for anything else --
-;;; including a name that was never declared. Callers give the better
-;;; error, since they know what they wanted it for.
-;;;
-;;; A typedef is followed to what it stands for, so reflection over an
-;;; alias works exactly as it does over the name it aliases.
-(define (get-fields name)
-  (let ((info (resolve-type-info name)))
-    (and info
-         (memq (car info) '(struct union))
-         (caddr info))))
-
-;;; Follow a typedef chain to the name it stands for. #f if NAME is
-;;; not a typedef. A typedef that leads back to itself stops rather
-;;; than spinning: nothing prevents one from being written.
-(define (get-underlying-type name)
-  (let follow ((name name) (seen (list)))
-    (and (not (member name seen))
-         (let ((info (get-type-info name)))
-           (and info
-                (eq? (car info) 'typedef)
-                (let ((target (caddr info)))
-                  (or (and (symbol? target) (follow target (cons name seen)))
-                      target)))))))
-
-;;; The declaration NAME ultimately names. For a typedef that is the
-;;; entry of whatever it stands for, and for anything else it is
-;;; NAME's own info
-(define (target-tag target)
-  (cond
-   ((symbol? target) target)
-   ((and (pair? target)
-         (memq (car target) '(struct union enum))
-         (pair? (cdr target))
-         (symbol? (cadr target)))
-    (cadr target))
-   (else #f)))
-
-(define (resolve-type-info name)
-  (let ((info (resolve-ordinary-type-info name)))
-    (if (and info (memq (car info) '(struct union enum)))
-        info
-        (or (get-tag-info name) info))))
-
-(define (resolve-ordinary-type-info name)
-  (let ((info (get-type-info name)))
-    (and info
-         (if (eq? (car info) 'typedef)
-             (let ((tag (target-tag (get-underlying-type name))))
-               ;; A typedef target is written in type position, where
-               ;; `struct point' means the tag
-               (and tag (or (get-tag-info tag) (get-type-info tag))))
-             info))))
-
-;;; Type matcher macro
-;;; (type-match type
-;;;   (int ...)
-;;;   ((* const char) ...)
-;;;   ([int 10] ...)
-;;;   ((* _) ...)                     ; a pointer to anything
-;;;   ((¤ _ _) ...)                   ; an array of anything, any length
-;;;   (else ...))
-;;;
-;;; A type is a form, not an atom, so patterns are matched structurally
-;;; rather than dispatched on like `case'. They are literal types and
-;;; are not evaluated; `else' is optional and the whole thing is #f when
-;;; nothing matches and there is no else.
-;;;
-;;; `_' in a pattern matches anything in that position, the same thing
-;;; it means in a type. Without it every spelling has to be enumerated:
-;;; `(closure ((int)) int)' and `(closure ((float)) int)' are separate
-;;; clauses for what is one case.
-;;;
-;;; A `_' written last takes everything that remains, because a type's
-;;; words are spread rather than nested -- `(* const char)' is three
-;;; elements, so `(* _)' has to cover two of them to mean "a pointer to
-;;; anything".
-;;;
-;;; Nothing destructures: a macro body is ordinary Scheme and a type is
-;;; a list, so `(caddr (type-of x))' already reads the length out of
-;;; `(¤ int 4)'.
-(define-syntax type-match
-  (syntax-rules (else)
-    ((_ type) #f)
-    ((_ type (else body ...)) (begin body ...))
-    ((_ type (pattern body ...) clause ...)
-     (if (type-pattern-matches? 'pattern type)
-         (begin body ...)
-         (type-match type clause ...)))))
-
-(define (type-pattern-matches? pattern type)
-  (cond
-   ((eq? pattern '_) #t)
-   ((and (pair? pattern) (pair? type))
-    (if (and (eq? (car pattern) '_) (null? (cdr pattern)))
-        #t                              ; a trailing `_' takes the rest
-        (and (type-pattern-matches? (car pattern) (car type))
-             (type-pattern-matches? (cdr pattern) (cdr type)))))
-   (else (equal? pattern type))))
-
-;;; Map function to each field/value of a structure/union/enum
-;;; For enums, field-type is the type of the enum (since C 23)
-;;; (map-fields type-name
-;;;     (lambda (field-name field-type) ...))
-;;;
-;;; Returns #f if nothing of that name was declared
-(define (map-fields struct-union-enum fn)
-  (let ((info (resolve-type-info struct-union-enum)))
-    (and info
-         (case (car info)
-           ((struct union)
-            (map (lambda (field) (fn (car field) (cadr field)))
-                 (caddr info)))
-           ;; An enumerator's type is the enum itself -- named as it was
-           ;; declared, since `enum some-typedef' is not a C type.
-           ((enum)
-            (let ((type (list 'enum (cadr info))))
-              (map (lambda (value) (fn value type))
-                   (caddr info))))
-           (else #f)))))
-
-;;; The shape of a written type
-;;;
-;;; Where a type ends, asked by an arglist and by an array bound:
-;;;
-;;;   (f1 float)      a name and a type    (unsigned int)  a type
-;;;   (¤ int 4)       four of int          (¤ const t)     unsized, of const t
-;;;   (¤ mytype N)    N of mytype          (¤ * size-t)    unsized, of (* size-t)
-
-;;; A qualifier cannot end a type: `(¤ const t)' is unsized, `(¤ int 4)'
-;;; is four of int.
-(define +c-qualifiers+ '(const volatile restrict _Atomic))
-
-(define +c-specifiers+
-  '(void char short int long float double signed unsigned
-    bool _Bool complex _Complex))
-
-;;; Does this list start a type rather than name one? `(const char)'
-;;; and `(unsigned int)' are types; `(f1 float)' is a named parameter.
-(define (type-head? form)
-  (and (pair? form)
-       (symbol? (car form))
-       (or (memq (car form) '(* ¤ struct union enum))
-           (memq (car form) +c-qualifiers+)
-           (memq (car form) +c-specifiers+))))
-
-;;; Does the parameter name itself?
-;;; (f1 float) does
-;;; (float), (const char), (unsigned int) and (¤ float 4) do not
-(define (named-arg? arg)
-  (and (pair? arg)
-       (pair? (cdr arg))                ; 1 element args are always type
-       (not (type-head? arg))))
-
-;;; A typedef and a `define' share +type-db+; only the typedef is part
-;;; of a type:
-;;;
-;;;   (typedef small int)  ->  (¤ small N) is N of small
-;;;   (define CAP 4)       ->  (¤ int CAP) is CAP of int
-(define (typedef-name? name)
-  (let ((info (and (symbol? name) (get-type-info name))))
-    (and info (memq (car info) '(typedef struct union enum)) #t)))
-
-;;; The last element is a bound only where what precedes it already
-;;; spells a whole type -- a specifier, a tag after its keyword, or a
-;;; typedef we have seen declared:
-;;;
-;;;   (¤ int 4)         four of int        (¤ unsigned int)  unsized
-;;;   (¤ mytype CAP)    CAP of mytype      (¤ struct point)  unsized
-;;;   (¤ const mytype)  unsized            (¤ * size-t)      unsized
-;;;
-;;; TYPE is the whole `(¤ ...)' form.
-(define (array-bound? type)
-  (and (> (length type) 2)
-       (let ((bound (last type))
-             (preceding (last (drop-right type 1))))
-         (cond
-          ((not (symbol? bound)) #t)
-          ((or (memq bound +c-specifiers+) (memq bound +c-qualifiers+)) #f)
-          ((memq preceding +c-specifiers+) #t)
-          ;; a tag always follows its keyword, so `(¤ * struct tt)' ends
-          ;; in a name belonging to the type
-          ((memq preceding '(struct union enum)) #f)
-          (else (typedef-name? preceding))))))
-
-;;; What one element of a written array type is:
-;;; (¤ struct point 2) -> (struct point), (¤ * const char 2) -> (* const char)
-(define (array-element-type type)
-  (and (pair? type)
-       (eq? '¤ (car type))
-       (pair? (cdr type))
-       (let ((words (if (array-bound? type)
-                        (drop-right (cdr type) 1)
-                        (cdr type))))
-         (and (pair? words)
-              (if (null? (cdr words)) (car words) words)))))

utils.module.scm

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

utils.scm

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