show the cases the comments were describing

`walk-parts' walked the whole `var' form, and a `fn' type's parameter
list is shaped like a call: `(fn ((c int)) int)' came out as
`int (*fp)(c int)'. A closure literal had no type, so calling one in
place missed the rewrite; sextest fed sexc symbols Sex cannot read.

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
@@ -96,9 +96,24 @@ sextest:
 	$(MAKE) -C ./tools/sextest sextest
 	cp ./tools/sextest/sextest .
 
-SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \
-                    feature-flags lambdas compound-literals closures fixpoint \
-                    wildcards inference
+SEX_TEST_PROGRAMS = c99 \
+                    closure-signatures \
+                    closures \
+                    comments \
+                    compound-literals \
+                    feature-flags \
+                    features \
+                    fixpoint \
+                    hello-world \
+                    inference \
+                    lambdas \
+                    lists \
+                    operators \
+                    serialize \
+                    type-shapes \
+                    unicode \
+                    unnamed-params \
+                    wildcards
 
 # 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,40 +373,28 @@ 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)
       (walk-type (maybe-unwrap-type (cdr arg)))
       ;; A lone type may arrive wrapped in parens of its own, and those
-      ;; are not part of it: ((* const char))
-      ;; Plain names e.g. (int) are left as is
-      (walk-type (if (and (pair? arg) (null? (cdr arg)) (pair? (car arg)))
-                     (car arg)
-                     arg))))
+      ;; are not part of it: ((* const char)), (int)
+      (walk-type (maybe-unwrap-type arg))))
 
