resolve typedefs in get-fields and map-fields

Now these macro helpers take in account the possibility of typedefing
one type to another, and correctly find the one intended

.gitea/workflows/build.yaml

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

.github/workflows/build.yaml

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

fmt-c-writer.scm

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

semen.scm

@@ -93,17 +93,9 @@
     (else (sex-error sex-form "unknown top level form" sex-form))))
 
 (define (process-imports module-public-forms acc)
-  ;; Recursively process imports: register public macros, cons all
+  ;; consume (import ...) form and process imports so
-  ;; other public things to our acc
+  ;; data types end up in types db
-  (if (null? module-public-forms) acc
+  (fold match-sex-form acc module-public-forms))
-      (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."

sex-fmt-c.scm

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

sex-modules.scm

@@ -14,6 +14,10 @@
 
 (define +persistent-module-paths+ (list))
 
+;;; for guarding against multiple imports (sort of mandatory #pragma
+;;; once)
+(define +imported-modules+ (list))
+
 (define (get-modules-public-forms module-list)
   ;; Module list is a list of symbols
   ;; How Sex handles modules:
@@ -29,7 +33,11 @@
   (let ((module-path (locate-module name)))
     (assert module-path (fmt #f "Failed to find module " name " in "
                              (get-module-paths)))
-    (read-public-interface module-path)))
+    (if (member module-path +imported-modules+)
+        (list)
+        (begin
+          (set! +imported-modules+ (cons module-path +imported-modules+))
+          (read-public-interface module-path)))))
 
 (define (get-module-paths)
   (cons (current-directory)
@@ -75,7 +83,7 @@
        ;; A variable becomes an `extern' declaration
        ((var)
         (cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc))
-       ((define defmacro import include struct typedef union)
+       ((define defmacro enum import include struct typedef union)
         (cons (copy-form-source! form (cdr form)) acc))
        (else (sex-error form "pub must be followed by a definition" form))))
     (else acc)))

tests/codegen.scm

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

tests/modules/Makefile

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

tests/modules/greet-app.sex

@@ -7,6 +7,9 @@
 ;;; as a prototype and `greet-count' as an extern. Both keep external
 ;;; linkage, so they refer to the one definition in greet.o rather than
 ;;; to private copies.
+;;;
+;;; Also check that import populates type-database, by means of
+;;; describe-fields macro, which should work on imported type.
 
 (include stdio.h)
 
@@ -16,4 +19,11 @@
   (greet "world")
   (greet "sex")
   (printf "%d greetings\n" greet-count)
+  (describe-fields greeting)
+  (printf "\n")
+  ;; ...and through the imported typedef for it
+  (describe-fields greeting-t)
+  (printf "\n")
+  (var m (enum mood) grumpy)
+  (printf "mood %d\n" m)
   (return 0))

tests/modules/greet.sex

@@ -9,6 +9,20 @@
 
 (pub var greet-count int 0)
 
+(pub struct greeting ((text (* const char)) (times int)))
+
+(pub enum mood (cheerful grumpy))
+
+(pub typedef greeting-t (struct greeting))
+
+;;; Compile-time reflection across the module boundary: both the macro
+;;; and the struct it asks about are exported, and the importing unit
+;;; has to know the struct's fields to expand this.
+(pub defmacro (describe-fields type)
+  `(do ,@(map-fields type
+           (lambda (name field-type)
+             `(printf "%s " ,(symbol->string name))))))
+
 (pub fn greet ((name (* const char))) void
   (++ greet-count)
   (printf "hello, %s\n" name))

tests/types.scm

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

types.scm

@@ -76,21 +76,44 @@
 ;;; ((name type) ...) for a struct or union, #f for anything else --
 ;;; including a name that was never declared. Callers give the better
 ;;; error, since they know what they wanted it for.
+;;;
+;;; A typedef is followed to what it stands for, so reflection over an
+;;; alias works exactly as it does over the name it aliases.
 (define (get-fields name)
-  (let ((info (get-type-info name)))
+  (let ((info (resolve-type-info name)))
     (and info
          (memq (car info) '(struct union))
          (caddr info))))
 
-;;; Follow a typedef chain to the name it ultimately stands for. #f if
+;;; Follow a typedef chain to the name it stands for. #f if NAME is
-;;; NAME is not a typedef.
+;;; not a typedef. A typedef that leads back to itself stops rather
+;;; than spinning: nothing prevents one from being written.
 (define (get-underlying-type name)
+  (let follow ((name name) (seen (list)))
+    (and (not (member name seen))
          (let ((info (get-type-info name)))
            (and info
                 (eq? (car info) 'typedef)
                 (let ((target (caddr info)))
-           (or (and (symbol? target) (get-underlying-type target))
+                  (or (and (symbol? target) (follow target (cons name seen)))
-               target)))))
+                      target)))))))
+
+;;; The declaration NAME ultimately names. For a typedef that is the
+;;; entry of whatever it stands for, and for anything else it is
+;;; NAME's own info.
+(define (resolve-type-info name)
+  (let ((info (get-type-info name)))
+    (and info
+         (if (eq? (car info) 'typedef)
+             (let* ((target (get-underlying-type name))
+                    (tag (cond ((symbol? target) target)
+                               ((and (pair? target)
+                                     (pair? (cdr target))
+                                     (symbol? (cadr target)))
+                                (cadr target))
+                               (else #f))))
+               (and tag (get-type-info tag)))
+             info))))
 
 ;;; Type matcher macro
 ;;; (type-match type
@@ -119,15 +142,16 @@
 ;;;
 ;;; Returns #f if nothing of that name was declared
 (define (map-fields struct-union-enum fn)
-  (let ((info (get-type-info struct-union-enum)))
+  (let ((info (resolve-type-info struct-union-enum)))
     (and info
          (case (car info)
            ((struct union)
             (map (lambda (field) (fn (car field) (cadr field)))
                  (caddr info)))
-           ;; An enumerator's type is the enum itself.
+           ;; An enumerator's type is the enum itself -- named as it was
+           ;; declared, since `enum some-typedef' is not a C type.
            ((enum)
-            (let ((type (list 'enum struct-union-enum)))
+            (let ((type (list 'enum (cadr info))))
               (map (lambda (value) (fn value type))
                    (caddr info))))
            (else #f)))))