generate temp .c files instead of passing to compiler's stdin

For a clearer architecture

.gitea/workflows/build.yaml

@@ -1,65 +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
-
-      # Eggs are pinned in eggs.lock and installed by the Makefile into .eggs/.
-      - name: Build sexc
-        run: make && ./sexc --help
-
-      - name: Run tests
-        run: make check

.github/workflows/build.yaml

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

.gitignore

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

Makefile

@@ -1,6 +1,4 @@
-CHICKEN_C ?= csc
+CHICKEN_C = csc
-CHICKEN_INSTALL ?= chicken-install
-CHICKEN_STATUS ?= chicken-status
 CSC_FLAGS += -K prefix -static
 # What and why:
 # -emit-all-import-libraries: Emit import-libraries for all defined modules.
@@ -14,44 +12,17 @@ CSC_FLAGS += -K prefix -static
 #     error.
 # -c: Stop after compilation to object files. This one is obvious.
 
-# GNU directory variables. Command line overrides, e.g.
-#   make prefix=$(HOME)/.local install
-#   make DESTDIR=/tmp/stage prefix=/usr install
-prefix = /usr/local
-exec_prefix = $(prefix)
-bindir = $(exec_prefix)/bin
-INSTALL = install
-INSTALL_PROGRAM = $(INSTALL)
-
 MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
 
 # Order matters, since module check correctness on compilation
 MODULES = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
 OBJ = $(MODULES:%=%.o)
 
