diff --git a/Makefile b/Makefile index 5be8aa2..04094b6 100644 --- a/Makefile +++ b/Makefile @@ -81,8 +81,8 @@ semen.o: semen.module.scm semen.scm infer.o sex-macros.o sex-modules.o types.o u 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 -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 +fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o types.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,types,utils sexc.o: sexc.module.scm infer.o 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,infer,types,utils @@ -98,7 +98,7 @@ sextest: SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \ feature-flags lambdas compound-literals closures fixpoint \ - wildcards inference + wildcards inference type-shapes # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 4ca7c43..da1f38f 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -13,6 +13,7 @@ (chicken irregex) ; unkebabify srfi-1 ; lists srfi-13 ; strings + types ; array-bound?, named-arg? utils) ;;; egg `tree' not ported to CHICKEN 6 yet @@ -292,27 +293,6 @@ forms, and what remains." (list) (walk-expr (drop form 3)))))) ; optional init expression -;;; `(¤ int N)' is N of int -;;; `(¤ unsigned int)' is an unsized array of unsigned int -;;; An aggregate is the exception -- `(¤ struct point)' ends in a tag, -;;; which is part of the type and not a bound. - -(define +c-type-words+ - '(void char short int long float double signed unsigned - bool _Bool complex _Complex _Atomic const volatile restrict)) - -(define (array-bound? array-type) - (and (> (length array-type) 1) - (let ((bound (last array-type)) - (preceding (last (drop-right array-type 1)))) - (cond - ((not (symbol? bound)) #t) - ((memq bound +c-type-words+) #f) - ;; a tag always follows its keyword, so `(¤ * struct tt)' ends - ;; in a name belonging to the type - ((memq preceding '(struct union enum)) #f) - (else #t))))) - (define (walk-type form) ;; int -> int ;; (const int) -> const int @@ -323,16 +303,11 @@ forms, and what remains." ;; (fn ((int) (float)) void) -> (%fun void ((int) (float))) (match form (('¤ . array-type) - (if (array-bound? array-type) - ;; sized array - (let* ((type-list (drop-right array-type 1)) - (type (maybe-unwrap-type type-list)) - (size (last array-type))) - `(%array ,(walk-type type) - ,size)) + (if (array-bound? form) + `(%array ,(walk-type (array-element-type form)) ,(last array-type)) ;; sugar for pointer... Do we really need it? Guess why not, ;; it's a strong semantic cue - `(%array ,(walk-type (maybe-unwrap-type array-type))))) + `(%array ,(walk-type (array-element-type form))))) (('fn arglist ret-type) `(%fun ,(walk-type ret-type) ,(walk-arg-types arglist))) (('fn . _) @@ -398,21 +373,6 @@ forms, and what remains." . ,(walk-body maybe-body))))) -;;; TODO: isn't there a better way? -(define (is-probably-type form) - (case (car form) - ((¤ * 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) diff --git a/semen.scm b/semen.scm index c9459d2..23081ed 100644 --- a/semen.scm +++ b/semen.scm @@ -276,7 +276,7 @@ ;;; through untouched. (define (fn-type-of fn-form) `(fn ,(map (lambda (param) - (if (and (pair? param) (= 2 (length param))) + (if (and (pair? param) (= 2 (length param)) (named-arg? param)) (list (second param)) param)) (sex-fn-arglist fn-form)) @@ -550,9 +550,10 @@ (and (symbol? (car expr)) (get-return-type (car expr)))) (else (case (car expr) + ;; subscripting an array gives its element type, and a pointer + ;; subscripts the same way ((¤) (let ((base (expression-type (second expr) env))) - (and (list? base) (>= (length base) 2) (eq? '¤ (car base)) - (second base)))) + (or (array-element-type base) (pointer-target base)))) ((&) (and (= 2 (length expr)) (let ((target (expression-type (second expr) env))) (and target `(* ,target))))) diff --git a/tests/Makefile b/tests/Makefile index ab046d8..deae867 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -38,8 +38,8 @@ semen.o: semen.module.scm ../semen.scm infer.o sex-macros.o sex-modules.o types. 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 -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 +fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o types.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,types,utils sexc.o: sexc.module.scm infer.o 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,infer,types,utils diff --git a/tests/sex-programs/type-shapes.sex b/tests/sex-programs/type-shapes.sex new file mode 100644 index 0000000..56a99df --- /dev/null +++ b/tests/sex-programs/type-shapes.sex @@ -0,0 +1,72 @@ +(input) +(output "aggregate element: 3 4" + "pointer element: there" + "multi-word element: 9" + "through a pointer: 55" + "unsized of a typedef: 1 2" + "unsized of a pointer: 5" + "unnamed parameters: 7 -1 2") +(return 0) + +;;; Three questions about a written type that used to be answered in +;;; three places and disagreed: is `(a b)' a named parameter or a bare +;;; type, is the last element of a `¤' its bound or the last word of +;;; its element type, and what is one element of an array. +;;; +;;; They are one question -- where does the type end -- so the answer +;;; lives in `types' and everything else asks it. + +(include stdio.h) + +(struct point ((x int) (y int))) + +(typedef small int) + +;;; a parameter that names nothing is a type, however many words it +;;; takes: `(unsigned int)' is one of them, not a `unsigned' called +;;; `int' +(fn width ((n unsigned int)) int + (return (cast n int))) + +(fn sign ((c const char)) int + (if (== c #\a) (return -1)) + (return 1)) + +(fn twice ((n small)) int + (return (* n 2))) + +(pub fn main () int + ;; an element keeps every word of its type, tag and all + (var pts (¤ (struct point) 2) #(#((struct point) : 1 2) + #((struct point) : 3 4))) + (var p _ (¤ pts 1)) + (printf "aggregate element: %d %d\n" (. p x) (. p y)) + + (var names (¤ (* const char) 2) #("hi" "there")) + (var s _ (¤ names 1)) + (printf "pointer element: %s\n" s) + + (var nums (¤ unsigned int 3) #(7 8 9)) + (var u _ (¤ nums 2)) + (printf "multi-word element: %u\n" u) + + ;; subscripting a pointer answers the same as subscripting an array + (var q (* (struct point)) (& (¤ pts 0))) + (var r _ (¤ q 1)) + (printf "through a pointer: %d\n" (+ (. r x) (* 13 (. r y)))) + + ;; the last word of an unsized array's type is not its bound: neither + ;; a typedef name nor the target of a `*' can be one + (var tail (¤ const small) #(1 2)) + (printf "unsized of a typedef: %d %d\n" (¤ tail 0) (¤ tail 1)) + + (var one size-t 5) + (var sizes (¤ * size-t) #((& one))) + (var w _ (¤ sizes 0)) + (printf "unsized of a pointer: %d\n" (cast (* w) int)) + + ;; the same question in type position: `(fn ((unsigned int)) int)' + ;; takes one parameter, not two + (var fp (fn ((unsigned int)) int) width) + (printf "unnamed parameters: %d %d %d\n" (fp 7) (sign #\a) (twice 1)) + (return 0)) diff --git a/tests/types.module.scm b/tests/types.module.scm index cbce298..cf06139 100644 --- a/tests/types.module.scm +++ b/tests/types.module.scm @@ -18,5 +18,11 @@ get-type-info get-tag-info get-fields - get-underlying-type) + get-underlying-type + + type-head? + named-arg? + typedef-name? + array-bound? + array-element-type) "../types.scm") diff --git a/types.module.scm b/types.module.scm index 742bfea..ed00b5c 100644 --- a/types.module.scm +++ b/types.module.scm @@ -18,5 +18,11 @@ get-type-info get-tag-info get-fields - get-underlying-type) + get-underlying-type + + type-head? + named-arg? + typedef-name? + array-bound? + array-element-type) "types.scm") diff --git a/types.scm b/types.scm index 0a0ad22..2f8e937 100644 --- a/types.scm +++ b/types.scm @@ -237,3 +237,77 @@ (map (lambda (value) (fn value type)) (caddr info)))) (else #f))))) + +;;; The shape of a written type +;;; +;;; Three places have to tell a type from something that merely +;;; contains one: an arglist entry is either `(name type)' or a bare +;;; type, and an array's last element is either a bound or the last +;;; word of its element type. They used to answer it separately, and +;;; disagreed. + +;;; A qualifier can never end a type, which is what tells `(¤ const t)' +;;; -- an unsized array of `t' -- from `(¤ int 4)'. +(define +c-qualifiers+ '(const volatile restrict _Atomic)) + +(define +c-specifiers+ + '(void char short int long float double signed unsigned + bool _Bool complex _Complex)) + +;;; Does this list start a type rather than name one? `(const char)' +;;; and `(unsigned int)' are types; `(f1 float)' is a named parameter. +(define (type-head? form) + (and (pair? form) + (symbol? (car form)) + (or (memq (car form) '(* ¤ struct union enum)) + (memq (car form) +c-qualifiers+) + (memq (car form) +c-specifiers+)))) + +;;; Does the parameter name itself? +;;; (f1 float) does +;;; (float), (const char), (unsigned int) and (¤ float 4) do not +(define (named-arg? arg) + (and (pair? arg) + (pair? (cdr arg)) ; 1 element args are always type + (not (type-head? arg)))) + +;;; Is NAME a typedef, as opposed to a `define'd constant? Both live in +;;; the same table, and only the first is part of a type. +(define (typedef-name? name) + (let ((info (and (symbol? name) (get-type-info name)))) + (and info (memq (car info) '(typedef struct union enum)) #t))) + +;;; `(¤ int N)' is N of int +;;; `(¤ unsigned int)' is an unsized array of unsigned int +;;; +;;; The last element is a bound only if what precedes it is already a +;;; complete type, so `(¤ const mytype)' and `(¤ * size-t)' end in the +;;; last word of their element type and not in a bound. A type is +;;; complete when it ends in a specifier, in a tag following its +;;; keyword, or in a typedef we have seen declared. +;;; +;;; TYPE is the whole `(¤ ...)' form. +(define (array-bound? type) + (and (> (length type) 2) + (let ((bound (last type)) + (preceding (last (drop-right type 1)))) + (cond + ((not (symbol? bound)) #t) + ((or (memq bound +c-specifiers+) (memq bound +c-qualifiers+)) #f) + ((memq preceding +c-specifiers+) #t) + ;; a tag always follows its keyword, so `(¤ * struct tt)' ends + ;; in a name belonging to the type + ((memq preceding '(struct union enum)) #f) + (else (typedef-name? preceding)))))) + +;;; What one element of a written array type is: +;;; (¤ struct point 2) -> (struct point), (¤ * const char 2) -> (* const char) +(define (array-element-type type) + (and (pair? type) + (eq? '¤ (car type)) + (pair? (cdr type)) + (let ((words (if (array-bound? type) + (drop-right (cdr type) 1) + (cdr type)))) + (and (pair? words) + (if (null? (cdr words)) (car words) words)))))