+;;; fmt-c reads a parameter as `(type name)', taking the name with
+;;; `cadr'. A nameless one is the type and an explicit #f:
+;;;
+;;;   (* const char)       ->  const char     the star read as the name
+;;;   ((* const char) #f)  ->  const char *
+;;;   (int)                ->  (cadr) error
+;;;   (int #f)             ->  int
 (define (walk-arglist form)
   ;; E.g.:
   ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
   ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
   (map (lambda (arg)
-         (if (named-arg? arg)
-             (list (arg-type arg) (walk-type (car arg)))
-             (arg-type arg)))
+         (list (arg-type arg)
+               (and (named-arg? arg) (walk-type (car arg)))))
        (remove comment-form? form)))
 
 (define (walk-arg-types form)

infer.module.scm

@@ -17,6 +17,7 @@
 
      resolve
      underlying
+     c-primitive?
      type-quals
      free-tvars
      decay

infer.scm

@@ -509,10 +509,12 @@
      ((eq? a b) #t)
      ((unknown-type? a) #t)
      ((unknown-type? b) #t)
-     ((and (tvar? a) (tvar? b) (tvar-rigid? b) (not (tvar-rigid? a)))
-      (bind-tvar! a b form))
-     ((tvar? a) (bind-tvar! a b form))
-     ((tvar? b) (bind-tvar! b a form))
+     ;; Whichever side is free takes the binding: `(unify a r)' and
+     ;; `(unify r a)' both leave `a' bound to `r'. Two rigid and
+     ;; distinct is the mismatch `eq?' above let through.
+     ((and (tvar? a) (not (tvar-rigid? a))) (bind-tvar! a b form))
+     ((and (tvar? b) (not (tvar-rigid? b))) (bind-tvar! b a form))
+     ((or (tvar? a) (tvar? b)) (type-mismatch a b form))
      ;; A typedef unifies as what it stands for. Its name survives in
      ;; whichever side is printed later, since neither side is rebuilt.
      ((alias-type? a) (unify (alias-expansion a) b form))

semen.scm

@@ -274,12 +274,15 @@
 ;;; (fn sum ((a int) (b int)) int ...) -> (fn ((int) (int)) int).
 ;;; Anything that is not a plain (name type) -- a variadic tail -- goes
 ;;; through untouched.
+(define (arglist-types arglist)
+  (map (lambda (param)
+         (if (and (pair? param) (= 2 (length param)) (named-arg? param))
+             (list (second param))
+             param))
+       arglist))
+
 (define (fn-type-of fn-form)
-  `(fn ,(map (lambda (param)
-               (if (and (pair? param) (= 2 (length param)))
-                   (list (second param))
-                   param))
-             (sex-fn-arglist fn-form))
+  `(fn ,(arglist-types (sex-fn-arglist fn-form))
        ,(sex-fn-return-type fn-form)))
 
 (define (aux-name! env make)
@@ -295,8 +298,16 @@
 ;;; The scope chain
 ;;;
 ;;; `(do (var c int 9) ...)' declares a `c' that ends with the block, so
-;;; a closure-typed `c' outside it is still a closure after it. `do' and
-;;; `for' each open a frame; innermost first.
+;;; a closure-typed `c' outside it is still a closure after it. Every
+;;; form whose body C brackets opens a frame; innermost first:
+;;;
+;;;   (var v double 3.75)
+;;;   (while (< v 0) (var v char 1) ...)
+;;;   (var m _ (+ v 1))                    ; double, not char
+;;;
+;;; One frame per form, not one per arm: a `case' label opens no scope
+;;; in C, and an `if' arm can only declare inside a `do', which brings
+;;; its own.
 
 (define (declare-name! env name type)
   (hash-table-set! (car (hash-table-ref env :scopes)) name type))
@@ -351,7 +362,8 @@
           (cons walk-embed-result (walk-body expansion env)))))
    (else
     (case (car form)
-      ((do for) (with-scope env (lambda () (walk-parts form env))))
+      ((do for while if switch)
+       (with-scope env (lambda () (walk-parts form env))))
 
       ((lambda)
        (let ((name (aux-name! env make-lambda-name)))
@@ -373,8 +385,25 @@
                                     (fourth form))))))))
 
       ((var)
-       ;; the initializer is walked before the name it binds is in scope
-       (let* ((walked (resolve-wildcard (walk-parts form env) env))
+       ;; the initializer is walked before the name it binds is in
+       ;; scope; the type is resolved rather than walked, a parameter
+       ;; list being shaped like a call:
+       ;;
+       ;;   (var c (closure ((int)) int) ...)
+       ;;   (var fp (fn ((c int)) int) ...)  ; int (*fp)(int)
+       (let* ((prefix (if (>= (length form) 3)
+                          (append (take form 2)
+                                  (list (resolve-closure-types
+                                         (expand-type (third form) env))))
+                          form))
+              (walked (resolve-wildcard
+                       (copy-form-source!
+                        form
+                        (append prefix
+                                (if (> (length form) 3)
+                                    (walk-body (drop form 3) env)
+                                    (list))))
+                       env))
               (bound  (if (>= (length walked) 4)
                           (copy-form-source!
                            walked
@@ -402,12 +431,16 @@
       (else
        (let ((closure (receiver-closure-type (car form) env)))
          (if closure
-             (copy-form-source!
-              form
-              `(,(register-closure-call! closure form)
-                ,(walk-statement (car form) env)
-                ,@(map (lambda (argument) (walk-statement argument env))
-                       (cdr form))))
+             ;; the receiver is walked first: `((closure ((x int)) int
+             ;; () ...) 5)' registers `struct ƛint_int' on the way, and
+             ;; the call helper's signature names it
+             (let ((receiver (walk-statement (car form) env)))
+               (copy-form-source!
+                form
+                `(,(register-closure-call! closure form)
+                  ,receiver
+                  ,@(map (lambda (argument) (walk-statement argument env))
+                         (cdr form)))))
              (convert-arguments (walk-parts form env) env))))))))
 
 ;;; `(var n _ (strlen s))' becomes `(var n size-t (strlen s))'.
@@ -501,6 +534,23 @@
      (else (pair (cdr params) (- remaining 1)
                  (cons (unwrap-type (car params)) acc))))))
 
+;;; What a `fn' header gets, a `var' type gets -- macro expansion and
+;;; closure resolution, no walk:
+;;;
+;;;   (defmacro (ty) 'int)  (var x (ty) 0)  ->  int x = 0;
+;;;
+;;; and the macro may ask `(type-of x)' while it stands in for a type.
+(define (expand-type type env)
+  (let ((expanded
+         (parameterize ((current-type-of
+                         (lambda (queried)
+                           (unresolve-closure-types
+                            (expression-type queried env)))))
+           (macro-expand (list type)))))
+    (if (and (pair? expanded) (null? (cdr expanded)))
+        (car expanded)
+        expanded)))
+
 (define (walk-parts form env)
   (copy-form-source! form (walk-body form env)))
 
@@ -550,12 +600,15 @@
     (and (symbol? (car expr)) (get-return-type (car expr))))
    (else
     (case (car expr)
+      ;; (¤ pts 1), pts : (¤ struct point 2) -> (struct point)
+      ;; (¤ p 1),   p   : (* int)             -> int
       ((¤) (let ((base (expression-type (second expr) env)))
-             (and (list? base) (>= (length base) 2) (eq? '¤ (car base))
-                  (second base))))
-      ((&) (and (= 2 (length expr))
-                (let ((target (expression-type (second expr) env)))
-                  (and target `(* ,target)))))
+             (or (array-element-type base) (pointer-target base))))
+      ;; unary `&' takes an address; with two operands it is bitwise and
+      ((&) (if (= 2 (length expr))
+               (let ((target (expression-type (second expr) env)))
+                 (and target `(* ,target)))
+               (arithmetic-type expr env)))
       ;; unary `*' is a dereference; with two operands it is a product
       ((*) (if (= 2 (length expr))
                (pointer-target (expression-type (second expr) env))
@@ -566,8 +619,21 @@
                               (cddr expr)))
       ((cast) (and (= 3 (length expr)) (third expr)))
       ((sizeof) 'size-t)
-      ((== != < > <= >= c-and c-or !) 'bool)
+      ;; `(closure ((x int)) int () ...)' is a `(closure ((int)) int)',
+      ;; so `((closure ((x int)) int () (return x)) 5)' is a call
+      ((closure) (and (closure-expression? expr)
+                      `(closure ,(arglist-types (second expr)) ,(third expr))))
+      ;; `c-and' and `c-or' are the names from before `&&' and `||'
+      ((== != < > <= >= && |\|\|| ! c-and c-or) 'bool)
       ((+ - / %) (arithmetic-type expr env))
+      ;; the bitwise operators join like the arithmetic ones
+      ((^ |\||) (arithmetic-type expr env))
+      ;; a shift is the promoted left operand, not a join:
+      ;;   (<< l b), l : long -> long;  (>> c b), c : char -> int
+      ((<< >>) (promoted-type (expression-type (second expr) env)))
+      ;; ...and an increment is the operand unpromoted:
+      ;;   (++ c), c : char -> char
+      ((++ --) (expression-type (second expr) env))
       ;; otherwise a call: a closure answers with its own return type,
       ;; anything else with what its signature says
       (else
@@ -594,15 +660,54 @@
   (cond
    ((not left) right)
    ((not right) left)
-   ((equal? left right) left)
    (else
     (let ((l (underlying (parse-type left)))
           (r (underlying (parse-type right))))
       (cond
-       ((or (ptr-type? l) (array-type? l)) left)
-       ((or (ptr-type? r) (array-type? r)) right)
-       ((< (conversion-rank l) (conversion-rank r)) right)
-       (else left))))))
+       ((or (ptr-type? l) (array-type? l)) (decayed left l))
+       ((or (ptr-type? r) (array-type? r)) (decayed right r))
+       ;; one type on both sides needs no ranking:
+       ;;   (+ n n), n : size-t -> size-t
+       ((and (prim-type? l) (prim-type? r) (equal? (prim-name l) (prim-name r)))
+        (promoted left l))
+       ((or (unrankable? l) (unrankable? r)) '?)
+       ((< (conversion-rank l) (conversion-rank r)) (promoted right r))
+       ((> (conversion-rank l) (conversion-rank r)) (promoted left l))
+       ;; (+ i u) and (+ u i) are both unsigned int
+       ((unsigned-type? r) (promoted right r))
+       (else (promoted left l)))))))
+
+;;; `size-t', `GLuint': no declaration parsed, so no rank to compare.
+;;;
+;;;   (var m _ (+ 1 n))       n : size-t  ->  type of this is unknown
+;;;   (var m size-t (+ 1 n))              ->  size_t m = 1 + n;
+(define (unrankable? type)
+  (and (prim-type? type) (not (c-primitive? type))))
+
+(define (unsigned-type? type)
+  (and (prim-type? type) (memq 'unsigned (prim-name type)) #t))
+
+;;; Narrower than `int' promotes to one:
+;;;
+;;;   (+ c c)  c : char 100     ->  int 200,    not char -56
+;;;   (+ h h)  h : short 30000  ->  int 60000,  not short -5536
+;;;   (+ u u)  u : unsigned     ->  unsigned -- `unsigned' is unsigned int
+;;; An array operand is a pointer to its first element:
+;;;
+;;;   (var p _ (+ a 1))  a : (¤ int 4)  ->  int * p = a + 1;
+;;;                                     not int p[4] = a + 1;
+(define (decayed written type)
+  (if (array-type? type) (unparse-type (decay type)) written))
+
+(define (promoted-type written)
+  (and written (promoted written (underlying (parse-type written)))))
+
+(define (promoted written type)
+  (if (and (prim-type? type)
+           (any (lambda (word) (memq word '(char short bool _Bool)))
+                (prim-name type)))
+      'int
+      written))
 
 ;;; `char' and `short' promote to `int', so the ranks start there
 (define (conversion-rank type)
@@ -675,13 +780,19 @@
 
 (define +closure-env-bytes+ 16)
 
-;;; +closure-env-bytes+ for maximum capacity, max-align-t for
-;;; effectiveness, hence union
+;;; +closure-env-bytes+ for capacity, the widest built-ins for
+;;; alignment, hence union -- a union takes the strictest alignment of
+;;; its members. `max_align_t' would say the second in one word:
+;;;
+;;;   sexc hello-world.sex -- -std=c99   unknown type name 'max_align_t'
 (define +closure-env-type+ 'ƛenv)
 
 (define (closure-env-declaration)
-  `(union ,+closure-env-type+ ((align max-align-t)
-                               (bytes (¤ char ,+closure-env-bytes+)))))
+  `(union ,+closure-env-type+ ((bytes (¤ char ,+closure-env-bytes+))
+                               (align-integer (long long))
+                               (align-real (long double))
+                               (align-pointer (* void))
+                               (align-code (fn ((* void)) void)))))
 
 (define +closure-structs+ (make-hash-table))
 (define +closure-forwards+ (make-hash-table))
@@ -747,10 +858,23 @@
                  *pending-closure-structs*)))))
    (delete-duplicates (aggregates-in type))))
 
+;;; The words inside an argument take the single separator, the
+;;; arguments a doubled one:
+;;;
+;;;   (closure ((long long)) int)    ->  ƛlong_long_int
+;;;   (closure ((long) (long)) int)  ->  ƛlong__long_int
+;;;
+;;; A word whose first character mangles to `_' still aliases the
+;;; doubled separator: `((a -b))' and `((a) (b))' are both `a__b'.
+(define (mangle-arglist args)
+  (if (null? args)
+      "void"
+      (string-intersperse (map mangle-type args) "__")))
+
 (define (closure-struct-name type)
   ;; the glyph says `closure' already, so the tag is just the signature
   (string->symbol (string-append "ƛ"
-                                 (mangle-type (second type))
+                                 (mangle-arglist (second type))
                                  "_"
                                  (mangle-type (third type)))))
 
@@ -919,9 +1043,9 @@
   (let ((name (capture-name capture)))
     (unless (symbol? name)
       (sex-error form "a closure capture needs a name" capture))
-    (let ((type (if (pair? capture)
-                    (expression-type (capture-argument capture) env)
-                    (lookup-name env name))))
+    ;; the same lookup either way, so `(closure ((x int)) int (scale)
+    ;; ...)' borrows a global's `scale' as readily as a local's
+    (let ((type (expression-type (capture-argument capture) env)))
       (unless type
         (sex-error form "cannot infer what is captured as" name))
       (list name type))))
@@ -1007,11 +1131,27 @@
         ((union) (add-union name form))
         ((enum) (add-enum name form))))))
 
+;;; No function around a toplevel form, so no scope chain: what a
+;;; global's initializer names comes from `get-name-type' alone.
+(define (make-toplevel-env)
+  (let ((env (make-hash-table)))
+    (set! (hash-table-ref env :scopes) (list))
+    env))
+
 (define (process-global-var sex-var acc)
-  ;; A global is not walked for lambdas, but its type still has to stop
-  ;; saying `closure' before the writer sees it
-  (let* ((form (resolve-closure-types sex-var))
-         (core (if (memq (car form) '(pub extern)) (cdr form) form)))
+  ;; A global is not walked for lambdas, but the writer spells neither
+  ;; `closure' nor `_': `(var n _ 1)' has to reach it as `int n = 1'
+  (let* ((resolved  (resolve-closure-types sex-var))
+         (qualifier (and (memq (car resolved) '(pub extern)) (car resolved)))
+         (core      (if qualifier (cdr resolved) resolved))
+         ;; `(extern var n int)' has no initializer to work a `_' out
+         ;; from
+         (core      (if (eq? 'extern qualifier)
+                        core
+                        (resolve-wildcard core (make-toplevel-env))))
+         (form      (if qualifier
+                        (copy-form-source! resolved (cons qualifier core))
+                        core)))
     (when (and (pair? (cdr core)) (pair? (cddr core)) (symbol? (second core)))
       (add-name-type! (second core) (third core)))
     (cons form acc)))

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/fmt-c-writer.scm

@@ -40,15 +40,15 @@
    (walk-type '(const * const char)))
 
   (test
-   '(%fun void ((int) (float) (%array (struct what * const))))
+   '(%fun void (int float (%array (struct what * const))))
    (walk-type '(fn ((int) (float) (¤ (const * struct what))) void)))
 
   (test
-   '(%fun void ((int) (%array float) (%array (struct what * const))))
+   '(%fun void (int (%array float) (%array (struct what * const))))
    (walk-type '(fn ((int) (¤ float) (¤ (const * struct what))) void)))
 
   (test
-   '(%array (%fun void ((int) (%array float) (%array (struct what * const)))))
+   '(%array (%fun void (int (%array float) (%array (struct what * const)))))
    (walk-type '(¤ (fn ((int) (¤ float) (¤ (const * struct what))) void))))
 
   ;; Type convert to C
@@ -136,7 +136,7 @@
 
 ;;; Fn defs
   (test
-   '(%fun void puk ((int) (%array float 8)))
+   '(%fun void puk ((int #f) ((%array float 8) #f)))
    (walk-fn-def '(fn puk ((int) (¤ float 8)) void)))
 
   (test
@@ -183,7 +183,7 @@
   (test
    '(struct mega_kebab ((int a)
                         ((struct ((int year) (int month) (int day))) dob)
-                        ((%fun bool ((int) (%array int))) min)))
+                        ((%fun bool (int (%array int))) min)))
    (walk-struct '(struct mega-kebab
                          ((a int)
                           (dob (struct ((year int)

tests/infer.module.scm

@@ -17,6 +17,7 @@
 
      resolve
      underlying
+     c-primitive?
      type-quals
      free-tvars
      decay

tests/infer.scm

@@ -183,7 +183,17 @@
         (test-assert "an ordinary variable binds to it instead"
                      (unify a r #f))
         ;; An unsolved variable resolves to itself.
-        (test-assert "it is still open" (tvar? (resolve r))))))
+        (test-assert "it is still open" (tvar? (resolve r))))
+      ;; ...and the same the other way round: it is which side is free
+      ;; that decides, not which side was written first.
+      (let ((r (fresh-rigid-tvar))
+            (a (fresh-tvar)))
+        (test-assert "rigid first binds the free one" (unify r a #f))
+        (test-assert "to the parameter itself" (eq? r (resolve a))))
+      (let ((r1 (fresh-rigid-tvar))
+            (r2 (fresh-rigid-tvar)))
+        (test-error "two parameters do not unify with each other"
+                    (unify r1 r2 #f)))))
 
   (test-group "constraints"
     (test #t (entails? 'numeric (parse-type 'int)))

tests/sex-programs/c99.sex

@@ -0,0 +1,28 @@
+(compilation "-- -std=c99 -pedantic-errors")
+(input)
+(output "c99: 42")
+(return 0)
+
+;;; The closure environment is part of the ABI, so its union is declared
+;;; in every translation unit whether or not one is used. That put
+;;; whatever it was written with into every program: `max_align_t' named
+;;; the alignment in one word, and made C11 the floor for a program with
+;;; no closure in it at all.
+;;;
+;;; The widest built-ins say the same thing -- a union is aligned for the
+;;; strictest of its members -- and say it in C99.
+;;;
+;;; Closures themselves still want C11 for the `_Static_assert' that
+;;; checks the captures fit, so this program keeps clear of them.
+
+(include stdio.h)
+
+(struct point ((x int) (y int)))
+
+(fn area ((p (struct point))) int
+  (return (* (. p x) (. p y))))
+
+(pub fn main () int
+  (var p (struct point) #((struct point) : 6 7))
+  (printf "c99: %d\n" (area p))
+  (return 0))

tests/sex-programs/closure-signatures.sex

@@ -0,0 +1,52 @@
+(input)
+(output "one argument of two words: 7"
+        "two arguments of one: 7"
+        "unsigned, one argument: 9"
+        "unsigned, two arguments: 3"
+        "captured global: 12"
+        "captured function: 8")
+(return 0)
+
+;;; A closure's struct is named after its signature, so that two
+;;; translation units agree on it without sharing a header. The name is
+;;; built by flattening the argument list, and flattening loses where one
+;;; argument ends and the next begins: `((long long))' and
+;;; `((long) (long))' are different signatures that used to mangle alike,
+;;; and the second quietly reused the first one's struct.
+;;;
+;;; A capture that borrows a name reads it from wherever the name is
+;;; declared, a global or a function included.
+
+(include stdio.h)
+
+(var scale int 3)
+
+(fn double-it ((n int)) int
+  (return (* n 2)))
+
+(pub fn main () int
+  (var one-wide (closure ((long long)) int)
+       (closure ((a (long long))) int () (return (cast a int))))
+  (printf "one argument of two words: %d\n" (one-wide 7))
+
+  (var two-longs (closure ((long) (long)) int)
+       (closure ((a long) (b long)) int () (return (cast (+ a b) int))))
+  (printf "two arguments of one: %d\n" (two-longs 3 4))
+
+  (var one-unsigned (closure ((unsigned int)) int)
+       (closure ((a (unsigned int))) int () (return (cast a int))))
+  (printf "unsigned, one argument: %d\n" (one-unsigned 9))
+
+  (var two-unsigned (closure ((unsigned) (int)) int)
+       (closure ((a unsigned) (b int)) int () (return (+ (cast a int) b))))
+  (printf "unsigned, two arguments: %d\n" (two-unsigned 1 2))
+
+  ;; a capture names what it borrows, and the name need not be a local
+  (var scaled (closure ((int)) int)
+       (closure ((x int)) int (scale) (return (* x scale))))
+  (printf "captured global: %d\n" (scaled 4))
+
+  (var doubled (closure ((int)) int)
+       (closure ((x int)) int (double-it) (return (double-it x))))
+  (printf "captured function: %d\n" (doubled 4))
+  (return 0))

tests/sex-programs/operators.sex

@@ -0,0 +1,90 @@
+(input)
+(output "logical: 1 1 0"
+        "bitwise: 7 2 5"
+        "shifts: 48 0 12"
+        "increment: 7"
+        "decayed: 2 2 there"
+        "unsigned wins either way: 4294967295 4294967295"
+        "toplevel: 1 2.5 hi 12"
+        "closure in place: 5"
+        "a type is not a call: 7")
+(return 0)
+
+;;; The walk types an expression by its head, and the heads it had a
+;;; rule for were the ones inference was written against. `&&', the
+;;; bitwise operators, the shifts and `++' were not among them and each
+;;; stopped with `cannot infer'.
+;;;
+;;; The rest of this is the same mistake in three other places: an array
+;;; is a pointer the moment it is an operand, a rank tie is not decided
+;;; by which operand was written first, and `_' is not a local's
+;;; privilege.
+
+(include stdio.h)
+
+(fn area ((w int) (h int)) int
+  (return (* w h)))
+
+;;; a toplevel `_' reads the same table a local's does, so it can name
+;;; anything declared above it
+(var n _ 1)
+(var d _ 2.5)
+(var s _ "hi")
+(var a _ (+ 3 (* 3 3)))
+
+(fn make-adder ((k int)) (closure ((int)) int)
+  (return (closure ((b int)) int (k) (return (+ k b)))))
+
+(pub fn main () int
+  (var x int 6)
+  (var y int 3)
+  (var ok _ (&& x y))
+  (var orr _ (|| x y))
+  (var neg _ (! x))
+  (printf "logical: %d %d %d\n" ok orr neg)
+
+  (var bor _ (| x y))
+  (var band _ (& x y))
+  (var bxor _ (^ x y))
+  (printf "bitwise: %d %d %d\n" bor band bxor)
+
+  ;; a shift is the promoted left operand, not a join: the right one
+  ;; says only how far
+  (var c char 12)
+  (var shl _ (<< x y))
+  (var shr _ (>> x y))
+  (var wide _ (>> c 0))
+  (printf "shifts: %d %d %d\n" shl shr wide)
+
+  ;; ...and an increment is the operand, unpromoted
+  (var inc _ (++ x))
+  (printf "increment: %d\n" inc)
+
+  ;; an array operand decays, so this is a pointer and not an array
+  (var xs (¤ int 4) #(1 2 3 4))
+  (var p _ (+ xs 1))
+  (var q _ (+ 1 xs))
+  (var names (¤ (* const char) 2) #("hi" "there"))
+  (var np _ (+ names 1))
+  (printf "decayed: %d %d %s\n" (* p) (* q) (* np))
+
+  ;; at equal rank C takes the unsigned operand, whichever side it is on
+  (var i int -1)
+  (var u (unsigned int) 1)
+  (var u1 _ (+ i u))
+  (var u2 _ (+ u i))
+  (printf "unsigned wins either way: %u %u\n" (- u1 1) (- u2 1))
+
+  (printf "toplevel: %d %g %s %d\n" n d s a)
+
+  ;; a closure literal is its own type, so it can be called where it is
+  ;; written, the way a lambda already could
+  (printf "closure in place: %d\n"
+          ((closure ((v int)) int () (return v)) 5))
+
+  ;; a `fn' type's parameter list looks exactly like a call; with a
+  ;; closure named `f' in scope it used to be read as one
+  (var f (closure ((int)) int) (make-adder 1))
+  (var fp (fn ((f int) (g int)) int) area)
+  (printf "a type is not a call: %d\n" (f 6))
+  (return 0))

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/sex-programs/unnamed-params.sex

@@ -0,0 +1,51 @@
+(input)
+(output "one word: 7"
+        "pointer: 2"
+        "aggregate: 3"
+        "array: 2.5"
+        "variadic: 1 two")
+(return 0)
+
+;;; A parameter that names nothing still has to reach the C writer as a
+;;; type and a name, the name being absent. Handed the bare type
+;;; instead, fmt-c read the type's own second word as the name -- so
+;;; `(* const char)' came out `const char', which is a different
+;;; function -- and a one-word type had no second word to read at all.
+
+(include stdio.h)
+(include stdarg.h)
+
+(struct point ((x int) (y int)))
+
+;;; declared here rather than included, so the prototype we emit is the
+;;; one the C compiler checks the call against
+(extern fn abs ((int)) int)
+(extern fn strlen ((* const char)) size-t)
+
+(fn origin-x ((p (* (struct point)))) int
+  (return (. (* p) x)))
+
+(fn second-of ((xs (¤ float 4))) float
+  (return (¤ xs 1)))
+
+(fn say ((fmt (* const char)) ...) void
+  (var ap va-list)
+  (va-start ap fmt)
+  (vprintf fmt ap)
+  (va-end ap))
+
+(pub fn main () int
+  (printf "one word: %d\n" (abs -7))
+  (printf "pointer: %d\n" (cast (strlen "hi") int))
+
+  ;; the same parameter lists written as types
+  (var p (struct point) #((struct point) : 3 4))
+  (var f (fn ((* (struct point))) int) origin-x)
+  (printf "aggregate: %d\n" (f (& p)))
+
+  (var xs (¤ float 4) #(1.5 2.5 3.5 4.5))
+  (var g (fn ((¤ float 4)) float) second-of)
+  (printf "array: %g\n" (g xs))
+
+  (say "variadic: %d %s\n" 1 "two")
+  (return 0))

tests/sex-programs/wildcards.sex

@@ -6,8 +6,10 @@
         "arrays: 30"
         "loop: 0 1 2"
         "shadowed: 9 then 42"
+        "still an int: 200"
         "partial: 1 2.5"
         "joined: 43.5 84 49 1"
+        "promoted: 200 60000 3705032704"
         "from elements: 4 9 0")
 (return 0)
 
@@ -55,11 +57,24 @@
        (printf " %d" i))
   (printf "\n")
 
-  ;; a block's declarations end with it
+  ;; a block's declarations end with it, and so do the declarations of
+  ;; everything else C brackets -- a `while' body is a block with no
+  ;; `do' written around it
   (do (var n _ 9)
       (printf "shadowed: %d then " n))
   (printf "%d\n" n)
 
+  (var wide int 200)
+  (while false (var wide char 1) (printf "%d" wide))
+  (if false (do (var wide char 1) (printf "%d" wide)))
+  ;; a statement before the declaration: a label may not be followed by
+  ;; one until C23
+  (switch a (case 1 (printf "") (var wide char 1) (printf "%d" wide) (break)))
+  ;; a copy, not a sum: an arithmetic result would be promoted to `int'
+  ;; whatever leaked, and say nothing
+  (var copy _ wide)
+  (printf "still an int: %d\n" copy)
+
   ;; a wildcard inside a written type: only it is solved
   (var pp2 (* _) (& p))
   (printf "partial: %d %g\n" (-> pp2 x) (-> pp2 y))
@@ -74,6 +89,17 @@
   (var single _ (+ g g))
   (printf "joined: %g %d %ld %g\n" mixed same wider single)
 
+  ;; ...including the promotions, which two operands of one narrow type
+  ;; are exactly where they show: `char' + `char' is an `int'
+  (var c1 char 100)
+  (var c2 char 100)
+  (var h1 short 30000)
+  (var narrow _ (+ c1 c2))
+  (var narrower _ (+ h1 h1))
+  (var kept (unsigned int) 4000000000)
+  (var unpromoted _ (+ kept kept))
+  (printf "promoted: %d %d %u\n" narrow narrower unpromoted)
+
   ;; a brace initializer has no type of its own, but its elements solve
   ;; the hole in the array type around it -- and the length stays as
   ;; written, whether or not every slot is initialized

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

tools/sextest/sextest.scm

@@ -86,8 +86,13 @@
         (compiled-file (create-temporary-file)))
     ;; `process' returns one record; `process-input-port' is named from
     ;; the child's side, so it is the port we write to.
+    ;;
+    ;; Sex reads no symbol escaping -- `|' is an operator there. Left
+    ;; on, `(|| a b)' leaves here as `(|\|\|| a b)' and reaches sexc
+    ;; as a different symbol.
     (let* ((proc (process compiler (append (list "-o" compiled-file) flags)))
            (sexc-stdin (process-input-port proc)))
+      (symbol-escape #f)
       (with-output-to-port sexc-stdin
         (fn (map (fn (fmt #t x)) src)))
       (close-output-port sexc-stdin)

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,79 @@
               (map (lambda (value) (fn value type))
                    (caddr info))))
            (else #f)))))
+
+;;; The shape of a written type
+;;;
+;;; Where a type ends, asked by an arglist and by an array bound:
+;;;
+;;;   (f1 float)      a name and a type    (unsigned int)  a type
+;;;   (¤ int 4)       four of int          (¤ const t)     unsized, of const t
+;;;   (¤ mytype N)    N of mytype          (¤ * size-t)    unsized, of (* size-t)
+
+;;; A qualifier cannot end a type: `(¤ const t)' is unsized, `(¤ int 4)'
+;;; is four of int.
+(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))))
+
+;;; A typedef and a `define' share +type-db+; only the typedef is part
+;;; of a type:
+;;;
+;;;   (typedef small int)  ->  (¤ small N) is N of small
+;;;   (define CAP 4)       ->  (¤ int CAP) is CAP of int
+(define (typedef-name? name)
+  (let ((info (and (symbol? name) (get-type-info name))))
+    (and info (memq (car info) '(typedef struct union enum)) #t)))
+
+;;; The last element is a bound only where what precedes it already
+;;; spells a whole type -- a specifier, a tag after its keyword, or a
+;;; typedef we have seen declared:
+;;;
+;;;   (¤ int 4)         four of int        (¤ unsigned int)  unsized
+;;;   (¤ mytype CAP)    CAP of mytype      (¤ struct point)  unsized
+;;;   (¤ const mytype)  unsized            (¤ * size-t)      unsized
+;;;
+;;; 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)))))