-DEPSFILE = dependencies.txt
+sexc: $(OBJ) main.scm
-DEPSLOCK = eggs.lock
-EGGS_DIR := $(abspath .eggs)
-
-# Compiler's own repository (types.db, chicken.*), ignoring ambient venv vars.
-SYSTEM_CHICKEN_REPO := $(shell env -u CHICKEN_INSTALL_REPOSITORY -u CHICKEN_REPOSITORY_PATH -u CHICKEN_EGG_CACHE -u CHICKEN_INSTALL_PREFIX $(CHICKEN_INSTALL) -repository 2>/dev/null)
-CHICKEN_ABI := $(notdir $(SYSTEM_CHICKEN_REPO))
-EGGS_STAMP := $(EGGS_DIR)/.installed-$(CHICKEN_ABI)
-
-export CHICKEN_EGG_CACHE := $(EGGS_DIR)/cache
-export CHICKEN_INSTALL_REPOSITORY := $(EGGS_DIR)
-export CHICKEN_INSTALL_PREFIX := $(EGGS_DIR)
-export CHICKEN_REPOSITORY_PATH := $(EGGS_DIR):$(SYSTEM_CHICKEN_REPO)
-
-all: sexc
-
-sexc: $(EGGS_STAMP) $(OBJ) main.scm
 	$(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc
         # otherwise csc hangs, probably because it tries to compile to sexc.o first
 	mv sexc-tmp sexc
 
-$(OBJ): $(EGGS_STAMP)
-
 #------------------------------------------------------------------
 
 utils.o: utils.module.scm utils.scm
@@ -82,69 +53,28 @@ sexc.o: sexc.module.scm types.o sexc.scm fmt-c-writer.o sex-macros.o sex-modules
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,types,utils
 
 # Unit testing
-sex-tests: $(EGGS_STAMP)
+sex-tests:
 	$(MAKE) -C ./tests sex-tests
 	cp ./tests/sex-tests ./
 
-sextest: $(EGGS_STAMP)
+sextest:
 	$(MAKE) -C ./tools/sextest sextest
 	cp ./tools/sextest/sextest .
 
-SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features
+SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize
 
 # 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.
+run-tests: sexc sex-tests sextest
-check-exit-code: sexc
+	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules
-	@$(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.lock is the pin file (chicken-status -list). Install from it;
-# do not float versions on a normal build. Regenerating the lock:
-#   make deps-update
-$(EGGS_STAMP): $(DEPSLOCK)
-	mkdir -p $(CHICKEN_EGG_CACHE)
-	$(CHICKEN_INSTALL) -force -from-list $(DEPSLOCK)
-	touch $@
-
-deps: $(EGGS_STAMP)
-
-deps-update: $(DEPSFILE)
-	rm -rf $(EGGS_DIR)
-	mkdir -p $(CHICKEN_EGG_CACHE)
-	$(CHICKEN_INSTALL) -force $$(cat $(DEPSFILE))
-	CHICKEN_REPOSITORY_PATH=$(EGGS_DIR) $(CHICKEN_STATUS) -list | sort > $(DEPSLOCK).tmp
-	mv $(DEPSLOCK).tmp $(DEPSLOCK)
-	touch $(EGGS_STAMP)
 
 clean:
 	rm -f $(OBJ) main.o
 	rm -f *.import.scm
 	rm -f *.link
 	rm -f sexc sex-tests sextest
-	$(MAKE) -C ./tests clean
 	$(MAKE) -C ./tests/modules clean
-	$(MAKE) -C ./tools/sextest clean
 
-deps-clean:
+.PHONY: clean run-tests sex-tests sextest check-modules
-	rm -rf $(EGGS_DIR)
-
-.PHONY: all check run-tests check-modules check-exit-code \
-        install install-strip installdirs uninstall \
-        deps deps-update deps-clean clean sex-tests sextest

Readme.org

@@ -12,46 +12,16 @@ Sex is statically typed, compiled general purpose language.
 First, get yourself a Chicken, then, some Chicken deps. You also will
 need a C compiler.
 
-Eggs are installed into a project-local ~.eggs/~ repository; they do not
+** Install Chicken Eggs
-touch the Chicken system repository.
+Tip: there's a way to make Chicken install eggs non-globally. You need
+to export ~CHICKEN_INSTALL_REPOSITORY~ and ~CHICKEN_REPOSITORY_PATH~
+environment variables. Refer to the documentation for more info:
+https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
+
+~chicken-install `cat dependencies.txt`~
 
 ** Compilation
-#+begin_src sh
+~make~
-  make
-#+end_src
-
-That installs pinned eggs from ~eggs.lock~ into ~.eggs/~ if needed, then
-builds ~sexc~. ~dependencies.txt~ is the unpinned request list. To
-refresh ~eggs.lock~ after changing it:
-
-#+begin_src sh
-  make deps-update
-#+end_src
-
-** 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
@@ -61,21 +31,13 @@ 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
+ -C, --preprocess         Emit C code
-                          for #+ and #- feature expressions. May be given
-                          more than once
- --no-platform-features   Leave out the host's own features. With --features,
-                          this reads a file the way another platform would
- -C, --emit-c             Emit C code
  --public-interface       Get module's public interface
  -h, --help               Show this help
  -m, --macro-expand       Emit macro-expanded semantically processed Sex code
+                          (sort of IR). May be useful for debugging
  -o, --output=ARG         Write output to file. Default file name is a.out.
                           If -E or -m options are provided, defaults to stdout
- --line-directives=ARG    How much #line information to emit: statement (default),
-                          toplevel, or none. `statement' is what makes a debugger
-                          land on the right source line; `none' is for reading -C
-                          output by eye
 #+end_src
 ** Compiling Hello World
 #+begin_src shell
@@ -139,39 +101,6 @@ Module's public interface consists of everything declared
 ~pub~. Structures, function, macros, types, variables can be
 public.
 
-** Read-time feature expressions
-Sex is able to use ~#+~ and ~#-~ for conditional compilation: the form that
-follows is kept only when the feature expression is true, and otherwise
-is read and thrown away.
-
-#+begin_src scheme
-#+macosx (include OpenGL/gl3.h)
-#-macosx (include GL/gl.h)
-
-#+(and unix (not macosx)) (define HAVE-EPOLL 1)
-#+end_src
-
-An expression is a feature name, or ~and~, ~or~ and ~not~ of them.
-
-This is read time, not compile time. What does not apply never reaches macro
-expansion, the type database or the generated C.
-
-The features are the host's ~(software-version)~, ~(software-type)~
-and ~(machine-type)~, e.g. ~macosx unix arm64~ or ~linux unix
-x86-64~. ~--features~ adds to them:
-
-#+begin_src shell
-sexc prog.sex -f debug,with-sdl
-sexc prog.sex --features=debug --features=with-sdl
-#+end_src
-
-A feature is never taken away. The host's features can be disabled,
-e.g. for checking output for other platform:
-
-#+begin_src shell
-sexc example/sdl3-triangle.sex -C --no-platform-features --features=linux,unix,x86-64
-#+end_src
-
 ** Syntactic macros
 Sex has support for syntactic macros. Macro definitions look like
 functions: they have a name, an argument list and a body. Macro should

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/sdl3-triangle.sex

@@ -8,29 +8,13 @@
 ;;; 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:
+;;; Build:
 ;;;   ./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
+(define GL-SILENCE-DEPRECATION 1)       ; OpenGL is deprecated on macOS
 
 (include SDL3/SDL.h)
-
+(include OpenGL/gl3.h)
-#+macosx (include OpenGL/gl3.h)
-#-macosx (define GL-GLEXT-PROTOTYPES 1)
-#-macosx (include GL/gl.h)
-#-macosx (include GL/glext.h)
 
 (define WINDOW-WIDTH 800)
 (define WINDOW-HEIGHT 600)

fmt-c-writer.scm

@@ -382,17 +382,10 @@ forms, and what remains."
 
 (define (walk-enum form)
   (match form
-    ;; Naming one without defining it: `(var m (enum mood))', the same
-    ;; shape walk-struct accepts for `(struct foo)'. Guarded, and
-    ;; before the anonymous case, since `(enum (red green))' is also a
-    ;; two-element form
-    (('enum (? symbol? name))
-     `(enum ,(atom-to-fmt-c name)))
     (('enum (values ...))
      `(enum ,(map atom-to-fmt-c values)))
     (('enum name (values ...))
-     `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))
+     `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
-    (else (sex-error form "malformed enum" form))))
 
 (define (walk-extern form)
   (match form
@@ -417,7 +410,6 @@ forms, and what remains."
 
          ('struct . _)
          ('union . _)
-         ('enum . _)
 
          ('typedef . _))
      ;; ignore here, used in generating public interface
@@ -431,10 +423,7 @@ forms, and what remains."
     (('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 . rest) (walk-public rest))
-    ;; `pub' form's -- otherwise a complaint about what follows `pub'
-    ;; cannot say where it was written
-    (('pub . rest) (walk-public (copy-form-source! form rest)))
     ((or ('struct . _)
          ('union . _)) (walk-struct form))
     (('enum . _) (walk-enum form))

reader.module.scm

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

reader.scm

@@ -7,8 +7,6 @@
 ;;;   - 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.
 
@@ -17,8 +15,6 @@
   (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
@@ -164,8 +160,7 @@
    ((string->number s) => identity)
    (else (string->symbol s))))
 
-;;; #-dispatch: booleans, characters, vectors, block/datum comments,
+;;; #-dispatch: booleans, characters, vectors, block/datum comments
-;;; feature expressions
 (define (read-hash port)
   (let ((c (get-ch port)))
     (cond
@@ -176,46 +171,8 @@
      ((char=? c #\() (list->vector (read-list port close-paren)))
      ((char=? c #\|) (skip-block-comment port 1) (next-token port))
      ((char=? c #\;) (read-datum port) (next-token port)) ; datum comment
-     ((char=? c #\+) (read-conditional port #t))
-     ((char=? c #\-) (read-conditional port #f))
      (else (error "Unsupported # syntax" c)))))
 
-;;; Feature expressions
-;;;
-;;;   #+linux   (include GL/gl.h)      kept on Linux
-;;;   #-macosx  (foo)                  kept only on other than macOS
-;;;   #+(and unix (not macosx)) (bar)  and / or / not combine them
-;;;
-(define (platform-features)
-  (list (software-version) (software-type) (machine-type)))
-
-;;; The host's features are the default, so anything reading Sex sees
-;;; what the compiler would. sexc rebinds this to add --features
-(define current-features (make-parameter (platform-features)))
-
-(define (feature-true? test)
-  (cond
-   ((symbol? test) (and (memq test (current-features)) #t))
-   ((pair? test)
-    (case (car test)
-      ((and) (every feature-true? (cdr test)))
-      ((or) (any feature-true? (cdr test)))
-      ((not)
-       (if (and (pair? (cdr test)) (null? (cddr test)))
-           (not (feature-true? (cadr test)))
-           (error "Feature expression `not' takes exactly one operand" test)))
-      (else (error "Unknown operator in feature expression" (car test)))))
-   (else (error "Malformed feature expression" test))))
-
-;;; The #-/#+ preceded datum is always read -- there is no other way
-;;; to know where it ends -- and then either returned or dropped
-(define (read-conditional port keep-when)
-  (let ((keep (eq? keep-when (feature-true? (read-datum port)))))
-    (if keep
-        (read-datum port)
-        (begin (read-datum port)
-               (next-token port)))))
-
 ;;; #t / #true / #f / #false. `val' is the boolean; consume any
 ;;; trailing name characters and validate
 (define (read-bool port val)

semen.scm

@@ -93,9 +93,17 @@
     (else (sex-error sex-form "unknown top level form" sex-form))))
 
 (define (process-imports module-public-forms acc)
-  ;; consume (import ...) form and process imports so
+  ;; Recursively process imports: register public macros, cons all
-  ;; data types end up in types db
+  ;; other public things to our acc
-  (fold match-sex-form acc module-public-forms))
+  (if (null? module-public-forms) acc
+      (match (car module-public-forms)
+        (('defmacro . rest)
+         (defmacro rest)
+         (process-imports (cdr module-public-forms) acc))
+        (else
+         (process-imports (cdr module-public-forms)
+                          (cons (car module-public-forms)
+                                acc))))))
 
 (define (macro-expand form)
   "Walk the form recursively and expand all macros, until none is left."
@@ -140,82 +148,16 @@
   (cons (copy-form-source! form `(typedef ,target ,new-type)) acc))
 
 ;;; Fn processing
-;;;
-;;; A string as the first body form is a docstring. In the generated
-;;; C code it will be placed as a C commentary just before the function
-;;; definition (actually that works for all blocky things: enum, struct, union as well).
 
 (define (comment-form? f)
   (and (pair? f) (eq? (car f) 'comment)))
 
-(define (fn-header-length fn-form)
-  (if (memq (car fn-form) '(pub extern)) 5 4))
-
-(define (fn-core form)
-  ;; The (fn name args rettype . body) list, without pub/extern
-  (if (memq (car form) '(pub extern))
-      (cdr form)
-      form))
-
-(define (take-leading-docstring forms)
-  ;; If FORMS starts with a string, possibly after comment forms, return
-  ;; that string and FORMS without it. Otherwise #f and FORMS unchanged
-  (let loop ((fs forms) (prefix (list)))
-    (cond
-     ((null? fs)
-      (values #f forms))
-     ((comment-form? (car fs))
-      (loop (cdr fs) (cons (car fs) prefix)))
-     ((string? (car fs))
-      (values (car fs) (append (reverse prefix) (cdr fs))))
-     (else
-      (values #f forms)))))
-
-(define (extract-fn-docstring fn-form)
-  (let ((n (fn-header-length fn-form)))
-    (if (< (length fn-form) n)
-        (values #f fn-form)
-        (let-values (((doc body) (take-leading-docstring (drop fn-form n))))
-          (if doc
-              (values doc
-                      (copy-form-source! fn-form
-                                         (append (take fn-form n) body)))
-              (values #f fn-form))))))
-
-(define (extract-aggregate-docstring form)
-  ;; ([pub] struct|union|enum name "doc" (fields ...) . attrs)
-  ;; A string immediately after the name is the docstring; comments
-  ;; between name and fields are not skipped, they already confuse the
-  ;; writer
-  (let* ((pub? (eq? (car form) 'pub))
-         (core (if pub? (cdr form) form)))
-    (if (and (pair? (cdr core))
-             (symbol? (cadr core))
-             (pair? (cddr core))
-             (string? (caddr core)))
-        (let ((new-core (cons (car core)
-                              (cons (cadr core) (cdddr core)))))
-          (values (caddr core)
-                  (copy-form-source! form
-                                     (if pub?
-                                         (cons 'pub new-core)
-                                         new-core))))
-        (values #f form))))
-
-(define (with-docstring doc form acc)
-  ;; acc is newest-first; FORM is consed last so the final reverse
-  ;; emits the comment immediately before the declaration
-  (cons form
-        (if doc
-            (cons (list 'comment doc) acc)
-            acc)))
-
 (define (strip-fn-header-comments fn-form)
   ;; Remove comment forms from the function header
   ;; ([pub|extern] fn name arglist rettype) so the positional accessors
   ;; below are not shifted. Comments in the body are left in place as
   ;; ordinary statements and preserved into the generated C.
-  (let ((header-count (fn-header-length fn-form)))
+  (let ((header-count (if (memq (car fn-form) '(pub extern)) 5 4)))
     ;; This always rebuilds the list, so the location has to be carried
     ;; over explicitly -- otherwise every function loses it
     (copy-form-source!
@@ -228,21 +170,21 @@
         (else (loop (cdr form) (+ kept 1) (cons (car form) acc))))))))
 
 (define (process-fn sex-fn-raw acc)
-  (let-values (((doc sex-fn)
+  (let* ((sex-fn (strip-fn-header-comments sex-fn-raw))
-                (extract-fn-docstring (strip-fn-header-comments sex-fn-raw))))
+         (expanded (macro-expand sex-fn))
-    (let* ((expanded (macro-expand sex-fn))
+         (env (make-hash-table))
-           (env (make-hash-table))
+         (processed
-           (processed
+          (walk-form
-            (walk-form
+           expanded
-             expanded
+           fn-walker
-             fn-walker
+           (begin
-             (begin
+             (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
-               (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
+             (set! (hash-table-ref env :lambda-counter) 0)
-               (set! (hash-table-ref env :lambda-counter) 0)
+             (set! (hash-table-ref env :lambda-aux-code) (list))
-               (set! (hash-table-ref env :lambda-aux-code) (list))
+             env))))
-               env))))
+
-      (with-docstring doc processed
+    (cons processed
-                      (append (hash-table-ref env :lambda-aux-code) acc)))))
+          (append (hash-table-ref env :lambda-aux-code) acc))))
 
 (define (fn-walker form env)
   (if (eq? 'lambda (car form))
@@ -273,9 +215,8 @@
 
 ;;; Record the named structs, unions and enums in the type database
 (define (process-struct sex-struct acc)
-  (let-values (((doc form) (extract-aggregate-docstring sex-struct)))
+  (register-aggregate! sex-struct)
-    (register-aggregate! form)
+  (cons sex-struct acc))
-    (with-docstring doc form acc)))
 
 (define (register-aggregate! form)
   (let* ((f (if (eq? (car form) 'pub) (cdr form) form))
@@ -299,35 +240,46 @@
 (define (sex-fn? form)
   "The `form` must be toplevel.
 Returns #f if the form is not a function, returns the form otherwise"
-  (and (non-empty-list? form)
+  (match form
-       (let ((core (fn-core form)))
+    ((fn . _) form)
-         (and (pair? core) (eq? (car core) 'fn) form))))
+    ((pub fn . _) form)
+    (else #f)))
 
 (define (sex-fn-public? fn-form)
   (eq? (car fn-form) 'pub))
 
+(define (sex-fn-return-type fn-form)
+  (assert (sex-fn? fn-form)
+          (fmt #f "Form " fn-form " is not a function"))
+  (if (sex-fn-public? fn-form)
+      (third fn-form)
+      (second fn-form)))
+
 (define (sex-fn-name fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (cadr (fn-core fn-form)))
+  (if (sex-fn-public? fn-form)
+      (fourth fn-form)
+      (third fn-form)))
 
 (define (sex-fn-arglist fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (caddr (fn-core fn-form)))
+  (if (sex-fn-public? fn-form)
-
+      (fifth fn-form)
-(define (sex-fn-return-type fn-form)
+      (fourth fn-form)))
-  (assert (sex-fn? fn-form)
-          (fmt #f "Form " fn-form " is not a function"))
-  (cadddr (fn-core fn-form)))
 
 (define (sex-fn-prototype fn-form)
   "Returns all except body"
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (take fn-form (fn-header-length fn-form)))
+  (if (sex-fn-public? fn-form)
+      (take fn-form 5)
+      (take fn-form 4)))
 
 (define (sex-fn-body fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (drop fn-form (fn-header-length fn-form)))
+  (if (sex-fn-public? fn-form)
+      (drop fn-form 5)
+      (drop fn-form 4)))

sex-fmt-c.scm

@@ -640,22 +640,16 @@
   (define (c-union . args) (apply c-struct/aux "union" args))
   (define (c-class . args) (apply c-struct/aux "class" args))
 
-  ;; MODIFIED FROM UPSTREAM fmt-c: an enum may also be named without
-  ;; being defined -- `enum color m;' -- exactly as c-struct/aux
-  ;; already allows `struct point p;'. Upstream assumed a value list
-  ;; was always present and mapped over whatever stood in its place.
   (define (c-enum x . o)
     (define (c-enum-one x)
       (if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x)))
     (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
-           (vals (if name (if (null? o) #f (car o)) x)))
+           (vals (if name (car o) x)))
-      (if vals
+      (c-wrap-stmt
-          (c-wrap-stmt
+       (cat
-           (cat
+        (c-braced-block
-            (c-braced-block
+         (if name (cat "enum " name) (dsp "enum"))
-             (if name (cat "enum " name) (dsp "enum"))
+         (c-in-expr (apply c-begin (map c-enum-one vals))))))))
-             (c-in-expr (apply c-begin (map c-enum-one vals))))))
-          (c-wrap-stmt (cat "enum " name)))))
 
   (define (c-attribute . args)
     (cat "__attribute__ ((" (fmt-join c-expr args ", ") "))"))
@@ -749,13 +743,7 @@
                      (if (and (pair? (cadr type)) (eq? '%array (caadr type)))
                          (c-paren name)
                          name))))
-          ;; MODIFIED FROM UPSTREAM fmt-c: upstream passed the
+          ((enum) (apply c-enum name (cdr type)))
-          ;; declarator's name to c-enum as the enum's tag, so
-          ;; `(var m (enum color))' emitted `enum m {...}' and lost the
-          ;; variable. Enums are laid out like structs: the type, then
-          ;; the name being declared.
-          ((enum)
-           (cat (apply c-enum (cdr type)) (if name (cat " " name) "")))
           ((struct union class)
            (cat (apply c-struct/aux (car type) (cdr type)) (if name (cat " " name) "")))
           (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))

sex-modules.scm

@@ -14,10 +14,6 @@
 
 (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:
@@ -33,11 +29,7 @@
   (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+)
+    (read-public-interface module-path)))
-        (list)
-        (begin
-          (set! +imported-modules+ (cons module-path +imported-modules+))
-          (read-public-interface module-path)))))
 
 (define (get-module-paths)
   (cons (current-directory)
@@ -71,18 +63,6 @@
      (list)
      raw-forms)))
 
