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

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)

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)))))

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

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))

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")

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")

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)))))