add type database and compile-time reflection
This commit is contained in:
15
Makefile
15
Makefile
@@ -15,7 +15,7 @@ CSC_FLAGS += -K prefix -static
|
|||||||
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
|
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
|
||||||
|
|
||||||
# Order matters, since module check correctness on compilation
|
# 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)
|
OBJ = $(MODULES:%=%.o)
|
||||||
|
|
||||||
sexc: $(OBJ) main.scm
|
sexc: $(OBJ) main.scm
|
||||||
@@ -28,6 +28,9 @@ sexc: $(OBJ) main.scm
|
|||||||
utils.o: utils.module.scm utils.scm
|
utils.o: utils.module.scm utils.scm
|
||||||
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
|
$(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
|
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
|
$(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
|
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
|
$(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
|
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,utils
|
$(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
|
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
|
$(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
|
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
|
$(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
|
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,utils
|
$(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
|
# Unit testing
|
||||||
sex-tests:
|
sex-tests:
|
||||||
@@ -58,7 +61,7 @@ sextest:
|
|||||||
$(MAKE) -C ./tools/sextest sextest
|
$(MAKE) -C ./tools/sextest sextest
|
||||||
cp ./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.
|
# Multi-module linking is checked end to end; see tests/modules/Makefile.
|
||||||
check-modules: sexc
|
check-modules: sexc
|
||||||
|
|||||||
64
example/serialize.sex
Normal file
64
example/serialize.sex
Normal file
@@ -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))
|
||||||
20
semen.scm
20
semen.scm
@@ -9,6 +9,7 @@
|
|||||||
fmt
|
fmt
|
||||||
sex-macros
|
sex-macros
|
||||||
sex-modules
|
sex-modules
|
||||||
|
types
|
||||||
matchable ; pattern matching
|
matchable ; pattern matching
|
||||||
srfi-1 ; list routines
|
srfi-1 ; list routines
|
||||||
srfi-69 ; hash tables
|
srfi-69 ; hash tables
|
||||||
@@ -72,7 +73,10 @@
|
|||||||
('pub 'var . _)
|
('pub 'var . _)
|
||||||
('extern 'var . _)) (process-global-var sex-form acc))
|
('extern 'var . _)) (process-global-var sex-form acc))
|
||||||
(('include _) (cons 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))
|
(('comment . _) (cons sex-form acc))
|
||||||
|
|
||||||
(('import . modules)
|
(('import . modules)
|
||||||
@@ -83,6 +87,7 @@
|
|||||||
|
|
||||||
((or ('typedef new-type target)
|
((or ('typedef new-type target)
|
||||||
('pub 'typedef new-type target))
|
('pub 'typedef new-type target))
|
||||||
|
(add-typedef new-type sex-form)
|
||||||
(process-typedef sex-form new-type target acc))
|
(process-typedef sex-form new-type target acc))
|
||||||
|
|
||||||
(else (sex-error sex-form "unknown top level form" sex-form))))
|
(else (sex-error sex-form "unknown top level form" sex-form))))
|
||||||
@@ -208,9 +213,22 @@
|
|||||||
|
|
||||||
;;; Structs
|
;;; Structs
|
||||||
|
|
||||||
|
;;; Record the named structs, unions and enums in the type database
|
||||||
(define (process-struct sex-struct acc)
|
(define (process-struct sex-struct acc)
|
||||||
|
(register-aggregate! sex-struct)
|
||||||
(cons sex-struct acc))
|
(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)
|
(define (process-global-var sex-var acc)
|
||||||
(cons sex-var acc))
|
(cons sex-var acc))
|
||||||
|
|
||||||
|
|||||||
@@ -1,6 +1,7 @@
|
|||||||
(module sex-macros
|
(module sex-macros
|
||||||
(register-macro
|
(register-macro
|
||||||
cat
|
cat
|
||||||
|
comment
|
||||||
get-macro
|
get-macro
|
||||||
macro?
|
macro?
|
||||||
apply-macro
|
apply-macro
|
||||||
|
|||||||
@@ -11,11 +11,23 @@
|
|||||||
(define (cat sym-1 sym-2)
|
(define (cat sym-1 sym-2)
|
||||||
(string->symbol (cat-syms 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)
|
(define (register-macro name arglist body)
|
||||||
(put! name 'sex-macro
|
(put! name 'sex-macro
|
||||||
`(lambda ,arglist
|
`(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
|
(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)))
|
,@body)))
|
||||||
|
|
||||||
(define (get-macro name)
|
(define (get-macro name)
|
||||||
|
|||||||
@@ -3,10 +3,10 @@ CHICKEN_C = csc
|
|||||||
CSC_FLAGS += -K prefix -static
|
CSC_FLAGS += -K prefix -static
|
||||||
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
|
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)
|
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)
|
TEST_SRCS = $(TESTS:%=%.scm)
|
||||||
|
|
||||||
sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
|
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
|
utils.o: utils.module.scm ../utils.scm
|
||||||
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
|
$(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
|
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
|
$(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
|
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
|
$(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
|
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,utils
|
$(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
|
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
|
$(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
|
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
|
$(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
|
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,utils
|
$(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:
|
clean:
|
||||||
rm -f $(SEX_OBJ)
|
rm -f $(SEX_OBJ)
|
||||||
|
|||||||
@@ -171,6 +171,22 @@ compiles."
|
|||||||
(emits? (in-fn "(var x int (c-or a b))") "a || b"))
|
(emits? (in-fn "(var x int (c-or a b))") "a || b"))
|
||||||
(test-assert "c-bit-or is still accepted"
|
(test-assert "c-bit-or is still accepted"
|
||||||
(emits? (in-fn "(var x int (c-bit-or a b))") "a | b")))
|
(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
|
;; Diagnostics name also the place. Every form carries a (file
|
||||||
;; . line), so an error can cite it
|
;; . line), so an error can cite it
|
||||||
(test-group "errors cite the source location"
|
(test-group "errors cite the source location"
|
||||||
|
|||||||
@@ -9,6 +9,7 @@
|
|||||||
(include "line-directives.scm")
|
(include "line-directives.scm")
|
||||||
(include "codegen.scm")
|
(include "codegen.scm")
|
||||||
(include "args.scm")
|
(include "args.scm")
|
||||||
|
(include "types.scm")
|
||||||
|
|
||||||
;;; Should be the last in the test suite
|
;;; Should be the last in the test suite
|
||||||
(test-exit)
|
(test-exit)
|
||||||
|
|||||||
37
tests/sex-programs/serialize.sex
Normal file
37
tests/sex-programs/serialize.sex
Normal file
@@ -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))
|
||||||
3
tests/types.module.scm
Normal file
3
tests/types.module.scm
Normal file
@@ -0,0 +1,3 @@
|
|||||||
|
(module types
|
||||||
|
*
|
||||||
|
"../types.scm")
|
||||||
106
tests/types.scm
Normal file
106
tests/types.scm
Normal file
@@ -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)))
|
||||||
14
types.module.scm
Normal file
14
types.module.scm
Normal file
@@ -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")
|
||||||
133
types.scm
Normal file
133
types.scm
Normal file
@@ -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)))))
|
||||||
Reference in New Issue
Block a user