-(define (public-fn-interface form)
-  ;; (pub fn name args ret . body) -> prototype, keeping a docstring so
-  ;; the importer can emit it above the declaration
-  (let ((header (take form 5)))
-    (let loop ((body (drop form 5)))
-      (cond
-       ((null? body) header)
-       ((and (pair? (car body)) (eq? (caar body) 'comment))
-        (loop (cdr body)))
-       ((string? (car body)) (append header (list (car body))))
-       (else header)))))
-
 ;;; TODO: use semen facilities to analyze modules
 (define (process-public-interface-form form acc)
   (case (car form)
@@ -91,11 +71,11 @@
        ;; A function is reduced to a prototype and keeps its `pub', so
        ;; the importing unit declares it with external linkage
        ((fn)
-        (cons (copy-form-source! form (public-fn-interface form)) acc))
+        (cons (copy-form-source! form (take form 5)) acc))
        ;; A variable becomes an `extern' declaration
        ((var)
         (cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc))
-       ((define defmacro enum import include struct typedef union)
+       ((define defmacro import include struct typedef union)
         (cons (copy-form-source! form (cdr form)) acc))
        (else (sex-error form "pub must be followed by a definition" form))))
     (else acc)))

sexc.scm

@@ -2,14 +2,12 @@
         (scheme base)                   ; call/cc
         brev-separate
         (chicken base)
-        (chicken condition)             ; handle-exceptions
         (chicken file)
         (chicken plist)
         (chicken pretty-print)
         (chicken process)
         (chicken process-context)
         (chicken port)
-        (chicken string)                ; string-split
         fmt
         fmt-c-writer
         getopt-long
@@ -32,17 +30,6 @@
                       (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)
@@ -110,15 +97,6 @@
           ((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)
@@ -139,22 +117,15 @@
                                  (emit-c sex-forms)))))
 
 (define (compile-to-file sex-forms output args cc-args)
-  "Hand the generated C to the C compiler. Returns the compiler's exit
-status, which is ours to pass on."
   (let ((compiler (or (get-arg args 'c-compiler #f)
                       (get-env-var "SEX_CC")
                       "cc"))
         (out-file (if (eq? output 'default)
                       "a.out"
-                      output))
+                      output)))
-        ;; The generated C goes to a temporary .c file rather than the
+    ;; The generated C goes to a temporary .c file rather than the
-        ;; compiler's stdin. It is removed however we leave -- emit-c
+    ;; compiler's stdin
-        ;; can throw, and used to leave the file behind when it did
+    (let ((c-file (create-temporary-file "c")))
-        (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)
@@ -164,9 +135,9 @@ status, which is ours to pass on."
                                             (list c-file)
                                             cc-args))))
         (call-with-values (lambda () (process-wait proc))
-          (lambda (pid normal-exit? status)
+          (lambda status
             (delete-file* c-file)
-            (if normal-exit? status 1)))))))
+            (apply values status)))))))
 
 (define (semantic-process-forms raw-forms input-source)
   (if (eq? input-source 'stdin)
@@ -202,14 +173,6 @@ status, which is ours to pass on."
        (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")
 
@@ -235,7 +198,5 @@ status, which is ours to pass on."
                  (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
+             ;; Compile file!
-             (let ((status (compile-to-file sex-forms output args cc-args)))
+             (compile-to-file sex-forms output args cc-args)))))))
-               (unless (zero? status)
-                 (exit status)))))))))

