diff --git a/Makefile b/Makefile index a540e4b..930f804 100644 --- a/Makefile +++ b/Makefile @@ -15,7 +15,7 @@ CSC_FLAGS += -K prefix -static MODULE_FLAGS = -emit-all-import-libraries -module-registration -c # Order matters, since module check correctness on compilation -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 OBJ = $(MODULES:%=%.o) sexc: $(OBJ) main.scm @@ -28,6 +28,9 @@ sexc: $(OBJ) main.scm 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 @@ -37,8 +40,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 @@ -46,8 +49,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 # Unit testing sex-tests: @@ -58,7 +61,7 @@ sextest: $(MAKE) -C ./tools/sextest sextest cp ./tools/sextest/sextest . -SEX_TEST_PROGRAMS = hello-world lists comments unicode +SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/example/serialize.sex b/example/serialize.sex new file mode 100644 index 0000000..b6d2d6d --- /dev/null +++ b/example/serialize.sex @@ -0,0 +1,64 @@ +;;; Generating code from a type's own definition. +;;; +;;; `serialize-struct' is handed nothing but a struct's name. It asks +;;; the compiler's type database what fields that struct has and what +;;; type each one is, and writes a printer to match. Add a field to the +;;; struct and the printer grows with it, with no other edit. +;;; +;;; The database is filled in as toplevel forms are processed, in order, +;;; so a struct has to be declared before the macro call that asks about +;;; it -- the same rule C has. + +(include stdio.h) + +(defmacro (serialize-struct type-name) + ;; map-fields walks the declaration; type-match picks a printf + ;; conversion per field. Both come from the compiler's type database, + ;; so the macro never takes a type apart itself. + (let ((printers + (map-fields type-name + (lambda (name type) + `(fprintf out + ,(string-append + " " (symbol->string name) "=" + (type-match type + (int "%d") + (char "%c") + (long "%ld") + (unsigned "%u") + (float "%g") + (double "%g") + ((* const char) "%s") + ((* char) "%s") + (else (error "serialize-struct: unsupported field type" + type-name name type)))) + (-> v ,name)))))) + (if (not printers) + (error "serialize-struct: no such struct" type-name) + `(pub fn ,(cat 'serialize- type-name) + ((v (* const struct ,type-name)) (out (* FILE))) + void + (fprintf out ,(string-append (symbol->string type-name) " {")) + ,@printers + (fprintf out " }\n"))))) + +(struct point ((x int) (y int))) + +(struct person + ((name (* const char)) + (age int) + (height float))) + +;;; Two printers, written by the compiler from the declarations above. +(serialize-struct point) +(serialize-struct person) + +(pub fn main () int + (var origin (struct point) #(0 0)) + (var corner (struct point) #(640 -480)) + (var alex (struct person) #("Alex" 34 1.82)) + + (serialize-point (& origin) stdout) + (serialize-point (& corner) stdout) + (serialize-person (& alex) stdout) + (return 0)) diff --git a/semen.scm b/semen.scm index 64f16e9..7daaf91 100644 --- a/semen.scm +++ b/semen.scm @@ -9,6 +9,7 @@ fmt sex-macros sex-modules + types matchable ; pattern matching srfi-1 ; list routines srfi-69 ; hash tables @@ -72,7 +73,10 @@ ('pub 'var . _) ('extern 'var . _)) (process-global-var sex-form acc)) (('include _) (cons sex-form acc)) - (('define . _) (cons sex-form acc)) + ((or ('define name . _) + ('pub 'define name . _)) + (add-define name sex-form) + (cons sex-form acc)) (('comment . _) (cons sex-form acc)) (('import . modules) @@ -83,6 +87,7 @@ ((or ('typedef new-type target) ('pub 'typedef new-type target)) + (add-typedef new-type sex-form) (process-typedef sex-form new-type target acc)) (else (sex-error sex-form "unknown top level form" sex-form)))) @@ -208,9 +213,22 @@ ;;; Structs +;;; Record the named structs, unions and enums in the type database (define (process-struct sex-struct acc) + (register-aggregate! sex-struct) (cons sex-struct acc)) +(define (register-aggregate! form) + (let* ((f (if (eq? (car form) 'pub) (cdr form) form)) + (name (and (pair? (cdr f)) (symbol? (cadr f)) (cadr f)))) + ;; An anonymous aggregate has a field list where the name would be, + ;; and nothing can refer to it by name anyway + (when name + (case (car f) + ((struct) (add-struct name form)) + ((union) (add-union name form)) + ((enum) (add-enum name form)))))) + (define (process-global-var sex-var acc) (cons sex-var acc)) diff --git a/sex-macros.module.scm b/sex-macros.module.scm index f211ab7..9837c04 100644 --- a/sex-macros.module.scm +++ b/sex-macros.module.scm @@ -1,6 +1,7 @@ (module sex-macros (register-macro cat + comment get-macro macro? apply-macro diff --git a/sex-macros.scm b/sex-macros.scm index 8d1b104..1923a46 100644 --- a/sex-macros.scm +++ b/sex-macros.scm @@ -11,11 +11,23 @@ (define (cat sym-1 sym-2) (string->symbol (cat-syms sym-1 sym-2))) +;;; The reader keeps `;' comments as (comment "...") forms so they can +;;; be re-emitted into the generated C. In a macro body a comment +;;; should be a call which does nothing, hence this one +(define (comment . _) + (void)) + (define (register-macro name arglist body) (put! name 'sex-macro `(lambda ,arglist + ;; A macro body is ordinary Scheme, evaluated at compile + ;; time. It gets `cat' for building names, and read access to + ;; the type database (import scheme - (only sex-macros cat)) + (scheme base) + (only sex-macros cat comment) + (only types get-type-info get-fields get-underlying-type + type-match map-fields)) ,@body))) (define (get-macro name) diff --git a/tests/Makefile b/tests/Makefile index 0251aaa..b40a19e 100644 --- a/tests/Makefile +++ b/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) diff --git a/tests/codegen.scm b/tests/codegen.scm index 6d4a0f9..8dc7637 100644 --- a/tests/codegen.scm +++ b/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" diff --git a/tests/run.scm b/tests/run.scm index 1256079..151ba89 100644 --- a/tests/run.scm +++ b/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) diff --git a/tests/sex-programs/serialize.sex b/tests/sex-programs/serialize.sex new file mode 100644 index 0000000..344d305 --- /dev/null +++ b/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)) diff --git a/tests/types.module.scm b/tests/types.module.scm new file mode 100644 index 0000000..bee50e2 --- /dev/null +++ b/tests/types.module.scm @@ -0,0 +1,3 @@ +(module types + * + "../types.scm") diff --git a/tests/types.scm b/tests/types.scm new file mode 100644 index 0000000..4d30ee0 --- /dev/null +++ b/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))) diff --git a/types.module.scm b/types.module.scm new file mode 100644 index 0000000..8f94b70 --- /dev/null +++ b/types.module.scm @@ -0,0 +1,14 @@ +(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") diff --git a/types.scm b/types.scm new file mode 100644 index 0000000..2654ed2 --- /dev/null +++ b/types.scm @@ -0,0 +1,133 @@ +;;; The type database. +;;; +;;; Every named aggregate, typedef and define the semantic engine +;;; walks past is recorded here, so that macros (or other forms) can +;;; ask what a type is made of. That is what lets a macro generate +;;; code from a struct's fields given nothing but its name. +;;; +;;; Entries are filled in as toplevel forms are processed, in order, so +;;; a type has to be declared before the macro that asks about it. + +(import + scheme + (scheme base) + (chicken base) + srfi-1 + srfi-69) + +(define +type-db+ (make-hash-table)) + +(define (strip-pub form) + (if (eq? (car form) 'pub) (cdr form) form)) + +(define (comment-form? f) + (and (pair? f) (eq? (car f) 'comment))) + +;;; Fields are written with the type last and one or more names before +;;; it, so ((x y int) (p (* char))) describes three fields. Flatten that +;;; into one (name type) per field, which is what a caller wants. +(define (normalize-fields fields) + (append-map + (lambda (field) + (if (comment-form? field) + (list) + (let ((type (last field)) + (names (drop-right field 1))) + (map (lambda (name) (list name type)) names)))) + (remove comment-form? fields))) + +;;; ([pub] struct name (fields ...) . attrs) +(define (aggregate-fields form) + (let ((f (strip-pub form))) + (if (and (pair? (cddr f)) (list? (caddr f))) + (caddr f) + (list)))) + +(define (add-struct name form) + (hash-table-set! +type-db+ name + (list 'struct name (normalize-fields (aggregate-fields form))))) + +(define (add-union name form) + (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! +type-db+ name + (list 'enum name (if (and (pair? (cddr f)) (list? (caddr f))) + (caddr f) + (list)))))) + +;;; ([pub] typedef new-name target) +(define (add-typedef name form) + (hash-table-set! +type-db+ name + (list 'typedef name (last (strip-pub form))))) + +;;; (define name value ...) -- a C #define, kept so a macro can read a +;;; compile-time constant rather than re-parse the source. +(define (add-define name form) + (hash-table-set! +type-db+ name + (list 'define name (cddr (strip-pub form))))) + +(define (get-type-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 +;;; error, since they know what they wanted it for. +(define (get-fields name) + (let ((info (get-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 +;;; NAME is not a typedef. +(define (get-underlying-type name) + (let ((info (get-type-info name))) + (and info + (eq? (car info) 'typedef) + (let ((target (caddr info))) + (or (and (symbol? target) (get-underlying-type target)) + target))))) + +;;; Type matcher macro +;;; (type-match type +;;; (int ...) +;;; ((* const char) ...) +;;; ([int 10] ...) +;;; (else ...)) +;;; +;;; A type is a form, not an atom, so this compares with equal? rather +;;; than dispatching like `case'. Patterns are literal types and are not +;;; evaluated; `else' is optional and the whole thing is #f when nothing +;;; matches and there is no else. +(define-syntax type-match + (syntax-rules (else) + ((_ type) #f) + ((_ type (else body ...)) (begin body ...)) + ((_ type (pattern body ...) clause ...) + (if (equal? type 'pattern) + (begin body ...) + (type-match type clause ...))))) + +;;; Map function to each field/value of a structure/union/enum +;;; For enums, field-type is the type of the enum (since C 23) +;;; (map-fields type-name +;;; (lambda (field-name field-type) ...)) +;;; +;;; Returns #f if nothing of that name was declared +(define (map-fields struct-union-enum fn) + (let ((info (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. + ((enum) + (let ((type (list 'enum struct-union-enum))) + (map (lambda (value) (fn value type)) + (caddr info)))) + (else #f)))))