add type database and compile-time reflection

tests/Makefile

@@ -3,10 +3,10 @@ CHICKEN_C = csc
 CSC_FLAGS += -K prefix -static
 MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
 
-MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
+MODULES = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
 SEX_OBJ = $(MODULES:%=%.o)
 
-TESTS = basic semen reader fmt-c-writer utils line-directives codegen args
+TESTS = basic semen reader fmt-c-writer utils line-directives codegen args types
 TEST_SRCS = $(TESTS:%=%.scm)
 
 sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
@@ -17,6 +17,9 @@ sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
 utils.o: utils.module.scm ../utils.scm
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
 
+types.o: types.module.scm ../types.scm
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types
+
 sex-macros.o: sex-macros.module.scm ../sex-macros.scm
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
 
@@ -26,8 +29,8 @@ reader.o: reader.module.scm ../reader.scm utils.o
 sex-modules.o: sex-modules.module.scm ../sex-modules.scm reader.o utils.o
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
 
-semen.o: semen.module.scm ../semen.scm sex-macros.o sex-modules.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,utils
+semen.o: semen.module.scm ../semen.scm sex-macros.o sex-modules.o types.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,types,utils
 
 sex-fmt-c.o: ../sex-fmt-c.scm
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) ../sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
@@ -35,8 +38,8 @@ sex-fmt-c.o: ../sex-fmt-c.scm
 fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o utils.o
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
 
-sexc.o: sexc.module.scm ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils
+sexc.o: sexc.module.scm types.o ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,types,utils
 
 clean:
 	rm -f $(SEX_OBJ)

tests/codegen.scm

@@ -171,6 +171,22 @@ compiles."
       (emits? (in-fn "(var x int (c-or a b))") "a || b"))
     (test-assert "c-bit-or is still accepted"
       (emits? (in-fn "(var x int (c-bit-or a b))") "a | b")))
+
+  ;; A `;' comment is a form. In a macro body `comment' is a no-op
+  ;; that swallows the comment itself. Inside a quasiquoted payload
+  ;; the same form is data, never evaluated, and reaches the writer
+  ;; intact
+  (test-group "comments in macros"
+    (test-assert "a comment in the payload reaches the C"
+      (emits? "(defmacro (m-kept) `(fn f () void\n ;; this survives\n (g)))\n(m-kept)"
+              "this survives"))
+    (test-assert "a comment about the macro does not"
+      (not (emits? "(defmacro (m-dropped)\n ;; this vanishes\n `(fn f () void (g)))\n(m-dropped)"
+                   "this vanishes")))
+    (test-assert "and the macro still expands"
+      (emits? "(defmacro (m-both)\n ;; about the macro\n `(fn f () void (g)))\n(m-both)"
+              "void f (void)")))
+
   ;; Diagnostics name also the place. Every form carries a (file
   ;; . line), so an error can cite it
   (test-group "errors cite the source location"

tests/run.scm

@@ -9,6 +9,7 @@
 (include "line-directives.scm")
 (include "codegen.scm")
 (include "args.scm")
+(include "types.scm")
 
 ;;; Should be the last in the test suite
 (test-exit)

tests/sex-programs/serialize.sex

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

tests/types.module.scm

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

tests/types.scm

@@ -0,0 +1,106 @@
+;;; The type database.
+;;;
+;;; Names here are prefixed so they cannot collide with the types the
+;;; other suites register: the database is one table in the linked
+;;; binary, and semen fills it in whenever a suite compiles a struct.
+
+(import types)
+
+(test-group "types"
+
+  (add-struct 't-point '(struct t-point ((x int) (y int))))
+  (test "fields come back as (name type)"
+        '((x int) (y int))
+        (get-fields 't-point))
+  (test "and the whole entry is tagged"
+        '(struct t-point ((x int) (y int)))
+        (get-type-info 't-point))
+
+  ;; Fields are written with the type last, so one entry can declare
+  ;; several names. They come back as one field each.
+  (add-struct 't-settings
+              '(pub struct t-settings ((x y w h u32) (title (* const char)))))
+  (test "names sharing a type are split apart"
+        '((x u32) (y u32) (w u32) (h u32) (title (* const char)))
+        (get-fields 't-settings))
+
+  (add-struct 't-commented '(struct t-commented ((comment " hi") (a int))))
+  (test "a comment among the fields is not a field"
+        '((a int))
+        (get-fields 't-commented))
+
+  (add-union 't-value '(union t-value ((i int) (f float))))
+  (test "unions have fields too"
+        '((i int) (f float))
+        (get-fields 't-value))
+
+  (add-enum 't-color '(enum t-color (red green blue)))
+  (test "enums keep their values"
+        '(enum t-color (red green blue))
+        (get-type-info 't-color))
+  (test "but have no fields"
+        #f
+        (get-fields 't-color))
+
+  (add-typedef 't-u8 '(typedef t-u8 uint8-t))
+  (test "a typedef resolves to its target"
+        'uint8-t
+        (get-underlying-type 't-u8))
+  (add-typedef 't-byte '(typedef t-byte t-u8))
+  (test "and chains are followed to the end"
+        'uint8-t
+        (get-underlying-type 't-byte))
+  (test "a struct is not a typedef"
+        #f
+        (get-underlying-type 't-point))
+
+  ;; A #define keeps its value forms -- there can be more than one.
+  (add-define 't-maxn '(define t-maxn 8))
+  (test "defines are recorded"
+        '(define t-maxn (8))
+        (get-type-info 't-maxn))
+
+  ;; map-fields walks an aggregate, handing each field to a function.
+  (test "map-fields visits every field"
+        '((x int) (y int))
+        (map-fields 't-point (lambda (name type) (list name type))))
+  (test "and splits shared names apart too"
+        '(x y w h title)
+        (map-fields 't-settings (lambda (name type) name)))
+  ;; An enumerator's type is the enum itself.
+  (test "enum values are fields whose type is the enum"
+        '((red (enum t-color)) (green (enum t-color)) (blue (enum t-color)))
+        (map-fields 't-color (lambda (name type) (list name type))))
+  (test "a typedef has no fields to map"
+        #f
+        (map-fields 't-u8 (lambda (name type) name)))
+  (test "nor does an undeclared name"
+        #f
+        (map-fields 't-nothing (lambda (name type) name)))
+
+  ;; type-match compares whole types, since a type is a form.
+  (test "a bare type matches"      'yes (type-match 'int (int 'yes) (else 'no)))
+  (test "so does a compound one"   'yes (type-match '(* const char)
+                                                    (int 'no)
+                                                    ((* const char) 'yes)
+                                                    (else 'no)))
+  ;; The [int 10] of the docstring is Sex notation: the Sex reader turns
+  ;; brackets into a ¤ form, while CHICKEN reads them as plain parens.
+  ;; In a .scm file the array type has to be written out.
+  (test "and an array"             'yes (type-match '(¤ int 10)
+                                                    ((¤ int 10) 'yes)
+                                                    (else 'no)))
+  (test "else catches the rest"    'no  (type-match '(* void) (int 'yes) (else 'no)))
+  (test "a near miss does not match" 'no (type-match '(¤ int 20)
+                                                     ((¤ int 10) 'yes)
+                                                     (else 'no)))
+  (test "no clause matching and no else is #f"
+        #f
+        (type-match 'float (int 'yes)))
+
+  (test "an undeclared name has no entry"
+        #f
+        (get-type-info 't-never-declared))
+  (test "and no fields"
+        #f
+        (get-fields 't-never-declared)))