tests/Makefile

@@ -46,5 +46,3 @@ clean:
 	rm -f *.import.scm
 	rm -f *.link
 	rm -f sex-tests
-
-.PHONY: clean

tests/codegen.scm

@@ -141,28 +141,6 @@ compiles."
     (test-assert "a comment in a body stays in the body"
       (emits? (in-fn "(while (< a b) ;; inside\n (g 1))")
               "while (a < b) {")))
-
-  (test-group "pub enum"
-    (test-assert "is emitted"
-      (emits? "(pub enum color (red green blue))" "enum color"))
-    (test-assert "with its values"
-      (emits? "(pub enum color (red green blue))" "red"))
-    (test-assert "and a non-pub enum still is too"
-      (emits? "(enum color (red green blue))" "enum color"))
-    ;; Naming an enum as a type, rather than defining it, had no
-    ;; walk-enum clause and died with `(match) no matching pattern'
-    (test-assert "and it can then be used as a type"
-      (emits? "(enum color (red green blue)) (fn f () void (var m (enum color) red))"
-              "enum color m = red"))
-    (test-assert "a malformed enum is rejected with its location"
-      (reports? "(enum)" "codegen.sex:1:"))
-    ;; c-type handed the declarator's name to c-enum as the enum tag,
-    ;; so this emitted `enum m { up, down }' with no variable at all
-    (test-assert "an anonymous enum keeps the variable"
-      (emits? "(fn f () void (var e (enum (up down)) up))" "} e = up"))
-    (test-assert "and a named definition keeps both"
-      (emits? "(fn f () void (var n (enum named (a b)) a))" "enum named{")))
-
   ;; `|', `||' and `|=' read as ordinary symbols -- our own reader has
   ;; no |symbol| syntax for them to collide with -- but fmt-c cannot
   ;; dispatch on a symbol whose name it cannot write in Scheme source,
