TMP

.gitea/workflows/build.yaml

@@ -57,9 +57,7 @@ jobs:
           hash -r
           csc -version
 
-      - name: Install dependencies
-        run: make deps
-
+      # Eggs are pinned in eggs.lock and installed by the Makefile into .eggs/.
       - name: Build sexc
         run: make && ./sexc --help
 

Makefile

@@ -34,27 +34,24 @@ DEPSLOCK = eggs.lock
 EGGS_DIR := $(abspath .eggs)
 
 # Compiler's own repository (types.db, chicken.*), ignoring ambient venv vars.
-SYSTEM_CHICKEN_REPO := $(shell env \
-	-u CHICKEN_INSTALL_REPOSITORY -u CHICKEN_REPOSITORY_PATH \
-	-u CHICKEN_EGG_CACHE -u CHICKEN_INSTALL_PREFIX \
-	$(CHICKEN_INSTALL) -repository 2>/dev/null)
+SYSTEM_CHICKEN_REPO := $(shell env -u CHICKEN_INSTALL_REPOSITORY -u CHICKEN_REPOSITORY_PATH -u CHICKEN_EGG_CACHE -u CHICKEN_INSTALL_PREFIX $(CHICKEN_INSTALL) -repository 2>/dev/null)
 CHICKEN_ABI := $(notdir $(SYSTEM_CHICKEN_REPO))
 EGGS_STAMP := $(EGGS_DIR)/.installed-$(CHICKEN_ABI)
 
-# 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_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: $(OBJ) main.scm
+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
@@ -85,16 +82,15 @@ 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:
+sex-tests: $(EGGS_STAMP)
 	$(MAKE) -C ./tests sex-tests
 	cp ./tests/sex-tests ./
 
-sextest:
+sextest: $(EGGS_STAMP)
 	$(MAKE) -C ./tools/sextest sextest
 	cp ./tools/sextest/sextest .
 
-SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \
-                    feature-flags
+SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features
 
 # Multi-module linking is checked end to end; see tests/modules/Makefile.
 check-modules: sexc
@@ -119,11 +115,9 @@ installdirs:
 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.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)
@@ -131,10 +125,10 @@ $(EGGS_STAMP): $(DEPSLOCK)
 
 deps: $(EGGS_STAMP)
 
-deps-update: $(DEPSFILE) deps-clean
+deps-update: $(DEPSFILE)
+	rm -rf $(EGGS_DIR)
 	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)

Readme.org

@@ -12,25 +12,22 @@ Sex is statically typed, compiled general purpose language.
 First, get yourself a Chicken, then, some Chicken deps. You also will
 need a C compiler.
 
-** Development
+Eggs are installed into a project-local ~.eggs/~ repository; they do not
+touch the Chicken system repository.
+
+** Compilation
 #+begin_src sh
-  make deps
   make
 #+end_src
 
-~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:
+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
 
-** 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

fmt-c-writer.scm

@@ -135,6 +135,9 @@ forms, and what remains."
       (car type)
       type))
 