@@ -230,33 +208,4 @@ compiles."
     (test-assert "grouping sublist still accepted"
       (emits? (in-fn "(var s (* (const struct suc)) 0)") "const struct suc * s"))
     (test-assert "flat chain still accepted"
-      (emits? (in-fn "(var q (* * const char) 0)") "const char * * q")))
+      (emits? (in-fn "(var q (* * const char) 0)") "const char * * q"))))
-
-  ;; A string as the first body form (or after the name of a struct,
-  ;; union or enum) is a docstring: it becomes a comment immediately
-  ;; before the declaration, not a statement inside it.
-  (test-group "docstrings"
-    (test-assert "appears before the function"
-      (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
-              "/* Greet NAME. */"))
-    (test-assert "and not inside the body as a statement"
-      (not (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
-                   "\"Greet NAME.\"")))
-    (test-assert "multiline keeps its paragraphs"
-      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
-              "Entry point."))
-    (test-assert "and the second paragraph too"
-      (emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
-              "ARGC and ARGV."))
-    (test-assert "a prototype with only a docstring stays a prototype"
-      (emits? "(fn helper ((a int)) int \"Forward.\")"
-              "helper (int a);"))
-    (test-assert "a string after the first statement is left alone"
-      (emits? "(fn f () void (g) \"not a docstring\")"
-              "\"not a docstring\""))
-    (test-assert "a struct docstring sits above the struct"
-      (emits? "(struct point \"A 2D point.\" ((x int) (y int)))"
-              "/* A 2D point. */"))
-    (test-assert "and an enum docstring too"
-      (emits? "(enum color \"RGB.\" (red green blue))"
-              "/* RGB. */"))))

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

@@ -7,14 +7,10 @@
 # module's object survives being passed after `--'. Get any of them
 # wrong and this fails to link -- or, in the `pub var' case, links and
 # quietly counts into a private copy.
-#
-# It also checks what only a second translation unit can check: that an
-# imported type reaches the type database, by expanding a macro that
-# reads the imported struct's fields.
 
 SEXC ?= ../../sexc
 
-EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1
+EXPECTED = hello, world\nhello, sex\n2 greetings
 
 check:
 	@$(SEXC) greet.sex -c -o greet.o

tests/modules/greet-app.sex

@@ -7,9 +7,6 @@
 ;;; 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)
 
@@ -19,11 +16,4 @@
   (greet "world")
   (greet "sex")
   (printf "%d greetings\n" greet-count)
-  (describe-fields greeting)
-  (printf "\n")
-  ;; ...and through the imported typedef for it
-  (describe-fields greeting-t)
-  (printf "\n")
-  (var m (enum mood) grumpy)
-  (printf "mood %d\n" m)
   (return 0))

tests/modules/greet.sex

@@ -9,24 +9,7 @@
 
 (pub var greet-count 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 ((name (* const char))) void
-  "Print a greeting for NAME."
   (++ greet-count)
   (printf "hello, %s\n" name))
 