+(define (comment-form? f)
+  (and (pair? f) (eq? (car f) 'comment)))
+
 ;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
 (define (strip-comment-marker text)
   (string-trim-both (string-trim text #\;)))
@@ -276,7 +279,7 @@ forms, and what remains."
          ;; it's a strong semantic cue
          `(%array ,(walk-type (maybe-unwrap-type array-type)))))
     (('fn arglist ret-type)
-     `(%fun ,(walk-type ret-type) ,(walk-arg-types arglist)))
+     `(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
     (('fn . _)
      (sex-error form "malformed function type" form))
 
@@ -288,13 +291,8 @@ forms, and what remains."
     (else
      (type-convert-to-c form))))
 
-;;; An array or a function type
-(define (structured-type? form)
-  (and (pair? form) (memq (car form) '(¤ fn))))
-
 (define (has-pointer-star? form)
   (and (pair? form)
-       (not (structured-type? form))
        (or (memq '* form)
            (any has-pointer-star? (filter pair? form)))))
 
@@ -306,10 +304,6 @@ forms, and what remains."
   (and (pair? type)
        (any has-pointer-star? (filter pair? type))))
 
-(define (nested-structured-type type)
-  (and (pair? type)
-       (find structured-type? (filter pair? type))))
-
 (define (type-convert-to-c type)
   ;; Our pointers to C pointers
   ;; int -> int
@@ -317,12 +311,6 @@ forms, and what remains."
   ;; const * const char -> const char * const
   (when (nested-pointer? type)
     (sex-error type "pointer chains are written flat, as (* * T), not nested" type))
-  (let ((inner (nested-structured-type type)))
-    (when inner
-      (if (eq? (car inner) 'fn)
-          ;; (fn ...) is spelled as the pointer it already is in C
-          (sex-error type "a fn type is a function pointer already: write (fn ...), not (* (fn ...))" type)
-          (sex-error type "a pointer to an array is not supported" type))))
   (if (atom? type) (atom-to-fmt-c type)
       (flatten
        (tree-map atom-to-fmt-c
@@ -346,38 +334,25 @@ forms, and what remains."
     ((¤ * const volatile struct union) #t)
     (else #f)))
 
-;;; Does the parameter name itself?
-;;; (f1 float) does
-;;; (float), (const char) and (¤ float 4) do not
-(define (named-arg? arg)
-  (and (pair? arg)
-       (pair? (cdr arg))                ; 1 element args are always type
-       (not (eq? (car arg) '¤))
-       (not (is-probably-type arg))))
-
-;;; The type of one parameter
-(define (arg-type arg)
-  (if (named-arg? arg)
-      (walk-type (maybe-unwrap-type (cdr arg)))
-      ;; A lone type may arrive wrapped in parens of its own, and those
-      ;; are not part of it: ((* const char))
-      ;; Plain names e.g. (int) are left as is
-      (walk-type (if (and (pair? arg) (null? (cdr arg)) (pair? (car arg)))
-                     (car arg)
-                     arg))))
-
 (define (walk-arglist form)
   ;; E.g.:
   ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
   ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
-  (map (lambda (arg)
-         (if (named-arg? arg)
-             (list (arg-type arg) (walk-type (car arg)))
-             (arg-type arg)))
-       (remove comment-form? form)))
+  (map (fn
+        (match x
+          (('¤ . _) (walk-type x))
 
-(define (walk-arg-types form)
-  (map arg-type (remove comment-form? form)))
+          ;; yeah shitty, but I don't know yet how to determine if the
+          ;; first entry is part of the type and not an argument name
+          ;; :(
+          ((? is-probably-type) (walk-type x))
+
+          ;; 1 element args are always type
+          ((_) (walk-type x))
+
+          ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
+                                (list (walk-type var))))))
+       (remove comment-form? form)))
 
 (define (walk-function form)
   ;; (fn ret-type name arglist body) -> normal function

reader.scm

@@ -115,21 +115,6 @@
      ((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)
@@ -223,24 +208,13 @@
    (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
+;;; to know where it ends -- and then either returned or dropped
 (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))))
+  (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

semen.scm

@@ -72,7 +72,7 @@
     ((or ('var . _)
          ('pub 'var . _)
          ('extern 'var . _)) (process-global-var sex-form acc))
-    (('include . includes) (process-includes sex-form includes acc))
+    (('include _) (cons sex-form acc))
     ((or ('define name . _)
          ('pub 'define name . _))
      (add-define name sex-form)
@@ -92,17 +92,6 @@
 
     (else (sex-error sex-form "unknown top level form" sex-form))))
 
-(define (process-includes sex-form includes acc)
-  ;; consume (include ...) form and add to acc
-  ;; (include <inc>) for each include
-  (let process ((includes includes)
-                (acc acc))
-    (if (null? includes)
-        acc
-        (process (cdr includes)
-                 (cons (copy-form-source! sex-form `(include ,(car includes)))
-                       acc)))))
-
 (define (process-imports module-public-forms acc)
   ;; consume (import ...) form and process imports so
   ;; data types end up in types db
@@ -156,12 +145,15 @@
 ;;; C code it will be placed as a C commentary just before the function
 ;;; definition (actually that works for all blocky things: enum, struct, union as well).
 
+(define (comment-form? f)
+  (and (pair? f) (eq? (car f) 'comment)))
+
 (define (fn-header-length fn-form)
-  (if (memq (first fn-form) '(pub extern)) 5 4))
+  (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 (first form) '(pub extern))
+  (if (memq (car form) '(pub extern))
       (cdr form)
       form))
 
@@ -169,42 +161,46 @@
   ;; If FORMS starts with a string, possibly after comment forms, return
   ;; that string and FORMS without it. Otherwise #f and FORMS unchanged
   (let loop ((fs forms) (prefix (list)))
-    (match fs
-      (() (values #f forms))
-      (((and cmt ('comment . _)) . rest)
-       (loop rest (cons cmt prefix)))
-      (((? string? doc) . rest)
-       (values doc (append (reverse prefix) rest)))
-      (_ (values #f forms)))))
+    (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 ((lift
-         (lambda (proto body)
-           (let-values (((doc rest) (take-leading-docstring body)))
-             (if doc
-                 (values doc (copy-form-source! fn-form (append proto rest)))
-                 (values #f fn-form))))))
-    (match fn-form
-      (('pub 'fn name args ret . body)
-       (lift `(pub fn ,name ,args ,ret) body))
-      (('extern 'fn name args ret . body)
-       (lift `(extern fn ,name ,args ,ret) body))
-      (('fn name args ret . body)
-       (lift `(fn ,name ,args ,ret) body))
-      (_ (values #f fn-form)))))
+  (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
-  (match form
-    (('pub (and kind (or 'struct 'union 'enum))
-           (? symbol? name) (? string? doc) . rest)
-     (values doc (copy-form-source! form `(pub ,kind ,name ,@rest))))
-    (((and kind (or 'struct 'union 'enum))
-      (? symbol? name) (? string? doc) . rest)
-     (values doc (copy-form-source! form `(,kind ,name ,@rest))))
-    (_ (values #f form))))
+  (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
@@ -215,10 +211,21 @@
             acc)))
 
 (define (strip-fn-header-comments fn-form)
-  ;; ([pub|extern] fn name arglist rettype). Comments in the body are
-  ;; left in place as ordinary statements and preserved into the
-  ;; generated C.
-  (strip-header-comments fn-form (fn-header-length fn-form)))
+  ;; 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)))
+    ;; This always rebuilds the list, so the location has to be carried
+    ;; over explicitly -- otherwise every function loses it
+    (copy-form-source!
+     fn-form
+     (let loop ((form fn-form) (kept 0) (acc (list)))
+       (cond
+        ((null? form) (reverse acc))
+        ((= kept header-count) (append (reverse acc) form))
+        ((comment-form? (car form)) (loop (cdr form) kept acc))
+        (else (loop (cdr form) (+ kept 1) (cons (car form) acc))))))))
 
 (define (process-fn sex-fn-raw acc)
   (let-values (((doc sex-fn)
@@ -292,29 +299,27 @@
 (define (sex-fn? form)
   "The `form` must be toplevel.
 Returns #f if the form is not a function, returns the form otherwise"
-  (match form
-    ((or ('fn . _)
-         ('pub 'fn . _)
-         ('extern 'fn . _)) form)
-    (else #f)))
+  (and (non-empty-list? form)
+       (let ((core (fn-core form)))
+         (and (pair? core) (eq? (car core) 'fn) form))))
 
 (define (sex-fn-public? fn-form)
-  (eq? (first fn-form) 'pub))
+  (eq? (car fn-form) 'pub))
 
 (define (sex-fn-name fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (second (fn-core fn-form)))
+  (cadr (fn-core fn-form)))
 
 (define (sex-fn-arglist fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (third (fn-core fn-form)))
+  (caddr (fn-core fn-form)))
 
 (define (sex-fn-return-type fn-form)
   (assert (sex-fn? fn-form)
           (fmt #f "Form " fn-form " is not a function"))
-  (fourth (fn-core fn-form)))
+  (cadddr (fn-core fn-form)))
 
 (define (sex-fn-prototype fn-form)
   "Returns all except body"

sex-fmt-c.scm

@@ -737,13 +737,10 @@
            (cat (c-type (cadr type) #f)
                 " (*" (or name "") ")("
                 (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
-          ;; MODIFIED FROM UPSTREAM fmt-c: a nameless declarator -- an
-          ;; array parameter of a function type, where C has no room
-          ;; for a name -- arrives as #f, and upstream printed it
           ((%array)
-           (let ((name (cat (or name "") "[" (if (pair? (cddr type))
-                                                 (c-expr (caddr type))
-                                                 "")
+           (let ((name (cat name "[" (if (pair? (cddr type))
+                                         (c-expr (caddr type))
+                                         "")
                             "]")))
              (c-type (cadr type) name)))
           ((%pointer *)
@@ -776,13 +773,10 @@
            (cat (c-type (cadr type) #f)
                 " (*" (or name "") ")("
                 (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
-          ;; MODIFIED FROM UPSTREAM fmt-c: a nameless declarator -- an
-          ;; array parameter of a function type, where C has no room
-          ;; for a name -- arrives as #f, and upstream printed it
           ((%array)
-           (let ((name (cat (or name "") "[" (if (pair? (cddr type))
-                                                 (c-expr (caddr type))
-                                                 "")
+           (let ((name (cat name "[" (if (pair? (cddr type))
+                                         (c-expr (caddr type))
+                                         "")
                             "]")))
              (c-type (cadr type) name)))
           ((%pointer *)

sex-macros.scm

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

sex-modules.scm

@@ -8,7 +8,6 @@
   (chicken process-context)
   (chicken string)
   fmt
-  matchable
   reader
   srfi-1
   utils)
@@ -72,35 +71,34 @@
      (list)
      raw-forms)))
 
-(define (public-fn-interface raw-form)
+(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 ((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)))))
+  (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)
-  (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)))
+  (case (car form)
+    ((pub)
+     (case (cadr form)
+       ;; A function is reduced to a prototype and keeps its `pub', so
+       ;; the importing unit declares it with external linkage
+       ((fn)
+        (cons (copy-form-source! form (public-fn-interface form)) acc))
+       ;; A variable becomes an `extern' declaration
+       ((var)
+        (cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc))
+       ((define defmacro enum import include struct typedef union)
+        (cons (copy-form-source! form (cdr form)) acc))
+       (else (sex-error form "pub must be followed by a definition" form))))
+    (else acc)))
 
 (define (load-persistent-module-paths)
   (let ((sex-module-path-env-var

tests/modules/Makefile

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

tests/modules/greet.sex

@@ -7,11 +7,7 @@
 
 (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 var greet-count int 0)
 
 (pub struct greeting
   "A greeting to print."
@@ -29,8 +25,7 @@
            (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
+(pub fn greet ((name (* const char))) void
   "Print a greeting for NAME."
   (++ greet-count)
   (printf "hello, %s\n" name))

tests/reader.scm

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

tests/semen.scm

@@ -115,17 +115,4 @@
           (union t-doc-val ((i int) (f float))))
         (semen-process
          '((union t-doc-val "Either." ((i int) (f float))))))
-
-  ;; Includes
-  (test '((include stdio.h))
-        (semen-process
-         '((include stdio.h))))
-  (test '((include stdio.h)
-          (include stdlib.h))
-        (semen-process
-         '((include stdio.h
-                    stdlib.h))))
-  (test '()
-        (semen-process
-         '((include))))
-)
+)

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

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

tests/types.scm

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

tools/sextest/sextest.scm

@@ -1,5 +1,4 @@
 (import scheme
-        (scheme base)                   ; let-values
         brev-separate
         (chicken base)
         (chicken file)
@@ -34,45 +33,27 @@
          (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
+;;; --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)))
-    (let loop ((flags (if compilation
-                          (string-split (cadr compilation))
+    (if compilation
+        (append-map (lambda (flag)
+                      (if (string-prefix? "--features=" flag)
+                          (map string->symbol
+                               (string-split (substring flag 11) ","))
                           (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))))))
+                    (string-split (cadr compilation)))
+        (list))))
 
 (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)))))))
+  (let* ((first-pass (split-settings (read-raw-forms target-path)))
+         (features (compilation-features (car first-pass))))
+    (if (null? features)
+        first-pass
+        (parameterize ((current-features (append (platform-features) features)))
+          (split-settings (read-raw-forms target-path))))))
 
 (define (compile src compilation sexc)
   (let ((compiler (or

tools/sextest/utils.module.scm

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

types.module.scm

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

types.scm

@@ -15,11 +15,7 @@
   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
+(define +type-db+ (make-hash-table))
 
 (define (strip-pub form)
   (if (eq? (car form) 'pub) (cdr form) form))
@@ -48,17 +44,17 @@
         (list))))
 
 (define (add-struct name form)
-  (hash-table-set! +tag-db+ name
+  (hash-table-set! +type-db+ name
                    (list 'struct name (normalize-fields (aggregate-fields form)))))
 
 (define (add-union name form)
-  (hash-table-set! +tag-db+ name
+  (hash-table-set! +type-db+ name
                    (list 'union name (normalize-fields (aggregate-fields form)))))
 
 ;;; ([pub] enum name (value ...))
 (define (add-enum name form)
   (let ((f (strip-pub form)))
-    (hash-table-set! +tag-db+ name
+    (hash-table-set! +type-db+ name
                      (list 'enum name (if (and (pair? (cddr f)) (list? (caddr f)))
                                           (caddr f)
                                           (list))))))
@@ -74,14 +70,8 @@
   (hash-table-set! +type-db+ name
                    (list 'define name (cddr (strip-pub form)))))
 
-(define (get-tag-info name)
-  (hash-table-ref/default +tag-db+ name #f))
-
-;;; First look up the ordinary identifier, then tag of that id when
-;;; no ordinary one was declared, as C does
 (define (get-type-info name)
-  (or (hash-table-ref/default +type-db+ name #f)
-      (get-tag-info name)))
+  (hash-table-ref/default +type-db+ name #f))
 
 ;;; ((name type) ...) for a struct or union, #f for anything else --
 ;;; including a name that was never declared. Callers give the better
@@ -110,31 +100,19 @@
 
 ;;; 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)))
-
+;;; NAME's own info.
 (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))))
+             (let* ((target (get-underlying-type name))
+                    (tag (cond ((symbol? target) target)
+                               ((and (pair? target)
+                                     (pair? (cdr target))
+                                     (symbol? (cadr target)))
+                                (cadr target))
+                               (else #f))))
+               (and tag (get-type-info tag)))
              info))))
 
 ;;; Type matcher macro

utils.module.scm

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

utils.scm

@@ -42,24 +42,6 @@
        (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)