tests/reader.scm

@@ -1,14 +1,6 @@
 (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)
@@ -46,41 +38,4 @@
   (reader-test '((a b) (comment " t")) "(a b) ; t")
   ;; a `;' inside a string is not a comment
   (reader-test '("a;b") "\"a;b\"")
-
-  ;; #+ / #- feature expressions. What does not apply is read and
-  ;; dropped, so it never reaches the compiler at all
-  (feature-test '((a)) (linux) "#+linux (a)")
-  (feature-test '()    (macosx) "#+linux (a)")
-  (feature-test '()    (linux) "#-linux (a)")
-  (feature-test '((a)) (macosx) "#-linux (a)")
-  ;; the guarded datum can be anything, not only a list
-  (feature-test '(42) (x) "#+x 42")
-  (feature-test '("s") (x) "#+x \"s\"")
-
-  ;; and / or / not
-  (feature-test '((a)) (unix linux) "#+(and unix linux) (a)")
-  (feature-test '()    (unix) "#+(and unix linux) (a)")
-  (feature-test '((a)) (unix) "#+(or linux unix) (a)")
-  (feature-test '()    (bsd)  "#+(or linux unix) (a)")
-  (feature-test '((a)) (unix) "#+(and unix (not macosx)) (a)")
-  (feature-test '()    (unix macosx) "#+(and unix (not macosx)) (a)")
-  ;; (and) is true and (or) is false, as they are in CL
-  (feature-test '((a)) () "#+(and) (a)")
-  (feature-test '()    () "#+(or) (a)")
-
-  ;; a guard inside a form, including as the last element -- dropping
-  ;; continues with the next token, so the closing paren still arrives
-  (feature-test '((f 1 3)) (a) "(f #+a 1 #-a 2 3)")
-  (feature-test '((f 2 3)) (b) "(f #+a 1 #-a 2 3)")
-  (feature-test '((f 1))   (a) "(f #+a 1 #+b 2)")
-  (feature-test '((f))     (b) "(f #+a 1)")
-  ;; ...and as the last form in the file
-  (feature-test '((a)) (x) "(a) #+y (b)")
-
-  ;; guards nest
-  (feature-test '((a)) (x y) "#+x #+y (a)")
-  (feature-test '((b)) (x) "#+x #+y (a) (b)")
-
-  ;; a feature the program was not given is simply absent
-  (feature-test '() () "#+anything (a)")
 )

tests/semen.scm

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

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

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

tests/types.scm

@@ -54,42 +54,6 @@
         #f
         (get-underlying-type 't-point))
 
-  ;; Reflection through an alias. Both spellings of the target occur:
-  ;; (typedef point-t point) and (typedef point-t (struct point)).
-  (add-typedef 't-point-t '(typedef t-point-t t-point))
-  (test "a typedef to a struct has the struct's fields"
-        '((x int) (y int))
-        (get-fields 't-point-t))
-  (add-typedef 't-point-s '(typedef t-point-s (struct t-point)))
-  (test "written the other way round too"
-        '((x int) (y int))
-        (get-fields 't-point-s))
-  (add-typedef 't-point-2 '(typedef t-point-2 t-point-t))
-  (test "and through a chain of them"
-        '((x int) (y int))
-        (get-fields 't-point-2))
-  (test "map-fields follows an alias as well"
-        '((x int) (y int))
-        (map-fields 't-point-t (lambda (name type) (list name type))))
-  (add-typedef 't-color-t '(typedef t-color-t t-color))
-  (test "an aliased enum is still named as it was declared"
-        '((red (enum t-color)) (green (enum t-color)) (blue (enum t-color)))
-        (map-fields 't-color-t (lambda (name type) (list name type))))
-  (test "a typedef to a primitive has no fields"
-        #f
-        (get-fields 't-u8))
-
-  ;; A typedef can be written to lead back to itself. Resolving it must
-  ;; stop rather than spin
-  (add-typedef 't-loop-a '(typedef t-loop-a t-loop-b))
-  (add-typedef 't-loop-b '(typedef t-loop-b t-loop-a))
-  (test "a typedef cycle terminates"
-        't-loop-a
-        (get-underlying-type 't-loop-a))
-  (test "and has no fields"
-        #f
-        (get-fields 't-loop-a))
-
   ;; A #define keeps its value forms -- there can be more than one.
   (add-define 't-maxn '(define t-maxn 8))
   (test "defines are recorded"

tools/sextest/reader.module.scm

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

tools/sextest/sextest.scm

@@ -7,63 +7,36 @@
         (chicken port)
         (chicken process)
         (chicken process-context)
-        (chicken string)                ; string-split
         fmt
         getopt-long
         reader                          ; read-raw-forms, shared with sexc
-        srfi-1
+        srfi-1)
-        srfi-13)                        ; string-prefix?
 
 (define (print-help)
   (fmt #t "Usage: sextest [options] filename" nl
        "Options:" nl
        (usage opts-grammar) nl))
 
-(define (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))
-
-;;; --features from the (compilation ...) form, which we have to honour
-;;; ourselves: the program is read here and printed back out for sexc,
-;;; so #+ and #- are resolved on this side
-(define (compilation-features settings)
-  (let ((compilation (assoc 'compilation settings)))
-    (if compilation
-        (append-map (lambda (flag)
-                      (if (string-prefix? "--features=" flag)
-                          (map string->symbol
-                               (string-split (substring flag 11) ","))
-                          (list)))
-                    (string-split (cadr compilation)))
-        (list))))
-
 (define (process-file target-path)
-  (let* ((first-pass (split-settings (read-raw-forms target-path)))
+  (let ((contents (read-raw-forms target-path)))
-         (features (compilation-features (car first-pass))))
+    (foldl (lambda (acc elt)
-    (if (null? features)
+             (case (car elt)
-        first-pass
+               ((compilation input output return)
-        (parameterize ((current-features (append (platform-features) features)))
+                (cons
-          (split-settings (read-raw-forms target-path))))))
+                 (append (car acc) (list elt))
+                 (cdr acc)))
+               (else
+                (cons
+                 (car acc)
+                 (append (cdr acc) (list elt))))))
+           (cons (list) (list))
+           contents)))
 
-(define (compile src compilation sexc)
+(define (compile src flags 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.
@@ -137,7 +110,7 @@
   (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)))
+         (compiled-file (compile src (assoc 'compile settings) sexc)))
     (if (not compiled-file)
         (begin (fmt #t "Failed to compile " path nl)
                #f)

types.scm

@@ -76,44 +76,21 @@
 ;;; ((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)))
+  (let ((info (get-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
+;;; Follow a typedef chain to the name it ultimately stands for. #f if
-;;; not a typedef. A typedef that leads back to itself stops rather
+;;; NAME is not a typedef.
-;;; than spinning: nothing prevents one from being written.
 (define (get-underlying-type name)
-  (let follow ((name name) (seen (list)))
-    (and (not (member name seen))
-         (let ((info (get-type-info name)))
-           (and info
-                (eq? (car info) 'typedef)
-                (let ((target (caddr info)))
-                  (or (and (symbol? target) (follow target (cons name seen)))
-                      target)))))))
-
-;;; The declaration NAME ultimately names. For a typedef that is the
-;;; entry of whatever it stands for, and for anything else it is
-;;; NAME's own info.
-(define (resolve-type-info name)
   (let ((info (get-type-info name)))
     (and info
-         (if (eq? (car info) 'typedef)
+         (eq? (car info) 'typedef)
-             (let* ((target (get-underlying-type name))
+         (let ((target (caddr info)))
-                    (tag (cond ((symbol? target) target)
+           (or (and (symbol? target) (get-underlying-type target))
-                               ((and (pair? target)
+               target)))))
-                                     (pair? (cdr target))
-                                     (symbol? (cadr target)))
-                                (cadr target))
-                               (else #f))))
-               (and tag (get-type-info tag)))
-             info))))
 
 ;;; Type matcher macro
 ;;; (type-match type
@@ -142,16 +119,15 @@
 ;;;
 ;;; Returns #f if nothing of that name was declared
 (define (map-fields struct-union-enum fn)
-  (let ((info (resolve-type-info struct-union-enum)))
+  (let ((info (get-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
+           ;; An enumerator's type is the enum itself.
-           ;; declared, since `enum some-typedef' is not a C type.
            ((enum)
-            (let ((type (list 'enum (cadr info))))
+            (let ((type (list 'enum struct-union-enum)))
               (map (lambda (value) (fn value type))
                    (caddr info))))
            (else #f)))))