ignore the attic directory

Two things out of one mechanism. `_' as a type means "work it out from
the initializer", so (var n _ (strlen s)) stops needing size-t spelled
out; `type-of' hands a macro the type of an expression, so a macro can
dispatch on what it was handed rather than on what was declared. Both
read the same answers from two sides.

Algorithm W's core, intra-procedural, with the extensions C forces:

  - an unknown type, since (include stdio.h) brings in names we never
    parsed. Unification is consistency rather than equality, so
    anything touching an unparsed declaration stops constraining
    instead of rejecting a program that compiled yesterday;
  - the usual arithmetic conversions, since `+' is not a function of
    one type;
  - checking mode for initializers, since #(0 0) has no type of its own
    and takes one from its context. #(T : ...) is the way out of that.

What it wanted on the way:

  - what type a *name* has, which neither the typedef nor the tag
    database recorded. One table serves functions and variables, since
    a function type already has a surface spelling;
  - a scope chain, so a (var c int 9) inside a do ends with the block;
  - form-type, keyed by cons cell, so one form has one type;
  - macros expanded during the walk rather than before it, so type-of
    is answered in the scope the macro was written in.

Closures take the same machinery: a receiver whose type comes from a
call, captures written (name expr) and typed from the expression, and
conversion from a bare function wherever a closure is expected.

type-match grew `_' on the pattern side, since (closure ((int)) int)
and (closure ((float)) int) were separate clauses for one case.

.gitignore

@@ -9,3 +9,6 @@ sexc
 sex-tests
 sextest
 tools/sextest/sextest
+
+# Scrapped design docs, kept for reference
+/attic

Makefile

@@ -26,7 +26,7 @@ INSTALL_PROGRAM = $(INSTALL)
 MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
 
 # Order matters, since module check correctness on compilation
-MODULES = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
+MODULES = utils types infer sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
 OBJ = $(MODULES:%=%.o)
 
 DEPSFILE = dependencies.txt
@@ -63,6 +63,9 @@ utils.o: utils.module.scm utils.scm
 types.o: types.module.scm types.scm
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types
 
+infer.o: infer.module.scm infer.scm types.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) infer.module.scm -o infer.o -unit infer -link types,utils
+
 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
 
@@ -72,8 +75,8 @@ reader.o: reader.module.scm reader.scm utils.o
 sex-modules.o: sex-modules.module.scm sex-modules.scm reader.o utils.o
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
 
-semen.o: semen.module.scm semen.scm sex-macros.o sex-modules.o types.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,types,utils
+semen.o: semen.module.scm semen.scm infer.o 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,infer,types,utils
 
 sex-fmt-c.o: sex-fmt-c.scm
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
@@ -81,8 +84,8 @@ sex-fmt-c.o: sex-fmt-c.scm
 fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
 
-sexc.o: sexc.module.scm types.o sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,types,utils
+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
 
 # Unit testing
 sex-tests:
@@ -94,7 +97,8 @@ sextest:
 	cp ./tools/sextest/sextest .
 
 SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \
-                    feature-flags lambdas compound-literals
+                    feature-flags lambdas compound-literals closures fixpoint \
+                    wildcards inference
 
 # Multi-module linking is checked end to end; see tests/modules/Makefile.
 check-modules: sexc

Readme.org

@@ -212,6 +212,20 @@ Sex has support for syntactic macros. Macro definitions look like
 functions: they have a name, an argument list and a body. Macro should
 return Sex code.
 
+A macro returns *one* form. To return several --- a function beside the
+struct it works on, say --- return them under =$=, which splices them in
+where the macro was written:
+
+#+begin_src scheme
+  (defmacro (pair-of-fns a b)
+    `($ (fn ,a () int (return 1))
+        (fn ,b () int (return 2))))
+#+end_src
+
+=($)= expands to nothing. Everything else is a single form, including
+one whose head is itself a form: =`((make-adder 10) 5)= calls what
+=make-adder= returned, and is not two forms.
+
 *** Examples:
 **** Structure with templated value type
 #+begin_src scheme

example/lambdas.sex

@@ -3,6 +3,12 @@
 (fn sum ((a int) (b int)) int
   (return (+ a b)))
 
+;;; A lambda captures nothing and is a bare function pointer; a closure
+;;; captures and is a value carrying its own environment
+(fn make-adder ((a int)) (closure ((int)) int)
+  (return (closure ((b int)) int (a)
+            (return (+ a b)))))
+
 (pub fn main () int
   (var a int 10)
   (var b int 20)
@@ -10,12 +16,12 @@
 
   (var sum-lambda (fn ((int) (int)) int)
 
-       (lambda ((a int) (b int)) int ()
+       (lambda ((a int) (b int)) int
          (return (+ a b))))
 
   (var sum-lambda-2 (fn ((int)) int)
 
-       (lambda ((a int)) int ()
+       (lambda ((a int)) int
          (return (+ a 20))))
 
   (printf "Hello from main fn!\n")
@@ -24,28 +30,19 @@
   (printf "Calling fn ptr: %d\n" (sum-fn a b))
   (printf "Calling lambda: %d\n" (sum-lambda a b))
   (printf "Calling other lambda: %d\n" (sum-lambda-2 a))
-  (printf "Calling lambda inplace: %d\n" ((lambda ((a int) (b int)) int ()
+  (printf "Calling lambda inplace: %d\n" ((lambda ((a int) (b int)) int
                                             (return (+ a b 100)))
                                           a b))
 
   (var l-1 (fn ((int)) int)
-       (lambda ((a int)) int ()
+       (lambda ((a int)) int
          (var l-2 (fn ((int)) int)
-              (lambda ((a int)) int ()
+              (lambda ((a int)) int
                 (return (+ 60 a))))
          (return (+ 600 (l-2 a)))))
   (printf "Calling nested lambdas: %d\n" (l-1 6))
 
-  ;; Not supported yet
-  ;; Closure
-  ;;  (var (fn (fn ((int)) int) ((int))) make-adder
-  ;;       (lambda (fn int ((int a))) ()
-  ;;         (return (lambda int ((int b)) (a)
-  ;;                   (return (+ a b))))))
-  ;;
-  ;;  (var (fn int ((int))) add-10
-  ;;       (make-adder 10))
-  ;;  (var (fn int ((int))) add-20
-  ;;       (make-adder 20))
-  ;;  (printf "Calling closures: %d\n" (add-10 24))
+  (var add-10 (closure ((int)) int) (make-adder 10))
+  (var add-20 (closure ((int)) int) (make-adder 20))
+  (printf "Calling closures: %d %d\n" (add-10 24) (add-20 24))
   (return 0))

fmt-c-writer.scm

@@ -114,6 +114,7 @@ forms, and what remains."
     ((attribute) '%attribute)
     ((¤) 'vector-ref)
     ((include) '%include)
+    ((static-assert) '_Static_assert)
     ;; a `|' inside a symbol has to be escaped to be written in
     ;; a Scheme source, so we just rename it in fmt-c compatible
     ;; way
@@ -291,6 +292,27 @@ 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
@@ -301,7 +323,7 @@ forms, and what remains."
   ;; (fn ((int) (float)) void) -> (%fun void ((int) (float)))
   (match form
     (('¤ . array-type)
-     (if (integer? (last array-type))
+     (if (array-bound? array-type)
          ;; sized array
          (let* ((type-list (drop-right array-type 1))
                 (type (maybe-unwrap-type type-list))

infer.module.scm

@@ -0,0 +1,44 @@
+(module infer
+    (;; The IR
+     tvar?
+     tvar-id
+     tvar-classes
+     tvar-rigid?
+     fresh-tvar
+     fresh-rigid-tvar
+
+     prim-type? prim-name prim-quals make-prim
+     ptr-type? ptr-target ptr-quals make-ptr
+     array-type? array-elt array-size make-array-type
+     fn-type? fn-ret fn-args fn-variadic? make-fn-type
+     agg-type? agg-kind agg-name agg-spelling agg-quals make-agg
+     alias-type? alias-name alias-expansion alias-quals make-alias
+     unknown-type? the-unknown-type
+
+     resolve
+     underlying
+     type-quals
+     free-tvars
+     decay
+
+     ;; The boundary
+     parse-type
+     unparse-type
+
+     ;; Constraints
+     register-class!
+     add-instance!
+     entails?
+     default-tvar!
+     default-type-variables!
+
+     ;; Unification
+     unify
+
+     ;; Type schemes
+     scheme? scheme-vars scheme-constraints scheme-type
+     make-scheme
+     generalize
+     instantiate
+     substitute)
+  "infer.scm")

infer.scm

@@ -0,0 +1,642 @@
+;;; Type inference, layer 0: the type representation and unification.
+;;;
+;;; Nothing in the compiler calls this unit yet. It is the ground floor
+;;; of the pass described in Type-inference.org -- built and tested on
+;;; its own before a single form is routed through it.
+;;;
+;;; Two representations meet here. *Surface* types are the forms the
+;;; rest of the compiler passes around -- `int', `(* const char)',
+;;; `(¤ int 16)', `(fn ((int)) int)'. They are what the reader
+;;; produces, what the C writer consumes and what `type-match' compares
+;;; with `equal?', and they are hopeless for unification. The *IR*
+;;; below is the other one: mutable cells, so that solving a type
+;;; variable is a side effect rather than a substitution rebuilt at
+;;; every step.
+;;;
+;;; `parse-type' and `unparse-type' are the boundary between the two,
+;;; and they carry the whole compatibility burden: `unparse-type' must
+;;; produce the exact spelling `type-match' compares against, or the
+;;; reflection macros break by silently falling into their `else'
+;;; branch. That is what the round-trip test in tests/infer.scm is for,
+;;; and why it is driven by every type spelling that appears in the
+;;; repository.
+
+(import
+  scheme
+  (scheme base)
+  (chicken base)
+  matchable
+  srfi-1
+  srfi-69
+  types
+  utils)
+
+;;; ---------------------------------------------------------------
+;;; The IR
+;;; ---------------------------------------------------------------
+
+;;; A type variable is a mutable cell. `ref' is #f while unsolved and
+;;; the type it stands for once bound -- union-find, with the path
+;;; compression done in `resolve'.
+;;;
+;;; `classes' is the list of type classes the variable must satisfy
+;;; (`numeric', and one day `ord'); see "constraints" below. `rigid?'
+;;; marks a variable that must not unify with anything but itself --
+;;; unused until a `fn' grows type parameters, and five lines now
+;;; against an IR change later.
+(define-record-type <tvar>
+  (%make-tvar id ref classes rigid?)
+  tvar?
+  (id tvar-id)
+  (ref tvar-ref tvar-ref-set!)
+  (classes tvar-classes tvar-classes-set!)
+  (rigid? tvar-rigid?))
+
+;;; A primitive or otherwise nominal type. `name' is the list of words
+;;; making it up, so `int', `(unsigned int)' and `(long long)' are all
+;;; one node, and so is a name we have never parsed a declaration for
+;;; (`size-t', `GLuint'). The two cases are told apart by
+;;; `c-primitive?', which is what keeps a constraint over an unparsed C
+;;; typedef from being an error.
+(define-record-type <prim>
+  (make-prim name quals)
+  prim-type?
+  (name prim-name)
+  (quals prim-quals))
+
+(define-record-type <ptr>
+  (make-ptr target quals)
+  ptr-type?
+  (target ptr-target)
+  (quals ptr-quals))
+
+;;; `size' is an integer, or #f for `(¤ int)' -- an array of unwritten
+;;; length.
+(define-record-type <array>
+  (make-array-type elt size)
+  array-type?
+  (elt array-elt)
+  (size array-size))
+
+(define-record-type <fn>
+  (make-fn-type ret args variadic?)
+  fn-type?
+  (ret fn-ret)
+  (args fn-args)
+  (variadic? fn-variadic?))
+
+;;; struct / union / enum. Nominal: two of them are the same type when
+;;; they are the same kind and the same name. `spelling' is the surface
+;;; form it was written as, kept verbatim so that an aggregate defined
+;;; inline in a type position round-trips unchanged.
+(define-record-type <agg>
+  (make-agg kind name spelling quals)
+  agg-type?
+  (kind agg-kind)
+  (name agg-name)
+  (spelling agg-spelling)
+  (quals agg-quals))
+
+;;; A typedef. Transparent to unification -- it unifies as whatever it
+;;; expands to -- and opaque to printing, so a diagnostic and a
+;;; generated declaration both say `size-t' rather than `unsigned long'.
+(define-record-type <alias>
+  (make-alias name expansion quals)
+  alias-type?
+  (name alias-name)
+  (expansion alias-expansion)
+  (quals alias-quals))
+
+;;; `?'. Sex has full C interop, so `printf', `SDL-CreateWindow' and
+;;; `size-t' arrive from headers nobody parsed. Rather than reject
+;;; every real program, the lattice gets a top element: `?' is
+;;; consistent with every type and constrains nothing.
+(define-record-type <unknown>
+  (%make-unknown)
+  unknown-type?)
+
+(define the-unknown-type (%make-unknown))
+
+(define tvar-counter 0)
+
+(define (fresh-tvar . classes)
+  (set! tvar-counter (+ tvar-counter 1))
+  (%make-tvar tvar-counter #f (if (null? classes) (list) (car classes)) #f))
+
+(define (fresh-rigid-tvar . classes)
+  (set! tvar-counter (+ tvar-counter 1))
+  (%make-tvar tvar-counter #f (if (null? classes) (list) (car classes)) #t))
+
+;;; Follow a bound variable to what it stands for, compressing the path
+;;; on the way out. Every procedure that looks at a type's shape starts
+;;; here.
+(define (resolve type)
+  (if (and (tvar? type) (tvar-ref type))
+      (let ((target (resolve (tvar-ref type))))
+        (tvar-ref-set! type target)
+        target)
+      type))
+
+;;; ...and through any typedef as well, for the places that care what a
+;;; type *is* rather than what it is called.
+(define (underlying type)
+  (let ((t (resolve type)))
+    (if (alias-type? t)
+        (underlying (alias-expansion t))
+        t)))
+
+(define (type-quals type)
+  (cond ((prim-type? type) (prim-quals type))
+        ((ptr-type? type) (ptr-quals type))
+        ((agg-type? type) (agg-quals type))
+        ((alias-type? type) (alias-quals type))
+        (else (list))))
+
+;;; Array-to-pointer and function-to-function-pointer, for the
+;;; positions where C decays: a call argument, an operand of `+', the
+;;; subscripted half of `(¤ a i)'.
+(define (decay type)
+  (let ((t (underlying type)))
+    (cond ((array-type? t) (make-ptr (array-elt t) (list)))
+          ((fn-type? t) (make-ptr t (list)))
+          (else (resolve type)))))
+
+(define (free-tvars type)
+  (let collect ((t type) (acc (list)))
+    (let ((t (resolve t)))
+      (cond ((tvar? t) (if (memq t acc) acc (cons t acc)))
+            ((ptr-type? t) (collect (ptr-target t) acc))
+            ((array-type? t) (collect (array-elt t) acc))
+            ((alias-type? t) (collect (alias-expansion t) acc))
+            ((fn-type? t) (fold collect (collect (fn-ret t) acc) (fn-args t)))
+            (else acc)))))
+
+;;; ---------------------------------------------------------------
+;;; Surface -> IR
+;;; ---------------------------------------------------------------
+
+(define +qualifiers+ '(const volatile restrict))
+
+(define (qualifier? word) (memq word +qualifiers+))
+
+;;; `(const char)' written as `((const char))' is the same type: a
+;;; sublist that merely groups. The C writer unwraps these too.
+(define (maybe-unwrap type)
+  (if (and (list? type) (= 1 (length type)))
+      (car type)
+      type))
+
+(define (parse-type surface)
+  (cond
+   ((symbol? surface) (parse-words (list surface) (list) surface))
+   ((not (pair? surface)) (sex-error surface "not a type" surface))
+   ((eq? (car surface) '¤) (parse-array surface))
+   ((eq? (car surface) 'fn) (parse-fn surface))
+   ((memq '* surface) (parse-pointer-chain surface))
+   (else (parse-words surface (list) surface))))
+
+;;; A `*'-free run of words: qualifiers, then whatever they qualify.
+;;; `form' is only carried along so a complaint can say where it was
+;;; written.
+(define (parse-words words quals form)
+  (cond
+   ((null? words) (sex-error form "type is nothing but qualifiers" form))
+   ((qualifier? (car words))
+    (parse-words (cdr words) (cons (car words) quals) form))
+   ;; A single sublist left: grouping parens, as in (* (const struct s))
+   ((and (null? (cdr words)) (pair? (car words)))
+    (with-quals (parse-type (car words)) (reverse quals)))
+   ((memq (car words) '(struct union enum)) (parse-agg words (reverse quals)))
+   ((eq? (car words) '¤) (parse-array words))
+   ((eq? (car words) 'fn) (parse-fn words))
+   ((memq '* words) (parse-pointer-chain (append (reverse quals) words)))
+   (else (parse-name words (reverse quals) form))))
+
+;;; A name, one word or several: `int', `size-t', `(unsigned int)'.
+(define (parse-name words quals form)
+  (cond
+   ((not (every symbol? words)) (sex-error form "malformed type" form))
+   ;; The type-level wildcard. It is a fresh variable wherever it
+   ;; appears, which is what makes partial types -- `(* _)', `(¤ _ 4)'
+   ;; -- fall out for free rather than needing their own grammar.
+   ((equal? words '(_)) (fresh-tvar))
+   ((and (null? (cdr words)) (get-underlying-type (car words)))
+    => (lambda (target)
+         (make-alias (car words) (parse-type target) quals)))
+   (else (make-prim words quals))))
+
+;;; ([pub] struct name), (struct name (fields ...)), (struct (fields ...))
+(define (parse-agg words quals)
+  (let* ((kind (car words))
+         (name (and (pair? (cdr words)) (symbol? (cadr words)) (cadr words))))
+    (make-agg kind name words quals)))
+
+;;; (¤ elt ... size) -- the size is the last element when it is an
+;;; integer, and absent otherwise. The element words are unwrapped the
+;;; way the C writer unwraps them, so `[int 16]' and `[(int) 16]' are
+;;; one type.
+(define (parse-array surface)
+  (let* ((rest (cdr surface))
+         (sized? (and (pair? rest) (integer? (last rest))))
+         (size (and sized? (last rest)))
+         (words (if sized? (drop-right rest 1) rest)))
+    (when (null? words)
+      (sex-error surface "array type without an element type" surface))
+    (make-array-type (parse-type (maybe-unwrap words)) size)))
+
+;;; (fn ((int) (float)) void). Argument entries are types, not named
+;;; parameters -- a `fn' in type position has no room for names.
+(define (parse-fn surface)
+  (match surface
+    (('fn (? list? arglist) ret)
+     (let* ((variadic? (and (pair? arglist) (variadic-marker? (last arglist))))
+            (entries (if variadic? (drop-right arglist 1) arglist)))
+       (make-fn-type (parse-type ret)
+                     (map (lambda (entry) (parse-type (maybe-unwrap entry)))
+                          entries)
+                     variadic?)))
+    (else (sex-error surface "malformed function type" surface))))
+
+;;; `...' in an arglist, written bare or wrapped the way every other
+;;; entry is.
+(define (variadic-marker? entry)
+  (or (eq? entry '...) (equal? entry '(...))))
+
+;;; Pointer chains are written flat and read right to left: the last
+;;; `*'-separated run is the pointed-to type, and each run before it
+;;; qualifies one level of indirection. `(const * const char)' is a
+;;; const pointer to a const char.
+(define (parse-pointer-chain words)
+  (let* ((segments (list-split words '*))
+         (base (last segments))
+         (levels (reverse (drop-right segments 1))))
+    (when (null? base)
+      (sex-error words "pointer to nothing" words))
+    (fold (lambda (level acc)
+            (unless (every qualifier? level)
+              (sex-error words "only qualifiers may sit between two `*'" words))
+            (make-ptr acc level))
+          (parse-words (maybe-unwrap-segment base) (list) words)
+          levels)))
+
+(define (maybe-unwrap-segment segment)
+  (let ((s (maybe-unwrap segment)))
+    (if (list? s) s (list s))))
+
+;;; Re-qualify a parsed type, for the grouping case `(const (struct s))'
+;;; where the qualifier is read before the thing it qualifies.
+(define (with-quals type quals)
+  (if (null? quals)
+      type
+      (cond ((prim-type? type) (make-prim (prim-name type)
+                                          (append quals (prim-quals type))))
+            ((ptr-type? type) (make-ptr (ptr-target type)
+                                        (append quals (ptr-quals type))))
+            ((agg-type? type) (make-agg (agg-kind type) (agg-name type)
+                                        (agg-spelling type)
+                                        (append quals (agg-quals type))))
+            ((alias-type? type) (make-alias (alias-name type)
+                                            (alias-expansion type)
+                                            (append quals (alias-quals type))))
+            (else type))))
+
+;;; ---------------------------------------------------------------
+;;; IR -> surface
+;;; ---------------------------------------------------------------
+
+;;; Every result here has to be the spelling the rest of the compiler
+;;; already writes by hand, since `type-match' compares with `equal?'
+;;; and a near miss is silent.
+(define (unparse-type type)
+  (let ((t (resolve type)))
+    (cond
+     ((tvar? t) '_)
+     ((unknown-type? t) '?)
+     ((alias-type? t) (qualify (alias-quals t) (list (alias-name t))))
+     ((prim-type? t) (qualify (prim-quals t) (prim-name t)))
+     ((agg-type? t) (qualify (agg-quals t) (agg-spelling t)))
+     ((ptr-type? t)
+      (append (ptr-quals t) (list '*) (as-words (unparse-type (ptr-target t)))))
+     ((array-type? t)
+      (let ((elt (as-words (unparse-type (array-elt t)))))
+        (append (list '¤)
+                (if (and (pair? elt) (eq? (car elt) '¤)) (list elt) elt)
+                (if (array-size t) (list (array-size t)) (list)))))
+     ((fn-type? t)
+      (list 'fn
+            (append (map (lambda (arg) (as-arg (unparse-type arg))) (fn-args t))
+                    (if (fn-variadic? t) (list '(...)) (list)))
+            (unparse-type (fn-ret t))))
+     (else (error "unparse-type: not a type" t)))))
+
+;;; A one-word type is written bare, anything longer as a list --
+;;; `int', but `(const int)' and `(struct point)'.
+(define (qualify quals words)
+  (let ((all (append quals words)))
+    (if (and (null? quals) (= 1 (length all)))
+        (car all)
+        all)))
+
+;;; An argument in a `fn' type is written as a list even when it is one
+;;; word -- `((int) (float))' -- so only an atom needs wrapping.
+(define (as-arg surface)
+  (if (pair? surface) surface (list surface)))
+
+;;; Splice a type into a surrounding word list, the way `(* const char)'
+;;; and `[* const char]' splice theirs. An array keeps its parentheses:
+;;; `(¤ ¤ char 4)' would read back as something else entirely.
+(define (as-words surface)
+  (cond ((not (pair? surface)) (list surface))
+        ((memq (car surface) '(¤ fn)) (list surface))
+        (else surface)))
+
+;;; ---------------------------------------------------------------
+;;; Constraints
+;;; ---------------------------------------------------------------
+
+;;; `(numeric a)' is already a type class, so it is written as one from
+;;; the start: one representation, one table, one entailment check. A
+;;; trait bound `(ord (struct circle))' is the same shape, discharged
+;;; the same way, and reported by the same procedure -- which is the
+;;; whole reason to build it this way while there is only one kind of
+;;; constraint to build.
+;;;
+;;; `default' is the type an unresolved constraint falls back to, the
+;;; way Haskell defaults `Num a' to Integer. `test' is how the built-in
+;;; classes say "every arithmetic type" without enumerating twenty
+;;; spellings as instances; a user trait has no test and lives entirely
+;;; in the instance table. `strict?' marks a class that must not be
+;;; guessed at: static dispatch needs a real instance, so `?' fails it.
+(define-record-type <type-class>
+  (%make-type-class name default test strict?)
+  type-class?
+  (name type-class-name)
+  (default type-class-default)
+  (test type-class-test)
+  (strict? type-class-strict?))
+
+(define +classes+ (make-hash-table))
+(define +instances+ (make-hash-table))
+
+(define (register-class! name default test strict?)
+  (hash-table-set! +classes+ name (%make-type-class name default test strict?)))
+
+(define (get-class name)
+  (or (hash-table-ref/default +classes+ name #f)
+      (error "no such type class" name)))
+
+;;; Instances key on the *resolved* type, so `(impl show for size-t)'
+;;; and `(impl show for unsigned long)' collide rather than quietly
+;;; coexisting as two instances of one C type.
+(define (instance-key type)
+  (unparse-type (underlying type)))
+
+(define (add-instance! class-name type)
+  (hash-table-set! +instances+ (cons class-name (instance-key type)) #t))
+
+(define (has-instance? class-name type)
+  (hash-table-exists? +instances+ (cons class-name (instance-key type))))
+
+;;; #t, #f, or 'unknown -- and the third answer is the important one.
+;;; A C name we never parsed a declaration for might well be numeric;
+;;; saying #f there would reject working programs, and saying #t would
+;;; invent knowledge. 'unknown means "do not constrain, do not
+;;; complain".
+(define (entails? class-name type)
+  (let ((cls (get-class class-name))
+        (t (underlying type)))
+    (cond
+     ((tvar? t) 'unknown)
+     ;; `?' is consistent with every type, but it entails nothing:
+     ;; there is no instance to select and no name to mangle.
+     ((unknown-type? t) (if (type-class-strict? cls) #f 'unknown))
+     ((has-instance? class-name t) #t)
+     ((type-class-test cls) => (lambda (test) (test t)))
+     (else #f))))
+
+(define +integer-words+ '(char short int long signed unsigned bool _Bool))
+(define +float-words+ '(float double))
+(define +known-words+ (append '(void) +integer-words+ +float-words+))
+
+;;; A prim built only out of words we recognise. Anything else is a
+;;; name from a header, and we have no opinion about it.
+(define (c-primitive? t)
+  (and (prim-type? t)
+       (every (lambda (word) (memq word +known-words+)) (prim-name t))))
+
+(define (void-type? t)
+  (and (prim-type? t) (equal? (prim-name t) '(void))))
+
+(define (arithmetic-type? t)
+  (cond ((and (agg-type? t) (eq? (agg-kind t) 'enum)) #t) ; an enum is an integer
+        ((not (prim-type? t)) #f)
+        ((not (c-primitive? t)) 'unknown)
+        ((void-type? t) #f)
+        (else #t)))
+
+(define (integral-type? t)
+  (cond ((and (agg-type? t) (eq? (agg-kind t) 'enum)) #t)
+        ((not (prim-type? t)) #f)
+        ((not (c-primitive? t)) 'unknown)
+        ((void-type? t) #f)
+        ((any (lambda (word) (memq word +float-words+)) (prim-name t)) #f)
+        (else #t)))
+
+(define (floating-type? t)
+  (cond ((not (prim-type? t)) #f)
+        ((not (c-primitive? t)) 'unknown)
+        (else (and (any (lambda (word) (memq word +float-words+)) (prim-name t))
+                   #t))))
+
+(define (scalar-type? t)
+  (cond ((ptr-type? t) #t)
+        ((array-type? t) #t)            ; decays to one
+        ((fn-type? t) #t)               ; likewise
+        (else (arithmetic-type? t))))
+
+;;; The built-ins. They are ordinary classes, registered the same way a
+;;; trait will be -- that is the point.
+(register-class! 'numeric  'int    arithmetic-type? #f)
+(register-class! 'integral 'int    integral-type?   #f)
+(register-class! 'floating 'double floating-type?   #f)
+(register-class! 'scalar   #f      scalar-type?     #f)
+
+;;; A constraint that survives to the end of a function is defaulted:
+;;; `(numeric a)' with nothing else known is an `int'. A *strict*
+;;; class has no default and no business guessing, so an unresolved one
+;;; is an error -- the rule is worth stating while there is only one
+;;; kind of constraint to state it about.
+(define (default-tvar! v form)
+  (let ((strict (find (lambda (c) (type-class-strict? (get-class c)))
+                      (tvar-classes v))))
+    (cond
+     (strict (sex-error form "unresolved constraint" (list strict (unparse-type v))))
+     ((find (lambda (c) (type-class-default (get-class c))) (tvar-classes v))
+      => (lambda (c)
+           (tvar-ref-set! v (parse-type (type-class-default (get-class c))))
+           #t))
+     (else #f))))
+
+;;; Default every variable still open in TYPE. Returns #t when none is
+;;; left unsolved, so a caller can tell "inferred" from "give up and
+;;; ask for the type in writing".
+(define (default-type-variables! type form)
+  (fold (lambda (v ok) (and (default-tvar! v form) ok))
+        #t
+        (free-tvars type)))
+
+(define (check-classes classes type form)
+  (for-each
+   (lambda (c)
+     (when (eq? #f (entails? c type))
+       (sex-error form "type does not satisfy a constraint"
+                  (list c (unparse-type type)))))
+   classes))
+
+;;; ---------------------------------------------------------------
+;;; Unification
+;;; ---------------------------------------------------------------
+
+;;; Consistency in the gradual-typing sense rather than equality: `?'
+;;; succeeds against anything and binds nothing, which is what keeps
+;;; the pass from rejecting every program that includes a C header.
+;;;
+;;; FORM is carried only so a failure can say where it was written.
+(define (unify t1 t2 form)
+  (let ((a (resolve t1))
+        (b (resolve t2)))
+    (cond
+     ((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))
+     ;; 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))
+     ((alias-type? b) (unify a (alias-expansion b) form))
+     ((and (prim-type? a) (prim-type? b))
+      (check-quals a b form)
+      (or (equal? (prim-name a) (prim-name b))
+          (type-mismatch a b form)))
+     ((and (ptr-type? a) (ptr-type? b))
+      (check-quals a b form)
+      (unify (ptr-target a) (ptr-target b) form))
+     ((and (array-type? a) (array-type? b))
+      ;; One of them may be `(¤ int)': an unwritten length constrains
+      ;; nothing, the way it does not in C either.
+      (when (and (array-size a) (array-size b)
+                 (not (= (array-size a) (array-size b))))
+        (type-mismatch a b form))
+      (unify (array-elt a) (array-elt b) form))
+     ((and (fn-type? a) (fn-type? b))
+      (unless (and (= (length (fn-args a)) (length (fn-args b)))
+                   (eq? (fn-variadic? a) (fn-variadic? b)))
+        (type-mismatch a b form))
+      (unify (fn-ret a) (fn-ret b) form)
+      (for-each (lambda (x y) (unify x y form)) (fn-args a) (fn-args b))
+      #t)
+     ((and (agg-type? a) (agg-type? b))
+      (check-quals a b form)
+      (or (and (eq? (agg-kind a) (agg-kind b))
+               (if (and (agg-name a) (agg-name b))
+                   (eq? (agg-name a) (agg-name b))
+                   (equal? (agg-spelling a) (agg-spelling b))))
+          (type-mismatch a b form)))
+     (else (type-mismatch a b form)))))
+
+(define (type-mismatch a b form)
+  (sex-error form "type mismatch: expected"
+             (unparse-type a) 'got (unparse-type b)))
+
+;;; Qualifiers are compared, and a mismatch is a warning rather than a
+;;; failure: C's const-correctness is not this pass's fight yet, and
+;;; making it one would reject programs that compile today.
+(define (check-quals a b form)
+  (let ((qa (type-quals a))
+        (qb (type-quals b)))
+    (unless (lset= eq? qa qb)
+      (sex-warning form "qualifiers differ between"
+                   (unparse-type a) "and" (unparse-type b)))))
+
+(define (bind-tvar! v t form)
+  (cond
+   ;; Without recursive types this cannot trigger. It is four lines,
+   ;; and the alternative to having it is a hang.
+   ((occurs? v t) (sex-error form "recursive type" (unparse-type v)))
+   ;; A rigid variable is a type *parameter*: inside a generic body it
+   ;; stands for one specific unknown type and must not be solved.
+   ((tvar-rigid? v) (type-mismatch v t form))
+   (else
+    (when (tvar? t)
+      (tvar-classes-set! t (lset-union eq? (tvar-classes t) (tvar-classes v))))
+    (tvar-ref-set! v t)
+    (unless (tvar? t)
+      (check-classes (tvar-classes v) t form))
+    #t)))
+
+(define (occurs? v type)
+  (let ((t (resolve type)))
+    (cond ((eq? v t) #t)
+          ((ptr-type? t) (occurs? v (ptr-target t)))
+          ((array-type? t) (occurs? v (array-elt t)))
+          ((alias-type? t) (occurs? v (alias-expansion t)))
+          ((fn-type? t) (or (occurs? v (fn-ret t))
+                            (any (lambda (a) (occurs? v a)) (fn-args t))))
+          (else #f))))
+
+;;; ---------------------------------------------------------------
+;;; Type schemes
+;;; ---------------------------------------------------------------
+
+;;; Nothing generalizes yet -- every `fn' in Sex carries a written
+;;; signature and there is no polymorphism to abstract over. These are
+;;; here because they are ten lines on top of unification and because
+;;; they are exactly what a `fn' with type parameters needs, and
+;;; because a scheme without a constraint list is the wrong shape for
+;;; every bounded generic. `(forall vars constraints type)' it is,
+;;; from the start.
+(define-record-type <scheme>
+  (make-scheme vars constraints type)
+  scheme?
+  (vars scheme-vars)
+  (constraints scheme-constraints)
+  (type scheme-type))
+
+;;; Quantify over everything free in TYPE that is not also free in the
+;;; environment, carrying each variable's class constraints along as
+;;; the scheme's context.
+(define (generalize type env-tvars)
+  (let ((vars (lset-difference eq? (free-tvars type) env-tvars)))
+    (make-scheme vars
+                 (append-map (lambda (v)
+                               (map (lambda (c) (cons c v)) (tvar-classes v)))
+                             vars)
+                 type)))
+
+(define (instantiate scheme)
+  (let ((subst (map (lambda (v) (cons v (fresh-tvar (tvar-classes v))))
+                    (scheme-vars scheme))))
+    (substitute (scheme-type scheme) subst)))
+
+;;; Structural copy with the variables in SUBST replaced. Copying is
+;;; how a generic body must be handled anyway -- `form-type' is keyed
+;;; by cons cell, one form one type, so an instantiation gets fresh
+;;; cells rather than a second type for the same cell.
+(define (substitute type subst)
+  (let ((t (resolve type)))
+    (cond
+     ((tvar? t) (let ((hit (assq t subst))) (if hit (cdr hit) t)))
+     ((ptr-type? t) (make-ptr (substitute (ptr-target t) subst) (ptr-quals t)))
+     ((array-type? t) (make-array-type (substitute (array-elt t) subst)
+                                       (array-size t)))
+     ((alias-type? t) (make-alias (alias-name t)
+                                  (substitute (alias-expansion t) subst)
+                                  (alias-quals t)))
+     ((fn-type? t) (make-fn-type (substitute (fn-ret t) subst)
+                                 (map (lambda (a) (substitute a subst))
+                                      (fn-args t))
+                                 (fn-variadic? t)))
+     (else t))))

semen.scm

@@ -7,6 +7,7 @@
   (chicken string)
   (chicken module)
   fmt
+  infer
   sex-macros
   sex-modules
   types
@@ -17,6 +18,7 @@
   )
 
 (export/rename (process semen-process))
+(export closure-env-declaration)
 
 ;;; for lambda extraction, docstring processing, macro expansion,
 ;;; injection of module headers, i.e. all things that rearrange code
@@ -37,26 +39,43 @@
      (macroexpand (car forms) (cdr forms))
      acc))
    (else
-    (process-rec (cdr forms)
-                 (match-sex-form (car forms) acc)))))
+    ;; `struct ƛint_int' has to be declared before the function whose
+    ;; signature first mentioned it, so the forms that function produced
+    ;; are lifted off and the structs slid underneath them
+    (let* ((processed (match-sex-form (car forms) acc))
+           (new (take-until processed acc)))
+      (process-rec (cdr forms)
+                   (append new (flush-closure-structs!) acc))))))
+
+(define (take-until forms tail)
+  (if (eq? forms tail)
+      (list)
+      (cons (car forms) (take-until (cdr forms) tail))))
 
 (define (macroexpand macro-form rest-forms)
-  ;; We want to replace macro with its expansion. The problem is,
-  ;; top-level macro can return either a single form, or a list of
-  ;; forms, when it for example generates some aux
-  ;; structures/functions/typedefs.
+  ;; `(defmacro (two) 2)' expands to `2', and `($ (fn a ...) (fn b ...))'
+  ;; to two forms, spliced where the macro was written. `($)' expands to
+  ;; nothing.
   ;;
-  ;; Single form we just cons to the top of rest-forms, but multiple
-  ;; forms have to be appended to the rest-forms.
+  ;; Everything else is one form, a list whose head is itself a form
+  ;; included: `((make-adder 10) 5)' calls what `make-adder' returned,
+  ;; and without `$' to mark a splice there is no telling that from a
+  ;; list of the two forms `(make-adder 10)' and `5'.
   (let ((res (apply-macro macro-form))
         (src (form-source macro-form)))
     ;; An expansion is fresh structure with no location of its own. Give
     ;; it the call site's, the way cpp attributes a macro body to where
     ;; the macro was used
-    (if (list? (car res))
-        (append (map (lambda (f) (stamp-form-source! f src)) res)
-                rest-forms)
-        (cons (stamp-form-source! res src) rest-forms))))
+    (cond
+     ((splice-form? res)
+      (append (map (lambda (f) (stamp-form-source! f src)) (cdr res))
+              rest-forms))
+     ((null? res) rest-forms)
+     (else
+      (cons (stamp-form-source! res src) rest-forms)))))
+
+(define (splice-form? form)
+  (and (pair? form) (list? form) (eq? '$ (car form))))
 
 (define (match-sex-form sex-form acc)
   (match sex-form
@@ -223,52 +242,759 @@
 (define (process-fn sex-fn-raw acc)
   (let-values (((doc sex-fn)
                 (extract-fn-docstring (strip-fn-header-comments sex-fn-raw))))
-    (let* ((expanded (macro-expand sex-fn))
-           (env (make-hash-table))
-           (processed
-            (walk-form
-             expanded
-             fn-walker
-             (begin
-               (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
-               (set! (hash-table-ref env :lambda-counter) 0)
-               (set! (hash-table-ref env :lambda-aux-code) (list))
-               env))))
-      (with-docstring doc processed
-                      (append (hash-table-ref env :lambda-aux-code) acc)))))
+    (let* ((boundary (fn-header-length sex-fn))
+           ;; only the header is expanded up front. A macro in the body
+           ;; is expanded during the walk, where `(type-of x)' can still
+           ;; be answered from the scope it was written in
+           (expanded (append (macro-expand (take sex-fn boundary))
+                             (drop sex-fn boundary))))
+      (add-name-type! (sex-fn-name expanded) (fn-type-of expanded))
+      (let* ((env       (make-fn-env expanded))
+             ;; the parameters are the body's outermost scope
+             (header    (map resolve-closure-types (take expanded boundary)))
+             (body      (walk-body (drop expanded boundary) env))
+             (processed (append header body)))
+        (with-docstring doc processed
+                        (append (hash-table-ref env :lambda-aux-code) acc))))))
 
-(define (fn-walker form env)
-  (if (eq? 'lambda (car form))
-      (let ((lambda-name (make-lambda-name (hash-table-ref env :fn-name)
-                                           (hash-table-ref env :lambda-counter))))
-        (set! (hash-table-ref env :lambda-aux-code)
-          (append (make-aux-lambda-struct lambda-name form)
-                  (hash-table-ref env :lambda-aux-code)))
-        (set! (hash-table-ref env :lambda-counter)
-          (+ (hash-table-ref env :lambda-counter) 1))
-        lambda-name)
+(define (make-fn-env fn-form)
+  (let ((env (make-hash-table))
+        (parameters (make-hash-table)))
+    (for-each (lambda (param)
+                (when (and (pair? param) (pair? (cdr param)))
+                  (hash-table-set! parameters (first param) (second param))))
+              (sex-fn-arglist fn-form))
+    (set! (hash-table-ref env :fn-name) (sex-fn-name fn-form))
+    (set! (hash-table-ref env :lambda-counter) 0)
+    (set! (hash-table-ref env :lambda-aux-code) (list))
+    (set! (hash-table-ref env :returns) (sex-fn-return-type fn-form))
+    (set! (hash-table-ref env :scopes) (list parameters))
+    env))
+
+;;; (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 (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))
+       ,(sex-fn-return-type fn-form)))
+
+(define (aux-name! env make)
+  (let ((counter (hash-table-ref env :lambda-counter)))
+    (set! (hash-table-ref env :lambda-counter) (+ counter 1))
+    (make (hash-table-ref env :fn-name) counter)))
+
+(define (add-aux-code! env forms)
+  (set! (hash-table-ref env :lambda-aux-code)
+    (append forms (hash-table-ref env :lambda-aux-code))))
+
+
+;;; 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.
+
+(define (declare-name! env name type)
+  (hash-table-set! (car (hash-table-ref env :scopes)) name type))
+
+(define (lookup-name env name)
+  (let search ((scopes (hash-table-ref env :scopes)))
+    (and (pair? scopes)
+         (or (hash-table-ref/default (car scopes) name #f)
+             (search (cdr scopes))))))
+
+(define (with-scope env body)
+  (let ((enclosing (hash-table-ref env :scopes)))
+    (set! (hash-table-ref env :scopes) (cons (make-hash-table) enclosing))
+    (let ((walked (body)))
+      (set! (hash-table-ref env :scopes) enclosing)
+      walked)))
+
+;;; The body walk
+;;;
+;;; One pass in statement order: lifts lambdas and closures out,
+;;; resolves closure types to the struct that stands for them, records
+;;; what each declaration binds, and rewrites a call whose head is a
+;;; closure.
+;;;
+;;; Not `walk-form': it has no event for leaving a scope, and it hands
+;;; the walk function every cdr-tail as well, so the `f' in `(g f)'
+;;; arrives as `(f)' and reads as a call of its own.
+
+(define (walk-body forms env)
+  (append-map (lambda (form)
+                (let ((walked (walk-statement form env)))
+                  (if (and (pair? walked) (eq? (car walked) walk-embed-result))
+                      (cdr walked)
+                      (list walked))))
+              forms))
+
+(define (walk-statement form env)
+  (cond
+   ((not (list? form)) form)
+   ((null? form) form)
+   ;; expanded here rather than before the walk, so the macro body can
+   ;; ask `(type-of x)' about a local the walk has already passed
+   ((macro? form)
+    (let ((expansion (parameterize
+                         ((current-type-of
+                           (lambda (queried)
+                             (unresolve-closure-types
+                              (expression-type queried env)))))
+                       (macroexpand form (list)))))
+      (if (and (pair? expansion) (null? (cdr expansion)))
+          (walk-statement (car expansion) env)
+          (cons walk-embed-result (walk-body expansion env)))))
+   (else
+    (case (car form)
+      ((do for) (with-scope env (lambda () (walk-parts form env))))
+
+      ((lambda)
+       (let ((name (aux-name! env make-lambda-name)))
+         (add-aux-code! env (lift-lambda name form))
+         name))
+
+      ((closure)
+       (if (closure-type? form)
+           ;; a type, not an expression: the struct for its signature
+           (copy-form-source! form `(struct ,(register-closure-type! form form)))
+           (let ((base (aux-name! env make-closure-name)))
+             (let-values (((construct lifted) (lift-closure base form env)))
+               (add-aux-code! env (fold match-sex-form (list) lifted))
+               (copy-form-source!
+                form
+                `(,construct ,@(map (lambda (capture)
+                                      (walk-statement (capture-argument capture)
+                                                      env))
+                                    (fourth form))))))))
+
+      ((var)
+       ;; the initializer is walked before the name it binds is in scope
+       (let* ((walked (resolve-wildcard (walk-parts form env) env))
+              (bound  (if (>= (length walked) 4)
+                          (copy-form-source!
+                           walked
+                           (append (take walked 3)
+                                   (cons (convert-to-closure (third walked)
+                                                             (fourth walked)
+                                                             env walked)
+                                         (drop walked 4))))
+                          walked)))
+         (when (>= (length bound) 3)
+           (declare-name! env (second bound) (third bound)))
+         bound))
+
+      ((return)
+       (let ((walked (walk-parts form env)))
+         (if (>= (length walked) 2)
+             (copy-form-source!
+              walked
+              (cons 'return
+                    (cons (convert-to-closure (hash-table-ref env :returns)
+                                              (second walked) env walked)
+                          (cddr walked))))
+             walked)))
+
+      (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))))
+             (convert-arguments (walk-parts form env) env))))))))
+
+;;; `(var n _ (strlen s))' becomes `(var n size-t (strlen s))'.
+(define (resolve-wildcard form env)
+  (if (and (>= (length form) 3) (wildcard-type? (third form)))
+      (let ((declared (parse-type (third form))))
+        (solve-wildcards! declared
+                          (and (>= (length form) 4) (fourth form))
+                          form env)
+        (let ((written (unparse-type declared)))
+          (cond
+           ;; `?' is what a name from an unparsed header types as, and
+           ;; the writer has no spelling for it
+           ((mentions? written '?)
+            (sex-error form "type of this is unknown; write it out"
+                       (second form)))
+           ((mentions? written '_)
+            (sex-error form "cannot infer the type of" (second form)))
+           (else
+            (copy-form-source! form
+                               (cons (first form)
+                                     (cons (second form)
+                                           (cons written (cdddr form)))))))))
       form))
 
+;;; `(* _)' against `(* (struct point))' solves only the wildcard inside
+;;; the pointer; a bare `_' is the same with nothing around it.
+;;;
+;;; `#(0 1 4 9)' has no type of its own, so it cannot answer a bare `_',
+;;; but its elements still solve the hole in `(¤ _ 4)' -- each one is
+;;; unified with the element type, which is what makes `(¤ _ 4)' worth
+;;; writing at all.
+(define (solve-wildcards! declared initializer form env)
+  (cond
+   ((not initializer)
+    (sex-error form "cannot infer the type of" (second form)))
+   ((brace-initializer? initializer)
+    (let ((element (and (array-type? declared) (array-elt declared))))
+      (unless element
+        (sex-error form "cannot infer the type of" (second form)))
+      (for-each (lambda (written)
+                  (let ((type (expression-type written env)))
+                    (when type
+                      (unify element
+                             (parse-type (resolve-closure-types type))
+                             form))))
+                (vector->list initializer))))
+   (else
+    (let ((type (expression-type initializer env)))
+      (unless type
+        (sex-error form "cannot infer the type of" (second form)))
+      ;; `(closure ((int)) int)' is spelled `(struct ƛint_int)'
+      ;; everywhere past this point, and is what `parse-type' knows
+      (unify declared (parse-type (resolve-closure-types type)) form)))))
+
+;;; `#(0 1 4 9)', as against the compound literal `#(T : ...)'
+(define (brace-initializer? form)
+  (and (vector? form)
+       (null? (cdr (list-split (vector->list form) ':)))))
+
+(define (wildcard-type? type) (mentions? type '_))
+
+(define (mentions? type word)
+  (cond ((eq? type word) #t)
+        ((list? type) (any (lambda (part) (mentions? part word)) type))
+        (else #f)))
+
+;;; `(each xs compare)' where `each' takes a closure: the argument is
+;;; checked against the parameter that signature wrote.
+(define (convert-arguments form env)
+  (let ((signature (and (symbol? (car form)) (get-name-type (car form)))))
+    (if (and (list? signature) (= 3 (length signature)) (eq? 'fn (car signature)))
+        (copy-form-source!
+         form
+         (cons (car form)
+               (map (lambda (argument expected)
+                      (if expected
+                          (convert-to-closure expected argument env form)
+                          argument))
+                    (cdr form)
+                    (parameter-types signature (length (cdr form))))))
+        form)))
+
+;;; One per argument, #f past the end of the parameter list -- a
+;;; variadic tail has nothing written to check against
+(define (parameter-types signature count)
+  (let pair ((params (second signature)) (remaining count) (acc (list)))
+    (cond
+     ((zero? remaining) (reverse acc))
+     ((null? params) (pair params (- remaining 1) (cons #f acc)))
+     (else (pair (cdr params) (- remaining 1)
+                 (cons (unwrap-type (car params)) acc))))))
+
+(define (walk-parts form env)
+  (copy-form-source! form (walk-body form env)))
+
+
+(define (as-closure-type type)
+  (cond
+   ((closure-type? type) type)
+   ((and (list? type) (= 2 (length type)) (eq? 'struct (car type)))
+    (hash-table-ref/default +closure-structs+ (second type) #f))
+   (else #f)))
+
+(define (receiver-closure-type expr env)
+  (as-closure-type (expression-type expr env)))
+
+;;; The type of an lvalue path, from known declarations -- a name, and
+;;; what can be reached from one by subscripting, dereferencing and
+;;; member access.
+
+;;; The type of an expression as a surface type, or #f when nothing
+;;; here can say. Every form it visits is recorded in `form-type', so
+;;; asking once types the whole subtree.
+;;;
+;;;   42          -> int              (. p x)    -> that field's type
+;;;   "hi"        -> (* const char)   (& p)      -> (* (struct point))
+;;;   (area 3 4)  -> what `area' returns
+(define (expression-type expr env)
+  (set-form-type! expr (compute-expression-type expr env)))
+
+(define (compute-expression-type expr env)
+  (cond
+   ((and (number? expr) (exact? expr)) 'int)
+   ((number? expr) 'double)
+   ((string? expr) '(* const char))
+   ((char? expr) 'char)
+   ((memq expr '(true false)) 'bool)
+   ;; `#(T : ...)' carries its own type; a bare `#(...)' has none and
+   ;; takes one from whatever it is being written into
+   ((vector? expr)
+    (let ((parts (list-split (vector->list expr) ':)))
+      (and (pair? (cdr parts))
+           (let ((written (car parts)))
+             (if (= 1 (length written)) (car written) written)))))
+   ((symbol? expr) (or (lookup-name env expr) (get-name-type expr)))
+   ((not (and (list? expr) (pair? expr))) #f)
+   ;; a call of no arguments is still a call
+   ((< (length expr) 2)
+    (and (symbol? (car expr)) (get-return-type (car expr))))
+   (else
+    (case (car expr)
+      ((¤) (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)))))
+      ;; unary `*' is a dereference; with two operands it is a product
+      ((*) (if (= 2 (length expr))
+               (pointer-target (expression-type (second expr) env))
+               (arithmetic-type expr env)))
+      ((dot-access) (member-path-type (expression-type (second expr) env)
+                                      (cddr expr)))
+      ((->) (member-path-type (pointer-target (expression-type (second expr) env))
+                              (cddr expr)))
+      ((cast) (and (= 3 (length expr)) (third expr)))
+      ((sizeof) 'size-t)
+      ((== != < > <= >= c-and c-or !) 'bool)
+      ((+ - / %) (arithmetic-type expr env))
+      ;; otherwise a call: a closure answers with its own return type,
+      ;; anything else with what its signature says
+      (else
+       (let ((closure (receiver-closure-type (car expr) env)))
+         (if closure
+             (third closure)
+             (and (symbol? (car expr)) (get-return-type (car expr))))))))))
+
+;;; C's usual arithmetic conversions, far enough to answer `_':
+;;;
+;;;   (+ i d)     i int, d double  -> double
+;;;   (+ i l)     l long           -> long
+;;;   (+ g d)     g float          -> double
+;;;   (+ (& p) 1)                  -> (* (struct point))
+;;;
+;;; `unsigned int' against `int' answers `int', where C says otherwise.
+(define (arithmetic-type expr env)
+  (fold (lambda (operand joined)
+          (arith-join joined (expression-type operand env)))
+        #f
+        (cdr expr)))
+
+(define (arith-join left right)
+  (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))))))
+
+;;; `char' and `short' promote to `int', so the ranks start there
+(define (conversion-rank type)
+  (let ((words (and (prim-type? type) (prim-name type))))
+    (cond
+     ((not words) 1)
+     ((memq 'double words) (if (memq 'long words) 7 6))
+     ((memq 'float words) 5)
+     ((memq 'long words) (if (= 2 (count (lambda (w) (eq? w 'long)) words)) 4 3))
+     (else 1))))
+
+
+;;; `(* const char)' is flat: everything after the `*' is the target.
+;;; `(& x)' builds the nested `(* (struct point))' and `unparse-type'
+;;; writes the flat `(* struct point)', so both spellings turn up.
+(define (pointer-target type)
+  (and (list? type)
+       (>= (length type) 2)
+       (eq? '* (car type))
+       (unwrap-type (cdr type))))
+
+(define (member-path-type type fields)
+  (if (null? fields)
+      type
+      (member-path-type (field-type type (car fields)) (cdr fields))))
+
+(define (field-type type field)
+  (let ((name (cond ((symbol? type) type)
+                    ((and (list? type)
+                          (= 2 (length type))
+                          (memq (car type) '(struct union)))
+                     (second type))
+                    (else #f))))
+    (and name
+         (let* ((fields (get-fields name))
+                (entry (and fields (assq field fields))))
+           (and entry (second entry))))))
+
 (define (make-lambda-name enclosing-fn-name counter)
   (string->symbol
-   (fmt #f "__lambda_" counter "_" enclosing-fn-name)))
+   (fmt #f "λ" counter "_" enclosing-fn-name)))
 
-(define (make-aux-lambda-struct name form)
+(define (lift-lambda name form)
   (match form
-    (('lambda arglist ret-type captures . body)
-     ;; Captures are ignored for now, but
-     ;; we'll need them for TODO: closures support
+    (('lambda arglist ret-type . body)
      (process-fn (copy-form-source! form `(fn ,name ,arglist ,ret-type ,@body))
                  (list)))
     (else (sex-error form "malformed lambda" form))))
 
+;;; Closures
+;;;
+;;; A closure is a function pointer and an inline environment, so the
+;;; value owns its captures and nothing is allocated. The type
+;;; `(closure ((int)) int)' becomes one struct per signature, shared by
+;;; every closure with that signature. The captures live in `env' as a record
+;;; only the lifted body knows the shape of, which is why `env' is
+;;; max_align_t rather than char -- it has to be aligned for whatever
+;;; ends up in it.
+;;;
+;;; The expression becomes three hoisted definitions -- the capture
+;;; struct, the lifted body, and a constructor -- and is replaced by a
+;;; call to the constructor, so the captures are evaluated as ordinary
+;;; arguments at the point the closure is written.
+
+;;; How much of a closure is environment, in bytes. Counted in bytes
+;;; so a closure that fits where it was written will also fit
+;;; elsewhere. Captures are only by value, and never allocated on
+;;; heap. Anything that is more than 16 bytes should be stored as a
+;;; pointer, and memory management is entirely up to caller
+
+(define +closure-env-bytes+ 16)
+
+;;; +closure-env-bytes+ for maximum capacity, max-align-t for
+;;; effectiveness, hence union
+(define +closure-env-type+ 'ƛenv)
+
+(define (closure-env-declaration)
+  `(union ,+closure-env-type+ ((align max-align-t)
+                               (bytes (¤ char ,+closure-env-bytes+)))))
+
+(define +closure-structs+ (make-hash-table))
+(define +closure-forwards+ (make-hash-table))
+(define *pending-closure-structs* (list))
+
+(define (closure-expression? form)
+  (and (list? form)
+       (pair? form)
+       (eq? 'closure (car form))
+       (>= (length form) 4)))
+
+(define (closure-type? form)
+  (and (pair? form)
+       (eq? 'closure (car form))
+       (= 3 (length form))))
+
+;;; A type spelling becomes an identifier deterministically, so two
+;;; translation units have the same signatures for the same closure
+;;; types: (* const char) -> p_const_char, (closure ((int)) int) ->
+;;; closure_int_int.
+(define (mangle-type type)
+  (cond
+   ((symbol? type) (mangle-word (symbol->string type)))
+   ((number? type) (number->string type))
+   ((null? type) "void")
+   ((pair? type) (string-intersperse (map mangle-type (mangle-head type)) "_"))
+   (else (sex-error type "cannot mangle type" type))))
+
+(define (mangle-head type)
+  (case (car type)
+    ((*) (cons 'p (cdr type)))
+    ((¤) (cons 'a (cdr type)))
+    (else type)))
+
+(define (mangle-word word)
+  (list->string
+   (map (lambda (c)
+          (if (or (char-alphabetic? c) (char-numeric? c)) c #\_))
+        (string->list word))))
+
+(define (aggregates-in type)
+  (cond
+   ((not (list? type)) (list))
+   ((and (= 2 (length type))
+         (memq (car type) '(struct union))
+         (symbol? (second type)))
+    (list type))
+   (else (append-map aggregates-in type))))
+
+;;; Extract aggregate types from the closure's signature to forward
+;;; declare them before the closure, so they can be referenced in the
+;;; closure. Particularly useful for complex cases like fixed point
+;;; combinator, etc.
+(define (forward-declare-aggregates! type src-form)
+  (for-each
+   (lambda (aggregate)
+     (let ((name (second aggregate)))
+       (unless (or (hash-table-exists? +closure-forwards+ name)
+                   (get-tag-info name))
+         (hash-table-set! +closure-forwards+ name #t)
+         (set! *pending-closure-structs*
+           (cons (copy-form-source! src-form aggregate)
+                 *pending-closure-structs*)))))
+   (delete-duplicates (aggregates-in type))))
+
+(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-type (third type)))))
+
+;;; The code pointer takes the environment first; everything else is
+;;; the closure's own signature.
+(define (closure-code-type type)
+  `(fn (((* void)) ,@(second type)) ,(third type)))
+
+;;; Emitted once per signature, before the toplevel form that first
+;;; needed it.
+(define (register-closure-type! type src-form)
+  (let ((name (closure-struct-name type)))
+    (unless (hash-table-exists? +closure-structs+ name)
+      (forward-declare-aggregates! type src-form)
+      (hash-table-set! +closure-structs+ name type)
+      (let ((form (copy-form-source!
+                   src-form
+                   `(struct ,name ((code ,(closure-code-type type))
+                                   (env (union ,+closure-env-type+)))))))
+        (register-aggregate! form)
+        (set! *pending-closure-structs*
+          (cons form *pending-closure-structs*))))
+    name))
+
+;;; Every closure type in FORM becomes the struct for its signature,
+;;; registering it on the way. The walker does this for function bodies
+;;; and headers; globals come through here instead.
+;;; The inverse of `resolve-closure-types', for what a macro is shown:
+;;; `(struct ƛint_int)' is a generated name, and `(closure ((int)) int)'
+;;; is what was written and what a `type-match' pattern says.
+(define (unresolve-closure-types type)
+  (or (as-closure-type type)
+      (if (list? type)
+          (map unresolve-closure-types type)
+          type)))
+
+(define (resolve-closure-types form)
+  (cond
+   ;; `(closure args ret captures . body)' is an expression, and one is
+   ;; lifted into the function it was written in. At toplevel, or in a
+   ;; struct field, there is none
+   ((closure-expression? form)
+    (sex-error form "a closure can only be written inside a function" form))
+   ((closure-type? form)
+    (copy-form-source! form `(struct ,(register-closure-type! form form))))
+   ((list? form)
+    (copy-form-source! form (map resolve-closure-types form)))
+   (else form)))
+
+(define +closure-conversions+ (make-hash-table))
+
+;;; `(var c (closure ((int)) int) sum)' becomes `ƛint_int_fromfn(sum)'.
+;;; The function pointer goes in the environment and a thunk reads it
+;;; back out, so one thunk serves every function of that signature:
+;;;
+;;;   struct ƛint_int_fnptr { int (*f)(int); };
+;;;   static int ƛint_int_fnthunk (void *ƛe, int ƛa0) {
+;;;       struct ƛint_int_fnptr *ƛcaptures = ƛe;
+;;;       return ƛcaptures->f(ƛa0);
+;;;   }
+(define (register-fn-conversion! type src-form)
+  (let* ((closure (closure-struct-name type))
+         (convert (suffixed closure "_fromfn"))
+         (record  (suffixed closure "_fnptr"))
+         (thunk   (suffixed closure "_fnthunk"))
+         (returns (third type))
+         (pointer `(fn ,(second type) ,returns))
+         (params  (map (lambda (argument index)
+                         (list (string->symbol (fmt #f "ƛa" index))
+                               (unwrap-type argument)))
+                       (second type)
+                       (iota (length (second type))))))
+    (unless (hash-table-exists? +closure-conversions+ convert)
+      (hash-table-set! +closure-conversions+ convert #t)
+      (let ((call `((-> ƛcaptures f) ,@(map first params))))
+        (for-each
+         (lambda (emitted)
+           (set! *pending-closure-structs*
+             (cons (copy-form-source! src-form emitted)
+                   *pending-closure-structs*)))
+         (list
+          `(struct ,record ((f ,pointer)))
+
+          `(fn ,thunk ((ƛe (* void)) ,@params) ,returns
+               (var ƛcaptures (* (struct ,record)) ƛe)
+               ,(if (eq? 'void returns) call `(return ,call)))
+
+          `(fn ,convert ((f ,pointer)) (struct ,closure)
+               (var ƛc (struct ,closure))
+               (= (dot-access ƛc code) ,thunk)
+               (var ƛcaptures (* (struct ,record))
+                    (cast (& (dot-access ƛc env)) (* (struct ,record))))
+               (= (-> ƛcaptures f) f)
+               (return ƛc))))))
+    convert))
+
+;;; A bare function is a closure that captures nothing, so it converts
+;;; wherever one is expected. The reverse cannot: a closure has an
+;;; environment and a function pointer has nowhere to put it.
+(define (convert-to-closure expected value env form)
+  (let ((closure (as-closure-type expected))
+        (actual  (expression-type value env)))
+    (if (and closure
+             (list? actual)
+             (= 3 (length actual))
+             (eq? 'fn (car actual))
+             (equal? (cdr actual) (cdr closure)))
+        (copy-form-source! form
+                           (list (register-fn-conversion! closure form) value))
+        value)))
+
+(define +closure-calls+ (make-hash-table))
+
+;;; The helper a closure call is routed through: `(f 1)' becomes
+;;; `ƛint_int_call(f, 1)', which unpacks the receiver into
+;;; `ƛc.code(&ƛc.env, ƛa0)' inside. The receiver arrives as an argument,
+;;; so it is evaluated once: unpacked at the call site instead,
+;;; `([table (++ i)] 10)' would read
+;;; `table[++i].code(&table[++i].env, 10)' and bump `i' twice.
+(define (register-closure-call! type src-form)
+  (let* ((closure (closure-struct-name type))
+         (helper  (suffixed closure "_call"))
+         (returns (third type))
+         (params  (map (lambda (arg index)
+                         (list (string->symbol (fmt #f "ƛa" index))
+                               (unwrap-type arg)))
+                       (second type)
+                       (iota (length (second type))))))
+    (unless (hash-table-ref/default +closure-calls+ helper #f)
+      (hash-table-set! +closure-calls+ helper #t)
+      (let ((call `((dot-access ƛc code)
+                    (& (dot-access ƛc env))
+                    ,@(map first params))))
+        (set! *pending-closure-structs*
+          (cons (copy-form-source!
+                 src-form
+                 `(fn ,helper ((ƛc (struct ,closure)) ,@params) ,returns
+                      ,(if (eq? 'void returns) call `(return ,call))))
+                *pending-closure-structs*))))
+    helper))
+
+;;; An argument type is written wrapped: `(int)' in `((int) (float))'
+(define (unwrap-type type)
+  (if (and (list? type) (= 1 (length type)))
+      (car type)
+      type))
+
+(define (flush-closure-structs!)
+  (let ((pending *pending-closure-structs*))
+    (set! *pending-closure-structs* (list))
+    pending))
+
+;;; Lowering
+
+(define (make-closure-name enclosing-fn-name counter)
+  (string->symbol (fmt #f "ƛ" counter "_" enclosing-fn-name)))
+
+(define (suffixed name suffix)
+  (string->symbol (string-append (symbol->string name) suffix)))
+
+;;; `(closure ((b int)) int (n) ...)' captures `n' under its own name
+;;; and takes its type from wherever it was declared. `((pa (& a)))'
+;;; names the capture and gives the expression it holds, so `pa' is a
+;;; `(* int)' inside the body and `a' is never mentioned there.
+(define (capture-binding capture form env)
+  (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))))
+      (unless type
+        (sex-error form "cannot infer what is captured as" name))
+      (list name type))))
+
+(define (capture-name capture)
+  (if (pair? capture) (first capture) capture))
+
+;;; What the constructor is handed: the name itself, or the expression
+;;; written beside it
+(define (capture-argument capture)
+  (if (pair? capture) (second capture) capture))
+
+(define (lift-closure base form env)
+  (match form
+    (('closure arglist ret-type captures . body)
+     (let* ((caps      (map (lambda (c) (capture-binding c form env)) captures))
+            (record    (suffixed base "_captures"))
+            (code      (suffixed base "_code"))
+            (construct (suffixed base "_make"))
+            (type      `(closure ,(map (lambda (p) (list (second p))) arglist)
+                                 ,ret-type))
+            (closure   (register-closure-type! type form)))
+       (values
+        construct
+        (map (lambda (f) (copy-form-source! form f))
+             ;; C has no empty struct, and a closure over nothing needs
+             ;; no record to point at
+             (append
+              (if (null? caps)
+                  (list)
+                  (list `(struct ,record ,caps)))
+
+              (list
+               `(fn ,code ((ƛe (* void)) ,@arglist) ,ret-type
+                    ,@(if (null? caps)
+                          (list)
+                          `((var ƛcaptures (* (struct ,record)) ƛe)
+                            ,@(map (lambda (cap)
+                                     `(var ,(first cap) ,(second cap)
+                                           (-> ƛcaptures ,(first cap))))
+                                   caps)))
+                    ,@body)
+
+               `(fn ,construct ,caps (struct ,closure)
+                    (var ƛc (struct ,closure))
+                    ,@(if (null? caps)
+                          (list)
+                          `((static-assert
+                             (<= (sizeof (struct ,record))
+                                 (sizeof (dot-access ƛc env)))
+                             "closure captures do not fit the inline environment")))
+                    (= (dot-access ƛc code) ,code)
+                    ,@(if (null? caps)
+                          (list)
+                          `((var ƛcaptures (* (struct ,record))
+                                 (cast (& (dot-access ƛc env)) (* (struct ,record))))
+                            ,@(map (lambda (cap)
+                                     `(= (-> ƛcaptures ,(first cap)) ,(first cap)))
+                                   caps)))
+                    (return ƛc))))))))
+    (else (sex-error form "malformed closure" form))))
+
 ;;; Structs
 
 ;;; Record the named structs, unions and enums in the type database
 (define (process-struct sex-struct acc)
   (let-values (((doc form) (extract-aggregate-docstring sex-struct)))
-    (register-aggregate! form)
-    (with-docstring doc form acc)))
+    ;; Resolve before registering: a field of closure type has to reach
+    ;; the type database as the struct it becomes, or member access
+    ;; through it finds nothing
+    (let ((form (resolve-closure-types form)))
+      (register-aggregate! form)
+      (with-docstring doc form acc))))
 
 (define (register-aggregate! form)
   (let* ((f (if (eq? (car form) 'pub) (cdr form) form))
@@ -282,7 +1008,13 @@
         ((enum) (add-enum name form))))))
 
 (define (process-global-var sex-var acc)
-  (cons 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)))
+    (when (and (pair? (cdr core)) (pair? (cddr core)) (symbol? (second core)))
+      (add-name-type! (second core) (third core)))
+    (cons form acc)))
 
 ;;; Utils
 (define (non-empty-list? form)

sex-fmt-c.scm

@@ -1015,9 +1015,24 @@
                              (cat nl (make-space (+ 2 (fmt-col st))) str " "))
                    st))))))))))
 
+  ;; `-' arrives as the symbol binary minus uses, and so with binary
+  ;; precedence: `(+ (- b) b)' asked under that spelling comes out
+  ;; `(-b) + b'.
+  (define (unary-operator op)
+    (case op
+      ((-) 'unary-)
+      ((+) 'unary+)
+      ((*) 'unary-*)
+      ((&) 'unary-&)
+      (else op)))
+
+  ;; Parenthesises the whole expression rather than the operand: the
+  ;; other way round, `(. (* p) x)' came out `*(p).x', which C reads as
+  ;; `*(p.x)'.
   (define (c-unary-op op x)
     (c-wrap-stmt
-     (cat (display-to-string op) (c-maybe-paren op (c-expr x)))))
+     (c-maybe-paren (unary-operator op)
+                    (cat (display-to-string op) (c-expr x)))))
 
   ;; some convenience definitions
 

sex-macros.scm

@@ -25,9 +25,14 @@
            ;; the type database
            (import scheme
                    (scheme base)
+                   ;; a type is a list, so a macro reading one wants
+                   ;; `(third type)' rather than `(caddr type)'
+                   (only srfi-1 first second third fourth fifth last)
                    (only sex-macros cat comment)
                    (only types get-type-info get-tag-info get-fields
-                         get-underlying-type type-match map-fields))
+                         get-underlying-type type-match type-pattern-matches?
+                         map-fields
+                         get-name-type get-return-type type-of))
            ,@body)))
 
 (define (get-macro name)

sexc.scm

@@ -175,17 +175,22 @@ status, which is ours to pass on."
                       (semen-process raw-forms))))
 
 (define prelude
-  '((include inttypes.h)
-    (include stdbool.h)
+  (append
+   '((include inttypes.h)
+     (include stdbool.h)
+     (include stddef.h)        ; max_align_t, for closure environments
+     (typedef u8 uint8-t)
+     (typedef i8 int8-t)
+     (typedef u16 uint16-t)
+     (typedef i16 int16-t)
+     (typedef u32 uint32-t)
+     (typedef i32 int32-t)
+     (typedef u64 uint64-t)
+     (typedef i64 int64-t))
 
-    (typedef u8 uint8-t)
-    (typedef i8 int8-t)
-    (typedef u16 uint16-t)
-    (typedef i16 int16-t)
-    (typedef u32 uint32-t)
-    (typedef i32 int32-t)
-    (typedef u64 uint64-t)
-    (typedef i64 int64-t)))
+   ;; The closure environment is the part of the ABI, so include it in
+   ;; every module
+   (list (closure-env-declaration))))
 
 (define (main)
   (let* ((argv (command-line-arguments))

tests/Makefile

@@ -3,10 +3,10 @@ CHICKEN_C = csc
 CSC_FLAGS += -K prefix -static
 MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
 
-MODULES = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
+MODULES = utils types infer sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
 SEX_OBJ = $(MODULES:%=%.o)
 
-TESTS = basic semen reader fmt-c-writer utils line-directives codegen args types
+TESTS = basic semen reader fmt-c-writer utils line-directives codegen args types infer
 TEST_SRCS = $(TESTS:%=%.scm)
 
 sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
@@ -20,6 +20,9 @@ utils.o: utils.module.scm ../utils.scm
 types.o: types.module.scm ../types.scm
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types
 
+infer.o: infer.module.scm ../infer.scm types.o utils.o
+	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) infer.module.scm -o infer.o -unit infer -link types,utils
+
 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
 
@@ -29,8 +32,8 @@ reader.o: reader.module.scm ../reader.scm utils.o
 sex-modules.o: sex-modules.module.scm ../sex-modules.scm reader.o utils.o
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
 
-semen.o: semen.module.scm ../semen.scm sex-macros.o sex-modules.o types.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,types,utils
+semen.o: semen.module.scm ../semen.scm infer.o 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,infer,types,utils
 
 sex-fmt-c.o: ../sex-fmt-c.scm
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) ../sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
@@ -38,8 +41,8 @@ sex-fmt-c.o: ../sex-fmt-c.scm
 fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o utils.o
 	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
 
-sexc.o: sexc.module.scm types.o ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
-	$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,types,utils
+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
 
 clean:
 	rm -f $(SEX_OBJ)

tests/codegen.scm

@@ -259,4 +259,353 @@ compiles."
               "/* A 2D point. */"))
     (test-assert "and an enum docstring too"
       (emits? "(enum color \"RGB.\" (red green blue))"
-              "/* RGB. */"))))
+              "/* RGB. */")))
+
+  ;; `static-assert' is the keyword rather than the <assert.h> macro, so
+  ;; a static assertion costs no include. Mapped in `atom-to-fmt-c'
+  ;; because `unkebabify' alone would spell it `static_assert'.
+  (test-group "static-assert"
+    (test-assert "emits the C11 keyword"
+      (emits? (in-fn "(static-assert (== (sizeof int) 4) \"int is four bytes\")")
+              "_Static_assert(sizeof(int) == 4, \"int is four bytes\")"))
+    (test-assert "and not the header macro"
+      (not (emits? (in-fn "(static-assert (== (sizeof int) 4) \"x\")")
+                   "static_assert("))))
+
+  ;; A closure is a code pointer beside its captures. The struct is
+  ;; named from the signature, so separate translation units agree on
+  ;; it, and calling one goes through `code' with `env' passed first.
+  ;;
+  ;; A closure struct, and the helper its calls go through, are each
+  ;; emitted once per signature; the registries deciding that are
+  ;; compile-time state like the type databases, and outlive a single
+  ;; `sex->c' here. So every case below that looks for a *definition*
+  ;; uses a signature of its own -- cases looking at a call site can
+  ;; share one.
+  (test-group "closures"
+    (test-assert "the type becomes a struct named for its signature"
+      (emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
+              "struct ƛint_int"))
+    ;; The environment is one shared union, declared in the prelude --
+    ;; its layout is part of the ABI two units agree on, so it cannot
+    ;; depend on what either file contains. `sex->c' has no prelude, so
+    ;; what is visible here is the member
+    (test-assert "whose environment is the shared union"
+      (emits? "(fn f ((c (closure ((float)) int))) int (return (c 1.0)))"
+              "union ƛenv env;"))
+    ;; The receiver goes through a helper rather than being written
+    ;; out twice, so that `[table (++ i)]' evaluates its index once,
+    ;; exactly as it would for an array of function pointers
+    (test-assert "a call passes the receiver to a helper"
+      (emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
+              "ƛint_int_call(c, 1)"))
+    (test-assert "and the helper is what dereferences it"
+      (emits? "(fn f ((c (closure ((long)) int))) int (return (c 1)))"
+              "ƛc.code(&ƛc.env, ƛa0)"))
+    (test-assert "a subscript receiver is evaluated once"
+      (emits? "(fn f ((t (¤ (closure ((int)) int) 4)) (i int)) int (return ((¤ t (++ i)) 1)))"
+              "ƛint_int_call(t[++i], 1)"))
+    (test-assert "so is a member receiver"
+      (emits? "(struct h ((cb (closure ((int)) int))))
+               (fn f ((s (struct h))) int (return ((. s cb) 1)))"
+              "ƛint_int_call(s.cb, 1)"))
+    (test-assert "a captured name is rebound in the lifted body"
+      (emits? "(fn f ((n int)) (closure ((char)) int) (return (closure ((x char)) int (n) (return n))))"
+              "int n = ƛcaptures->n;"))
+    (test-assert "captures are checked against the environment"
+      (emits? "(fn f ((n int)) (closure ((short)) int) (return (closure ((x short)) int (n) (return n))))"
+              "_Static_assert(sizeof(struct"))
+    ;; A closure over nothing has no record to point at, and C has no
+    ;; empty struct to declare for it
+    (test-assert "no captures means no capture record"
+      (not (emits? "(fn f () (closure () int) (return (closure () int () (return 7))))"
+                   "_captures {")))
+    ;; `(name expr)' names a capture and gives what it holds, so the
+    ;; expression is evaluated once, where the closure is written
+    (test-assert "a named capture takes its type from the expression"
+      (emits? "(struct p ((x int) (y int)))
+               (fn f ((s (struct p))) (closure () int)
+                 (return (closure () int ((sum (+ (. s x) (. s y)))) (return sum))))"
+              "int sum;"))
+    (test-assert "and the constructor is handed the expression"
+      (emits? "(struct p ((x int) (y int)))
+               (fn f ((s (struct p))) (closure () int)
+                 (return (closure () int ((sum (+ (. s x) (. s y)))) (return sum))))"
+              "_make(s.x + s.y)"))
+    (test-assert "capturing a pointer is how by-reference is spelled"
+      (emits? "(struct p ((x int)))
+               (fn f ((s (* (struct p)))) (closure () int)
+                 (return (closure () int ((q s)) (return (-> q x)))))"
+              "struct p* q;"))
+    ;; A bare function is a closure that captures nothing, so it
+    ;; converts wherever one is expected -- the pointer goes in the
+    ;; environment and one thunk per signature reads it back out
+    (test-assert "a named function in a var initializer"
+      (emits? "(fn g ((n int)) int (return n))
+               (fn f () void (var c (closure ((int)) int) g))"
+              "ƛint_int_fromfn(g)"))
+    (test-assert "a lambda, which is a bare function too"
+      (emits? "(fn f () void (var c (closure ((int)) int)
+                               (lambda ((n int)) int (return n))))"
+              "ƛint_int_fromfn(λ0_f)"))
+    (test-assert "an argument, against the parameter that signature wrote"
+      (emits? "(fn g ((n int)) int (return n))
+               (fn h ((c (closure ((int)) int))) int (return (c 1)))
+               (fn f () int (return (h g)))"
+              "h(ƛint_int_fromfn(g))"))
+    (test-assert "a return, against the declared return type"
+      (emits? "(fn g ((n int)) int (return n))
+               (fn f () (closure ((int)) int) (return g))"
+              "return ƛint_int_fromfn(g)"))
+    (test-assert "the thunk reads the pointer out of the environment"
+      (emits? "(fn g ((n float)) int (return 1))
+               (fn f () void (var c (closure ((float)) int) g))"
+              "return ƛcaptures->f(ƛa0)"))
+    ;; a signature that does not match is left alone, and C rejects it
+    (test-assert "a function of the wrong signature does not convert"
+      (not (emits? "(fn g ((n float)) int (return 1))
+                    (fn f () void (var c (closure ((int)) int) g))"
+                   "_fromfn(g)")))
+    ;; a closure is lifted into the function it was written in, so
+    ;; there has to be one
+    (test-assert "a closure at toplevel is refused"
+      (reports? "(var c (closure () int) (closure () int () (return 1)))"
+                "only be written inside a function"))
+    (test-assert "and so is one in a struct field"
+      (reports? "(struct s ((f (closure () int) (closure () int () (return 1)))))"
+                "only be written inside a function"))
+    ;; A block opens a scope, so what it declares ends with it
+    (test-assert "a name shadowed in a block does not escape it"
+      (emits? "(fn mk () (closure () int) (return (closure () int () (return 1))))
+               (fn f () int (var c (closure () int) (mk))
+                            (do (var c int 9) (g c))
+                            (return (c)))"
+              "ƛvoid_int_call(c)"))
+    (test-assert "and the shadowing declaration is what the block sees"
+      (emits? "(fn mk () (closure () int) (return (closure () int () (return 1))))
+               (fn f () int (var c (closure () int) (mk))
+                            (do (var c int 9) (g c))
+                            (return (c)))"
+              "g(c)"))
+    ;; The receiver is written twice, so a name used as an argument
+    ;; must not be mistaken for a call of its own
+    (test-assert "a closure passed as an argument stays a value"
+      (emits? "(fn g ((c (closure ((int)) int))) int (return 0))
+               (fn f ((c (closure ((int)) int))) int (return (g c)))"
+              "g(c)")))
+
+  ;; a macro body reads types as lists, so the srfi-1 accessors are in
+  ;; scope beside the type database
+  (test-group "macro list accessors"
+    (test-assert "third reads an array's length"
+      (emits? "(defmacro (len t) (third t))
+               (fn f () int (return (len (¤ int 7))))"
+              "return 7;"))
+    (test-assert "second reads a tag"
+      (emits? "(defmacro (tag t) (symbol->string (second t)))
+               (fn f () void (g (tag (struct point))))"
+              "g(\"point\")")))
+
+  ;; `type-of' hands a macro the type of an *expression*, where
+  ;; `get-name-type' only answers for a name. The macro is expanded
+  ;; during the walk rather than before it, so the scope is still live.
+  (test-group "type-of"
+    (test-assert "a local, from its declaration"
+      (emits? "(defmacro (t x) (type-match (type-of x) (int 1) (else 0)))
+               (fn f () int (var n int 0) (return (t n)))"
+              "return 1;"))
+    (test-assert "an expression, not just a name"
+      (emits? "(defmacro (t x) (type-match (type-of x) (double 1) (else 0)))
+               (fn f () int (var d double 0.0) (return (t (+ d 1))))"
+              "return 1;"))
+    (test-assert "a call, through the callee's signature"
+      (emits? "(fn g () float (return 1.0))
+               (defmacro (t x) (type-match (type-of x) (float 1) (else 0)))
+               (fn f () int (return (t (g))))"
+              "return 1;"))
+    ;; a macro is shown the written spelling, not the generated struct
+    (test-assert "a closure, spelled the way it was written"
+      (emits? "(fn mk () (closure ((int)) int)
+                 (return (closure ((b int)) int () (return b))))
+               (defmacro (t x) (type-match (type-of x) ((closure _ _) 1) (else 0)))
+               (fn f () int (var c _ (mk)) (return (t c)))"
+              "return 1;"))
+    (test-assert "and calling one has the closure's return type"
+      (emits? "(fn mk () (closure ((int)) int)
+                 (return (closure ((b int)) int () (return b))))
+               (defmacro (t x) (type-match (type-of x) (int 1) (else 0)))
+               (fn f () int (var c _ (mk)) (return (t (c 1))))"
+              "return 1;"))
+    ;; outside an expansion there is no scope to ask about
+    (test-assert "a name the walk has not reached is unknown"
+      (emits? "(defmacro (t x) (type-match (type-of x) (int 1) (else 0)))
+               (fn f () int (return (t nope)))"
+              "return 0;")))
+
+  ;; `_' as a type is written out from what the initializer says. The
+  ;; answer comes from declarations and from the signature a call names,
+  ;; never from unification -- a partial type would need one.
+  (test-group "wildcard types"
+    (test-assert "an integer literal"
+      (emits? (in-fn "(var x _ 42)") "int x = 42"))
+    (test-assert "a float literal"
+      (emits? (in-fn "(var x _ 3.5)") "double x = 3.5"))
+    (test-assert "a string literal"
+      (emits? (in-fn "(var x _ \"hi\")") "const char * x"))
+    (test-assert "a call, through the name table"
+      (emits? "(fn g ((a int)) float (return 1.0))
+               (fn f () void (var x _ (g 1)))"
+              "float x = g(1)"))
+    (test-assert "a struct member"
+      (emits? "(struct p ((a int) (b float)))
+               (fn f ((s (struct p))) void (var x _ (. s b)))"
+              "float x = s.b"))
+    (test-assert "an address, which composes"
+      (emits? "(struct p ((a int)))
+               (fn f ((s (struct p))) void (var x _ (& s)))"
+              "struct p* x = &s"))
+    (test-assert "a comparison is a bool"
+      (emits? (in-fn "(var x _ (< a b))") "bool x = a < b"))
+    ;; a wildcard inside a spelling is solved in place, leaving the rest
+    ;; of the written type alone -- this is what needs the unifier
+    (test-assert "a wildcard inside a pointer"
+      (emits? "(struct p ((a int)))
+               (fn f ((s (struct p))) void (var x (* _) (& s)))"
+              "struct p* x = &s"))
+    (test-assert "a wildcard inside an array"
+      (emits? (in-fn "(var t (¤ _ 3) #((¤ int 3) : 1 2 3))") "int t[3]"))
+    ;; a compound literal carries its own type, where a brace
+    ;; initializer has none and takes one from its context
+    (test-assert "a compound literal answers a bare wildcard"
+      (emits? "(struct p ((a int) (b int)))
+               (fn f () void (var x _ #((struct p) : 1 2)))"
+              "struct p x = (struct p){1, 2}"))
+    (test-assert "a brace initializer cannot"
+      (reports? (in-fn "(var x _ #(1 2))") "cannot infer the type"))
+    ;; ...but its elements still solve the hole in an array type
+    (test-assert "elements solve an array's element type"
+      (emits? (in-fn "(var t (¤ _ 4) #(0 1 4 9))") "int t[4] = {0, 1, 4, 9}"))
+    (test-assert "including when there are fewer than the length"
+      (emits? (in-fn "(var t (¤ _ 10) #(1 2))") "int t[10] = {1, 2}"))
+    (test-assert "and they have to agree with each other"
+      (reports? (in-fn "(var t (¤ _ 2) #(1 \"s\"))") "type mismatch"))
+    ;; a closure type reaches the solver as the struct that stands for
+    ;; it, which is the spelling `parse-type' knows
+    (test-assert "a closure, from the signature that produced it"
+      (emits? "(fn mk () (closure ((int)) int)
+                 (return (closure ((b int)) int () (return b))))
+               (fn f () void (var c _ (mk)))"
+              "struct ƛint_int c = mk()"))
+    (test-assert "and it is callable once inferred"
+      (emits? "(fn mk () (closure ((int)) int)
+                 (return (closure ((b int)) int () (return b))))
+               (fn f () int (var c _ (mk)) (return (c 1)))"
+              "ƛint_int_call(c, 1)"))
+    ;; C's usual arithmetic conversions, far enough to answer `_'
+    (test-assert "floating beats integral"
+      (emits? (in-fn "(var d double 1.0) (var x _ (+ a d))") "double x = a + d"))
+    (test-assert "the wider integer wins"
+      (emits? (in-fn "(var l long 1) (var x _ (+ a l))") "long x = a + l"))
+    (test-assert "double beats float"
+      (emits? (in-fn "(var g float 1.0) (var d double 1.0) (var x _ (+ g d))")
+              "double x = g + d"))
+    (test-assert "and same-width operands stay put"
+      (emits? (in-fn "(var g float 1.0) (var x _ (+ g g))") "float x = g + g"))
+    (test-assert "a pointer operand makes it pointer arithmetic"
+      (emits? "(struct p ((a int)))
+               (fn f ((s (struct p))) void (var x _ (+ (& s) 1)))"
+              "struct p* x = &s + 1"))
+    ;; a written type that cannot match what the initializer gives
+    (test-assert "a mismatch is reported, not papered over"
+      (reports? (in-fn "(var p (* _) 42)") "type mismatch"))
+    ;; a wildcard that cannot be answered is an error, not a guess
+    (test-assert "with no initializer there is nothing to infer from"
+      (reports? (in-fn "(var x _)") "cannot infer the type"))
+    (test-assert "nor from a name the compiler never saw declared"
+      (reports? (in-fn "(var x _ (never-declared))") "cannot infer the type")))
+
+  ;; `(car res)' on the expansion assumed it was a pair, so a macro
+  ;; computing a value rather than building a form crashed the compiler.
+  (test-group "macro expanding to an atom"
+    (test-assert "a number"
+      (emits? "(defmacro (two) 2) (fn f () int (return (two)))"
+              "return 2;"))
+    (test-assert "a string"
+      (emits? "(defmacro (who) \"sex\") (fn f () void (g (who)))"
+              "g(\"sex\")"))
+    ;; a symbol expansion can stand where a type does, which is what
+    ;; makes a macro able to compute one
+    (test-assert "a symbol, used as a type"
+      (emits? "(defmacro (ty) 'int) (fn f () void (var x (ty) 0))"
+              "int x = 0"))
+    ;; ...and nothing at all, for a macro that only registers something
+    (test-assert "nothing, at toplevel"
+      (emits? "(defmacro (quiet) (list)) (quiet) (fn f () int (return 1))"
+              "return 1;"))
+    (test-assert "nothing, in a body"
+      (emits? "(defmacro (quiet) (list)) (fn f () int (quiet) (return 1))"
+              "return 1;"))
+    ;; several forms need `$', which is what tells a splice from a call
+    (test-assert "$ splices"
+      (emits? "(defmacro (pair) (list '$ '(fn a () int (return 1))
+                                         '(fn b () int (return 2))))
+               (pair)"
+              "b (void)"))
+    (test-assert "and ($) is nothing at all"
+      (emits? "(defmacro (quiet) (list '$)) (quiet) (fn f () int (return 1))"
+              "return 1;"))
+    ;; without `$' a list is one form, so a head that is itself a form
+    ;; stays a call rather than becoming two statements
+    (test-assert "a computed callee stays one form"
+      (emits? "(fn mk () (closure ((int)) int)
+                 (return (closure ((b int)) int () (return b))))
+               (defmacro (apply-it x) `((mk) ,x))
+               (fn f () int (return (apply-it 5)))"
+              "ƛint_int_call(mk(), 5)"))
+    ;; spliced, it would have become two forms in the `return' -- the
+    ;; comma operator, and the wrong answer
+    (test-assert "rather than two forms in its context"
+      (not (emits? "(fn mk () (closure ((int)) int)
+                      (return (closure ((b int)) int () (return b))))
+                    (defmacro (apply-it x) `((mk) ,x))
+                    (fn f () int (return (apply-it 5)))"
+                   "return mk(), 5"))))
+
+  ;; A unary expression parenthesised its operand rather than itself, so
+  ;; the parens landed inside: `*(p).x', which C reads as `*(p.x)'.
+  (test-group "unary operand precedence"
+    (test-assert "member access through a dereference"
+      (emits? "(struct pt ((x int))) (fn f ((p (* (struct pt)))) int (return (. (* p) x)))"
+              "(*p).x"))
+    (test-assert "and not with the parens inside"
+      (not (emits? "(struct pt ((x int))) (fn f ((p (* (struct pt)))) int (return (. (* p) x)))"
+                   "*(p).x")))
+    (test-assert "member access through a cast"
+      (emits? (in-fn "(var n int (. (* (cast a (* (struct s)))) f))")
+              "(*(struct s*)a).f"))
+    ;; ...without gaining parens where none are due
+    (test-assert "a bare dereference is left alone"
+      (emits? (in-fn "(var p (* int) 0) (= a (* p))") "a = *p"))
+    (test-assert "so is address-of in an argument"
+      (emits? (in-fn "(g (& a))") "g(&a)"))
+    (test-assert "and negation beside a binary operator"
+      (emits? (in-fn "(var n int (+ (- a) b))") "-a + b")))
+
+  ;; An array bound was taken only when it was an integer literal, so a
+  ;; symbolic one fell into the type: `(¤ int N)' came out `int N a[]'.
+  (test-group "array bounds"
+    (test-assert "a symbolic bound"
+      (emits? "(define N 4) (struct s ((a (¤ int N))))" "int a[N]"))
+    (test-assert "an expression bound"
+      (emits? "(define N 4) (struct s ((a (¤ char (* 2 N)))))" "char a[2 * N]"))
+    (test-assert "an integer bound still works"
+      (emits? "(struct s ((a (¤ int 4))))" "int a[4]"))
+    ;; a multi-word type is keywords all the way down, so a trailing
+    ;; keyword belongs to the type and leaves the array unsized
+    (test-assert "a multi-word type is not a bound"
+      (emits? "(struct s ((a (¤ unsigned int))))" "unsigned int a[]"))
+    ;; ...and a tag always follows its keyword
+    (test-assert "nor is an aggregate tag"
+      (emits? "(struct t ((z int))) (struct s ((a (¤ struct t))))" "struct t a[]"))
+    (test-assert "nor one behind a pointer"
+      (emits? "(struct t ((z int))) (struct s ((a (¤ * struct t))))" "struct t* a[]"))))

tests/infer.module.scm

@@ -0,0 +1,44 @@
+(module infer
+    (;; The IR
+     tvar?
+     tvar-id
+     tvar-classes
+     tvar-rigid?
+     fresh-tvar
+     fresh-rigid-tvar
+
+     prim-type? prim-name prim-quals make-prim
+     ptr-type? ptr-target ptr-quals make-ptr
+     array-type? array-elt array-size make-array-type
+     fn-type? fn-ret fn-args fn-variadic? make-fn-type
+     agg-type? agg-kind agg-name agg-spelling agg-quals make-agg
+     alias-type? alias-name alias-expansion alias-quals make-alias
+     unknown-type? the-unknown-type
+
+     resolve
+     underlying
+     type-quals
+     free-tvars
+     decay
+
+     ;; The boundary
+     parse-type
+     unparse-type
+
+     ;; Constraints
+     register-class!
+     add-instance!
+     entails?
+     default-tvar!
+     default-type-variables!
+
+     ;; Unification
+     unify
+
+     ;; Type schemes
+     scheme? scheme-vars scheme-constraints scheme-type
+     make-scheme
+     generalize
+     instantiate
+     substitute)
+  "../infer.scm")

tests/infer.scm

@@ -0,0 +1,309 @@
+;;; Type inference, layer 0.
+;;;
+;;; Names registered in the type database are prefixed, since the
+;;; database is one table shared by every suite in the linked binary.
+
+(import infer types (chicken sort))
+
+;;; Parse and print a surface type again. Everything in this suite goes
+;;; through this pair, which is deliberate: they are the only thing the
+;;; rest of the compiler will ever see of the IR.
+(define (round-trip surface)
+  (unparse-type (parse-type surface)))
+
+(test-group "infer"
+
+  (test-group "round-trip"
+    ;; Every spelling below appears in example/ or tests/, or is one
+    ;; the C writer documents in walk-type. `type-match' compares types
+    ;; with equal?, so a near miss here is not a cosmetic bug -- it is
+    ;; a reflection macro silently falling into its else branch.
+    (for-each
+     (lambda (surface)
+       (test (conc "round-trips: " surface) surface (round-trip surface)))
+     '(int
+       void
+       char
+       float
+       double
+       size-t
+       GLfloat
+       (unsigned int)
+       (long long)
+       (const int)
+       (const char)
+       (* char)
+       (* void)
+       (* const char)
+       (* * char)
+       (* const * const char)
+       (const * const char)
+       (* FILE)
+       (* SDL-Window)
+       (struct point)
+       (struct list-int)
+       (union value)
+       (enum mood)
+       (const struct list-int)
+       (* struct list-int)
+       (* const struct point)
+       (¤ int 16)
+       (¤ char 512)
+       (¤ GLfloat 15)
+       (¤ float)
+       (¤ * const char)
+       (¤ * const struct res 32)
+       (¤ (¤ const char))
+       (fn () void)
+       (fn ((int)) int)
+       (fn ((int) (int)) int)
+       (fn ((* const char)) size-t)
+       (fn ((* const char) (...)) int)
+       (fn ((¤ float 4)) void)))
+
+    ;; Grouping parens are not part of the type, so these come back
+    ;; canonicalised rather than verbatim -- which is the whole reason
+    ;; unparse-type exists rather than "keep what was written".
+    (test "a grouped element is the same array" '(¤ int 16) (round-trip '(¤ (int) 16)))
+    (test "a grouped base is the same pointer" '(* const char)
+          (round-trip '(* (const char))))
+    (test "a grouped aggregate keeps its qualifier" '(const struct point)
+          (round-trip '(const (struct point))))
+
+    ;; A typedef is transparent to unification and opaque to printing:
+    ;; the generated declaration has to say what the programmer said.
+    (add-typedef 'i-handle '(typedef i-handle int))
+    (test "a typedef prints as itself" 'i-handle (round-trip 'i-handle))
+    (test "and qualified, as itself" '(const i-handle) (round-trip '(const i-handle)))
+    (test "and under a pointer" '(* i-handle) (round-trip '(* i-handle))))
+
+  (test-group "wildcards"
+    (test "a bare _ is a variable" '_ (round-trip '_))
+    (test "and composes under a pointer" '(* _) (round-trip '(* _)))
+    (test "and inside an array" '(¤ _ 4) (round-trip '(¤ _ 4)))
+    (test "and in a signature" '(fn ((_)) _) (round-trip '(fn ((_)) _)))
+
+    ;; Each _ is its own variable: solving one must not solve the rest.
+    (let ((t (parse-type '(fn ((_)) _))))
+      (unify (car (fn-args t)) (parse-type 'int) #f)
+      (test "one hole at a time" '(fn ((int)) _) (unparse-type t))))
+
+  (test-group "structure"
+    (test-assert "a pointer is a pointer" (ptr-type? (parse-type '(* char))))
+    (test "and knows what it points at" 'char
+          (unparse-type (ptr-target (parse-type '(* char)))))
+    (test "quals sit on the level they were written at" '(const)
+          (ptr-quals (parse-type '(const * char))))
+    (test "an unsized array has no size" #f (array-size (parse-type '(¤ int))))
+    (test "a sized one does" 16 (array-size (parse-type '(¤ int 16))))
+    (test "an aggregate is nominal" 'point (agg-name (parse-type '(struct point))))
+    (test-assert "a variadic signature says so"
+                 (fn-variadic? (parse-type '(fn ((* const char) (...)) int))))
+    (test-assert "and a plain one does not"
+                 (not (fn-variadic? (parse-type '(fn ((int)) int)))))
+
+    ;; decay: the conversion C performs at a call site, an operand of
+    ;; `+', or the left half of a subscript.
+    (test "an array decays to a pointer" '(* int) (unparse-type (decay (parse-type '(¤ int 16)))))
+    (test "a function decays to a pointer to itself" '(* (fn ((int)) int))
+          (unparse-type (decay (parse-type '(fn ((int)) int)))))
+    (test "anything else is left alone" 'int (unparse-type (decay (parse-type 'int)))))
+
+  (test-group "unification"
+    (test-assert "a type unifies with itself"
+                 (unify (parse-type 'int) (parse-type 'int) #f))
+    (test-error "and not with another one"
+                (unify (parse-type 'int) (parse-type 'char) #f))
+
+    (let ((a (fresh-tvar)))
+      (unify a (parse-type '(* const char)) #f)
+      (test "a variable takes the shape it is unified with"
+            '(* const char) (unparse-type a)))
+
+    ;; The point of the exercise: `(var p (* _) (& x))' with x : int.
+    (let ((p (parse-type '(* _))))
+      (unify p (parse-type '(* int)) #f)
+      (test "a partial type is completed by one step" '(* int) (unparse-type p)))
+
+    (let ((a (fresh-tvar))
+          (b (fresh-tvar)))
+      (unify a b #f)
+      (unify b (parse-type 'double) #f)
+      (test "two variables joined then solved" 'double (unparse-type a)))
+
+    (test-error "structure has to match"
+                (unify (parse-type '(* int)) (parse-type '(* char)) #f))
+    (test-error "and arity"
+                (unify (parse-type '(fn ((int)) int))
+                       (parse-type '(fn ((int) (int)) int)) #f))
+    (test-error "and aggregates are told apart by name"
+                (unify (parse-type '(struct point)) (parse-type '(struct box)) #f))
+    (test-error "and by kind"
+                (unify (parse-type '(struct point)) (parse-type '(union point)) #f))
+
+    ;; An unwritten array length constrains nothing, the way it does
+    ;; not in C either.
+    (test-assert "an unsized array unifies with a sized one"
+                 (unify (parse-type '(¤ int)) (parse-type '(¤ int 16)) #f))
+    (test-error "but two written lengths must agree"
+                (unify (parse-type '(¤ int 4)) (parse-type '(¤ int 16)) #f))
+
+    ;; A typedef unifies as whatever it stands for.
+    (add-typedef 'i-count '(typedef i-count int))
+    (test-assert "a typedef unifies with its target"
+                 (unify (parse-type 'i-count) (parse-type 'int) #f))
+    (let ((a (fresh-tvar)))
+      (unify a (parse-type 'i-count) #f)
+      (test "and keeps its name when it is the one printed"
+            'i-count (unparse-type a)))
+
+    (test-group "the unknown type"
+      (test-assert "? is consistent with anything"
+                   (unify the-unknown-type (parse-type '(struct point)) #f))
+      (test-assert "in either order"
+                   (unify (parse-type 'int) the-unknown-type #f))
+      ;; ...and binds nothing. Degrading to ? is what keeps an
+      ;; unparsed C declaration from poisoning everything it touches.
+      (let ((a (fresh-tvar)))
+        (unify a the-unknown-type #f)
+        (test "a variable met with ? stays open" '_ (unparse-type a))))
+
+    (test-group "occurs check"
+      ;; Unreachable without recursive types, and the alternative to
+      ;; having it is not an error but a hang.
+      (let ((a (fresh-tvar)))
+        (test-error "a variable may not contain itself"
+                    (unify a (make-ptr a (list)) #f))))
+
+    (test-group "rigid variables"
+      (let ((r (fresh-rigid-tvar))
+            (a (fresh-tvar)))
+        (test-error "a type parameter does not unify with a type"
+                    (unify r (parse-type 'int) #f))
+        (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-group "constraints"
+    (test #t (entails? 'numeric (parse-type 'int)))
+    (test #t (entails? 'numeric (parse-type '(unsigned long))))
+    (test #t (entails? 'integral (parse-type 'char)))
+    (test #f (entails? 'integral (parse-type 'double)))
+    (test #t (entails? 'floating (parse-type 'double)))
+    (test #f (entails? 'floating (parse-type 'int)))
+    (test #f (entails? 'numeric (parse-type '(* char))))
+    (test #t (entails? 'scalar (parse-type '(* char))))
+    (test #f (entails? 'numeric (parse-type 'void)))
+
+    (add-enum 'i-mood '(enum i-mood (glad sad)))
+    (test "an enum is an integer" #t (entails? 'integral (parse-type '(enum i-mood))))
+
+    ;; The third answer, and the important one. A name from a header
+    ;; might well be numeric; #f would reject working programs and #t
+    ;; would invent knowledge.
+    (test "an unparsed C name is not known either way"
+          'unknown (entails? 'numeric (parse-type 'size-t)))
+    (test "nor is an open variable" 'unknown (entails? 'numeric (fresh-tvar)))
+    (test "? entails nothing, but says so quietly"
+          'unknown (entails? 'numeric the-unknown-type))
+
+    ;; A typedef is entailed by what it resolves to, so an alias cannot
+    ;; sneak past a constraint its target would fail.
+    (add-typedef 'i-len '(typedef i-len int))
+    (test "a typedef is judged by its target" #t (entails? 'numeric (parse-type 'i-len)))
+
+    ;; A constrained variable checks its classes at the moment it is
+    ;; solved, not at the end.
+    (let ((a (fresh-tvar '(numeric))))
+      (test-error "solving to a type that fails the class is an error"
+                  (unify a (parse-type '(* char)) #f)))
+    (let ((a (fresh-tvar '(numeric))))
+      (test-assert "and to one that satisfies it is not"
+                   (unify a (parse-type 'double) #f)))
+    ;; ...but an unparsed name is not a failure, it is an absence of
+    ;; knowledge, and must stay silent.
+    (let ((a (fresh-tvar '(numeric))))
+      (test-assert "an unparsed C name does not trip a constraint"
+                   (unify a (parse-type 'GLuint) #f)))
+
+    ;; Joining two variables joins what is known about both.
+    (let ((a (fresh-tvar '(numeric)))
+          (b (fresh-tvar '(integral))))
+      (unify a b #f)
+      (test "constraints merge when variables do"
+            '("integral" "numeric")
+            (sort (map symbol->string (tvar-classes b)) string<?)))
+
+    (test-group "defaulting"
+      (let ((a (fresh-tvar '(numeric))))
+        (default-type-variables! a #f)
+        (test "an open numeric is an int" 'int (unparse-type a)))
+      (let ((a (fresh-tvar '(floating))))
+        (default-type-variables! a #f)
+        (test "an open floating is a double" 'double (unparse-type a)))
+      (let ((a (fresh-tvar)))
+        (test "a variable with nothing known about it cannot be defaulted"
+              #f (default-type-variables! a #f))
+        (test "and stays a hole, for the caller to complain about"
+              '_ (unparse-type a)))
+      ;; Defaulting reaches into the structure, since the hole may be
+      ;; anywhere: `(var p (* _) ...)'.
+      (let ((t (parse-type '(* _))))
+        (unify (ptr-target t) (fresh-tvar '(numeric)) #f)
+        (default-type-variables! t #f)
+        (test "and it reaches inside a type" '(* int) (unparse-type t))))
+
+    (test-group "user classes"
+      ;; A trait bound is the same shape as `numeric', discharged by
+      ;; the same procedure -- that is the point of one representation.
+      ;; It differs in two rules, and both are stated while there is
+      ;; still only one kind of constraint to state them about.
+      (register-class! 'i-ord #f #f #t)
+      (add-struct 'i-circle '(struct i-circle ((r int))))
+      (test "no instance, no entailment" #f (entails? 'i-ord (parse-type '(struct i-circle))))
+      (add-instance! 'i-ord (parse-type '(struct i-circle)))
+      (test "and with one, entailment" #t (entails? 'i-ord (parse-type '(struct i-circle))))
+      ;; Instances key on the resolved type, so an alias cannot be
+      ;; registered twice under two names.
+      (add-typedef 'i-circle-alias '(typedef i-circle-alias (struct i-circle)))
+      (test "an alias of an instance is the same instance"
+            #t (entails? 'i-ord (parse-type 'i-circle-alias)))
+      ;; Decision 2: static dispatch cannot select an instance for a
+      ;; type it does not know, so a strict class says no to ? rather
+      ;; than shrugging the way `numeric' does.
+      (test "a strict class refuses ?" #f (entails? 'i-ord the-unknown-type))
+      (test "where a lenient one abstains" 'unknown (entails? 'numeric the-unknown-type))
+      ;; ...and it has no default to fall back on.
+      (let ((a (fresh-tvar '(i-ord))))
+        (test-error "an unresolved user constraint is an error, not a guess"
+                    (default-type-variables! a #f)))))
+
+  (test-group "schemes"
+    ;; Nothing generalizes yet. The shape is here because a scheme
+    ;; without a constraint list is the wrong shape for every bounded
+    ;; generic, and because instantiation is how a generic body gets
+    ;; fresh cells instead of a second type for the same one.
+    (let* ((a (fresh-tvar '(numeric)))
+           (id (make-fn-type a (list a) #f))
+           (s (generalize id (list))))
+      (test "the free variable is quantified" 1 (length (scheme-vars s)))
+      (test "carrying its class as the scheme's context"
+            '((numeric)) (list (map car (scheme-constraints s))))
+
+      (let ((one (instantiate s))
+            (two (instantiate s)))
+        (test "an instantiation is still open" '(fn ((_)) _) (unparse-type one))
+        (unify (fn-ret one) (parse-type 'int) #f)
+        (test "solving one instantiation" '(fn ((int)) int) (unparse-type one))
+        (test "leaves the other alone" '(fn ((_)) _) (unparse-type two))
+        (test "and the scheme itself untouched" '(fn ((_)) _) (unparse-type id))))
+
+    (let* ((a (fresh-tvar))
+           (b (fresh-tvar))
+           (s (generalize (make-fn-type a (list b) #f) (list b))))
+      (test "a variable free in the environment is not quantified"
+            1 (length (scheme-vars s)))
+      (let ((inst (instantiate s)))
+        (unify (car (fn-args inst)) (parse-type 'char) #f)
+        (test "so instantiating solves it for everyone" 'char (unparse-type b))))))

tests/modules/Makefile

@@ -10,14 +10,17 @@
 #
 # It also checks what only a second translation unit can check: that an
 # imported type reaches the type database, by expanding a macro that
-# reads the imported struct's fields.
+# reads the imported struct's fields; and that a closure type crossing
+# the boundary works both ways -- one built in the module and called
+# here, one built here and called there, through a code pointer that is
+# static in the other object.
 #
 # The public forms carry comments in their headers, which the reduction
 # to a prototype and to an extern both have to look past.
 
 SEXC ?= ../../sexc
 
-EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1
+EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1\nclosure 15 21 201
 
 check:
 	@$(SEXC) greet.sex -c -o greet.o

tests/modules/greet-app.sex

@@ -26,4 +26,11 @@
   (printf "\n")
   (var m (enum mood) grumpy)
   (printf "mood %d\n" m)
+
+  (var add-10 (closure ((int)) int) (make-adder 10))
+  (printf "closure %d %d" (add-10 5) (apply-twice add-10 1))
+  (var base int 100)
+  (var here (closure ((int)) int)
+       (closure ((x int)) int (base) (return (+ base x))))
+  (printf " %d\n" (apply-twice here 1))
   (return 0))

tests/modules/greet.sex

@@ -35,6 +35,19 @@
   (++ greet-count)
   (printf "hello, %s\n" name))
 
+;;; A closure type crossing the boundary. Both units generate the
+;;; struct for this signature independently, so they have to agree on
+;;; its tag and its layout, or the value is passed wrong and nothing
+;;; says so.
+(pub fn make-adder ((n int)) (closure ((int)) int)
+  (return (closure ((b int)) int (n)
+            (return (+ n b)))))
+
+;;; The other direction: a closure built by the importer, whose code
+;;; pointer is static in *its* object, called from here
+(pub fn apply-twice ((f (closure ((int)) int)) (x int)) int
+  (return (f (f x))))
+
 ;;; Not `pub': invisible to importers, and static in the generated C.
 (fn unused-helper () void
   (printf "private\n"))

tests/run.scm

@@ -10,6 +10,7 @@
 (include "codegen.scm")
 (include "args.scm")
 (include "types.scm")
+(include "infer.scm")
 
 ;;; Should be the last in the test suite
 (test-exit)

tests/sex-programs/closures.sex

@@ -0,0 +1,121 @@
+(input)
+(output "Adders: 15 25"
+        "Two captures: 47"
+        "No captures: 7"
+        "Through a parameter: 110"
+        "From an array: 1 2 3"
+        "Index evaluated once: 21 i 1"
+        "Through a struct member: 8"
+        "Shadowed in a block: 9 then 15"
+        "Nested: 33"
+        "Named capture: 7"
+        "Captured pointer: 11 then 12"
+        "From a bare fn: 20 42 7")
+(return 0)
+
+;;; A closure is a code pointer beside its captures, so what this
+;;; checks is that the captures survive the lifting -- that two
+;;; closures of one shape keep their own environments, that a closure
+;;; outlives the call that built it, and that calling one through a
+;;; parameter, an array element or a struct member resolves the same
+;;; way as through a local.
+;;;
+;;; A receiver is also an ordinary expression: `[table (++ i)]' has to
+;;; evaluate its index exactly once, the way it would for an array of
+;;; function pointers.
+
+(include stdio.h)
+
+(fn double-it ((n int)) int
+  (return (* n 2)))
+
+;;; a bare function is a closure that captures nothing, so it converts
+;;; wherever one is expected -- here a declared return type
+(fn as-closure () (closure ((int)) int)
+  (return double-it))
+
+(fn make-adder ((n int)) (closure ((int)) int)
+  (return (closure ((b int)) int (n)
+            (return (+ n b)))))
+
+(fn make-affine ((k int) (b int)) (closure ((int)) int)
+  (return (closure ((x int)) int (k b)
+            (return (+ (* k x) b)))))
+
+(fn make-const-7 () (closure () int)
+  (return (closure () int ()
+            (return 7))))
+
+;;; A closure arriving as a parameter: its type is written, so the call
+;;; resolves without knowing where it came from
+(fn apply-twice ((f (closure ((int)) int)) (x int)) int
+  (return (f (f x))))
+
+(struct handlers ((on-tick (closure ((int)) int))))
+
+(pub fn main () int
+  (var add-10 (closure ((int)) int) (make-adder 10))
+  (var add-20 (closure ((int)) int) (make-adder 20))
+  (printf "Adders: %d %d\n" (add-10 5) (add-20 5))
+
+  (var affine (closure ((int)) int) (make-affine 5 2))
+  (printf "Two captures: %d\n" (affine 9))
+
+  (var seven (closure () int) (make-const-7))
+  (printf "No captures: %d\n" (seven))
+
+  (printf "Through a parameter: %d\n" (apply-twice (make-adder 50) 10))
+
+  (var table (¤ (closure ((int)) int) 3))
+  (var i int 0)
+  (for (= i 0) (< i 3) (++ i)
+       (= (¤ table i) (make-adder i)))
+  (printf "From an array: %d %d %d\n"
+          ((¤ table 0) 1) ((¤ table 1) 1) ((¤ table 2) 1))
+
+  ;; the index must be evaluated once, so `i' ends at 1 and not 2 --
+  ;; read in a separate statement, since reading and bumping it in one
+  ;; printf would be unsequenced whatever the closure did
+  (= i 0)
+  (var once int ([table (++ i)] 20))
+  (printf "Index evaluated once: %d i %d\n" once i)
+
+  (var h (struct handlers) #((struct handlers) : .on-tick (make-adder 5)))
+  (printf "Through a struct member: %d\n" ((. h on-tick) 3))
+
+  ;; a block opens a scope: the inner `add-10' ends with it, and the
+  ;; call after it is the closure again
+  (do (var add-10 int 9)
+      (printf "Shadowed in a block: %d then " add-10))
+  (printf "%d\n" (add-10 5))
+
+  ;; a closure built inside a closure, capturing that one's capture
+  (var outer (closure ((int)) int)
+       (closure ((x int)) int ()
+         (var inner (closure ((int)) int) (make-adder x))
+         (return (inner 3))))
+  (printf "Nested: %d\n" (outer 30))
+
+  ;; a capture can name what it holds rather than borrow a variable's
+  ;; name, and the expression is evaluated where the closure is written
+  (var pt (struct handlers))
+  (var sum-once (closure () int)
+       (closure () int ((sum (+ 3 4))) (return sum)))
+  (printf "Named capture: %d\n" (sum-once))
+
+  ;; capturing a pointer is how by-reference is spelled; the caller owns
+  ;; what it points at
+  (var counter int 11)
+  (var peek (closure () int)
+       (closure () int ((at (& counter))) (return (* at))))
+  (printf "Captured pointer: %d then " (peek))
+  (++ counter)
+  (printf "%d\n" (peek))
+
+  ;; ...and in an initializer, as an argument, and as a return
+  (var from-fn (closure ((int)) int) double-it)
+  (printf "From a bare fn: %d %d %d\n"
+          (apply-twice from-fn 5)
+          ((as-closure) 21)
+          (apply-twice (lambda ((n int)) int (return (+ n 1))) 5))
+  (return 0))

tests/sex-programs/fixpoint.sex

@@ -0,0 +1,61 @@
+(input)
+(output "direct: 120"
+        "fac: 120 3628800"
+        "fib: 55 6765"
+        "applied on the spot: 120")
+(return 0)
+
+;;; A fixed point built out of closures, which is the hardest thing to
+;;; ask of them: recursion with no recursive function anywhere, only
+;;; self-application.
+;;;
+;;; Self-application needs `x x' and so a recursive type, which is
+;;; spelled here by routing it through a named struct whose field is a
+;;; closure whose own signature mentions that struct. The generated
+;;; closure struct is written before `struct rec' is, so this only
+;;; compiles because a forward declaration is emitted ahead of both.
+;;;
+;;; Note what `fix' captures: a *pointer* to the knot, not the knot. A
+;;; closure is a code pointer beside N bytes of environment, so
+;;; capturing one by value would need N >= 8 + N. No budget makes that
+;;; true, and the static assertion says so rather than letting it
+;;; corrupt anything.
+
+(include stdio.h)
+
+(struct rec ((f (closure (((* (struct rec))) (int)) int))))
+
+;;; Takes a step that expects itself, returns an ordinary closure with
+;;; the self-application hidden inside
+(fn fix ((step (* (struct rec)))) (closure ((int)) int)
+  (return (closure ((n int)) int (step)
+            (return ((-> step f) step n)))))
+
+(pub fn main () int
+  (var fac-knot (struct rec))
+  (= (. fac-knot f)
+     (closure ((self (* (struct rec))) (n int)) int ()
+       (if (<= n 1) (return 1))
+       (return (* n ((-> self f) self (- n 1))))))
+
+  ;; the knot applied to itself directly, without fix
+  (printf "direct: %d\n" ((. fac-knot f) (& fac-knot) 5))
+
+  (var fib-knot (struct rec))
+  (= (. fib-knot f)
+     (closure ((self (* (struct rec))) (n int)) int ()
+       (if (< n 2) (return n))
+       (return (+ ((-> self f) self (- n 1))
+                  ((-> self f) self (- n 2))))))
+
+  ;; one combinator, two different recursions
+  (var fac (closure ((int)) int) (fix (& fac-knot)))
+  (var fib (closure ((int)) int) (fix (& fib-knot)))
+  (printf "fac: %d %d\n" (fac 5) (fac 10))
+  (printf "fib: %d %d\n" (fib 10) (fib 20))
+
+  ;; the combinator's result invoked where it is returned, with no
+  ;; intervening `var' -- the receiver's type is the return type of the
+  ;; signature it came from, which is what the name table records
+  (printf "applied on the spot: %d\n" ((fix (& fac-knot)) 5))
+  (return 0))

tests/sex-programs/inference.sex

@@ -0,0 +1,178 @@
+(input)
+(output "15"
+        "42 0.25"
+        "(5, 7)"
+        "(1, 2)"
+        "3"
+        "(5, 7)"
+        "0 1 4 9 "
+        "4"
+        "42"
+        "<closure of 0: 10>"
+        "42"
+        "2 1"
+        "Hello from Sex!")
+(return 0)
+
+;;; Both halves of inference, from the two sides that read the same
+;;; answers: `_' in a type means "work it out", and `type-of' hands a
+;;; macro the type of an expression.
+;;;
+;;; This was written as a draft before either existed, to be read
+;;; before it was built. It is registered now.
+;;;
+;;; Two features, one mechanism:
+;;;
+;;;   `_' in a type means "work it out", and
+;;;   `type-of' hands a macro the type of an expression.
+;;;
+;;; Both are the same solved constraint store, read from two sides.
+
+(include stdio.h)
+(include string.h)
+
+;;; `(include string.h)' is for the C compiler; it tells Sex nothing.
+;;; A signature has to be written before `_' can be resolved from a
+;;; call to `strlen' -- without one the call's type is `?', and a `_'
+;;; that resolves to `?' is an error, not a silent int.
+(extern fn strlen ((s (* const char))) size-t)
+
+(struct point ((x int) (y int)))
+
+(fn midpoint ((a (* const struct point)) (b (* const struct point))) (struct point)
+  (var m (struct point))
+  ;; No `_' here: `m' has no initializer to infer from. Inference fills
+  ;; in a type, it does not invent one.
+  (= (. m x) (/ (+ (-> a x) (-> b x)) 2))
+  (= (. m y) (/ (+ (-> a y) (-> b y)) 2))
+  (return m))
+
+;;; The closure's type is written once, in the signature; `_' reads it
+;;; from there at every use.
+(fn make-adder ((n int)) (closure ((int)) int)
+  (return (closure ((b int)) int (n)
+            (return (+ n b)))))
+
+;;; A macro that asks what it was handed.
+;;;
+;;; `type-of' returns a *surface* type -- the same spelling the type
+;;; database hands to `map-fields' -- so it composes with the
+;;; `type-match' that already exists, and dispatch over a user struct
+;;; costs nothing extra.
+(defmacro (print x)
+  (type-match (type-of x)
+    (int             `(printf "%d\n" ,x))
+    (size-t          `(printf "%zu\n" ,x))
+    (double          `(printf "%g\n" ,x))
+    ((* const char)  `(printf "%s\n" ,x))
+    ;; NOTE: ,x twice -- a macro that duplicates its argument still has
+    ;; to think about evaluating it twice. Inference does not fix that.
+    ((struct point)  `(printf "(%d, %d)\n" (. ,x x) (. ,x y)))
+    ;; a closure is a type like any other, so it dispatches like one --
+    ;; and `_' saves a clause per signature
+    ((closure _ int) `(printf "<closure of 0: %d>\n" (,x 0)))
+    (else (error "print: don't know how to print" (type-of x)))))
+
+;;; The temporary's type is the thing the macro could not write down
+;;; before. Either spelling works -- `_' is the lazier one, and it is
+;;; inferred in the expansion's own scope.
+(defmacro (swap a b)
+  `(do (var tmp _ ,a)
+       (= ,a ,b)
+       (= ,b tmp)))
+
+(pub fn main () int
+  ;; Written out, for contrast with everything below it.
+  (var greeting (* const char) "Hello from Sex!")
+
+  ;; size-t, from the signature above -- not int, and not a guess.
+  (var n _ (strlen greeting))
+  (printf "%zu\n" n)
+
+  ;; Literals carry a constraint, not a type: the int-ish one defaults
+  ;; to int, and the mixed division joins to double the way C does.
+  (var count _ (+ 20 22))
+  (var half  _ (/ 1.0 4))
+  (printf "%d %g\n" count half)
+
+  ;; An aggregate initializer has no type of its own, so the type flows
+  ;; in and has to be written. `(var origin _ #(3 4))' is an error --
+  ;; there is nothing to infer from.
+  (var origin (struct point) #(3 4))
+  (var corner (struct point) #(7 10))
+
+  ;; A compound literal is the way out of that rule: the `:' is where an
+  ;; initializer stops needing a type from its context, so `_' has
+  ;; something to read after all.
+  (var centre _ #((struct point) : 5 7))
+  (print centre)
+
+  ;; ...and the same designated, which names fields instead of counting
+  ;; positions.
+  (var offset _ #((struct point) : .x 1 .y 2))
+  (print offset)
+
+  ;; A partial type: "a pointer to something". The something arrives
+  ;; from the initializer. This is why the wildcard lives in the type
+  ;; grammar rather than beside it -- it composes.
+  (var p (* _) (& origin))
+
+  ;; Member access reads the same type database the macros do.
+  (var x _ (-> p x))
+  (printf "%d\n" x)
+
+  ;; A call into a function Sex has actually parsed: the return type is
+  ;; the whole answer, and `print' then dispatches on it.
+  (var mid _ (midpoint (& origin) (& corner)))
+  (print mid)
+
+  ;; The loop variable, which is where `_' earns its keep most often.
+  (for (var i _ 0) (< i 4) (++ i)
+       (printf "%d " (* i i)))
+  (printf "\n")
+
+  ;; Four of something: the element type is fixed by the initializer,
+  ;; the count by the type. Subscripting gives the element type back.
+  (var squares [_ 4] #(0 1 4 9))
+  (print [squares 2])
+
+  ;; A closure's type comes from the signature that produced it, and
+  ;; calling one needs that type and nothing else.
+  (var add-10 _ (make-adder 10))
+  (print (add-10 32))
+  (print add-10)
+
+  ;; ...including where it is returned, with no name in between.
+  (print ((make-adder 20) 22))
+
+  ;; A macro writing a declaration it could not have written before.
+  (var a _ 1)
+  (var b _ 2)
+  (swap a b)
+  (printf "%d %d\n" a b)
+
+  (print greeting)
+  (return 0))
+
+;;; Open questions this draft raises, to settle before Layer 2 ships:
+;;;
+;;; 1. SETTLED. `type-match' took `_' on the pattern side, so
+;;;    `(closure _ int)' above is one clause rather than one per
+;;;    signature, and `(* _)' and `(¤ _ _)' say "any pointer" and "any
+;;;    array". A `_' written last takes the rest, since a type's words
+;;;    are spread and not nested: `(* const char)' is three elements.
+;;;    Nothing destructures -- a macro body is Scheme and a type is a
+;;;    list, so `(caddr (type-of x))' reads an array's length.
+;;;
+;;; 2. SETTLED, allowed. `[_ 4]' against `#(0 1 4 9)' unifies each
+;;;    element with the hole, so the element type comes from the
+;;;    literals and the length stays as written -- `[_ 10]' with two
+;;;    initializers is still ten. Elements that disagree are a type
+;;;    mismatch. A bare `_' is still refused: `#(0 1 4 9)' has no type
+;;;    of its own, only elements.
+;;;
+;;; 3. POSTPONED to the standard library design. `(extern fn strlen
+;;;    ...)' above duplicates string.h, which is the same bargain every
+;;;    FFI makes, but it is where "no C header parsing" starts costing
+;;;    the user something. A `sex/libc' module of prototypes is the
+;;;    obvious answer and belongs with the rest of the stdlib.

tests/sex-programs/lambdas.sex

@@ -22,21 +22,21 @@
   (printf "Named fn through a pointer: %d\n" (sum-fn a b))
 
   (var sum-lambda (fn ((int) (int)) int)
-       (lambda ((a int) (b int)) int ()
+       (lambda ((a int) (b int)) int
          (return (+ a b))))
   (printf "Lambda through a pointer: %d\n" (sum-lambda a b))
 
   (printf "Lambda called in place: %d\n"
-          ((lambda ((a int) (b int)) int ()
+          ((lambda ((a int) (b int)) int
              (return (+ a b 100)))
            a b))
 
   ;; A lambda inside a lambda: the inner one is lifted out of a
   ;; function that is itself being lifted
   (var outer (fn ((int)) int)
-       (lambda ((x int)) int ()
+       (lambda ((x int)) int
          (var inner (fn ((int)) int)
-              (lambda ((y int)) int ()
+              (lambda ((y int)) int
                 (return (+ 60 y))))
          (return (+ 600 (inner x)))))
   (printf "Nested lambdas: %d\n" (outer 6))

tests/sex-programs/wildcards.sex

@@ -0,0 +1,83 @@
+(input)
+(output "literals: 42 3.5 hello"
+        "calls: 12"
+        "members: 1 2.5"
+        "pointers: 1 2.5"
+        "arrays: 30"
+        "loop: 0 1 2"
+        "shadowed: 9 then 42"
+        "partial: 1 2.5"
+        "joined: 43.5 84 49 1"
+        "from elements: 4 9 0")
+(return 0)
+
+;;; `_' as a type means "work it out from the initializer". What the
+;;; pass can answer comes from declarations -- Sex writes a type at
+;;; every binding site -- and from the signature of whatever a call
+;;; names. A partial type like `(* _)' is solved by unifying what was
+;;; written against what the initializer gives, so only the wildcard
+;;; inside the spelling is filled in.
+
+(include stdio.h)
+
+(struct point ((x int) (y float)))
+
+(fn area ((w int) (h int)) int
+  (return (* w h)))
+
+(pub fn main () int
+  (var n _ 42)
+  (var f _ 3.5)
+  (var s _ "hello")
+  (printf "literals: %d %g %s\n" n f s)
+
+  (var a _ (area 3 4))
+  (printf "calls: %d\n" a)
+
+  (var p (struct point) #((struct point) : .x 1 .y 2.5))
+  (var px _ (. p x))
+  (var py _ (. p y))
+  (printf "members: %d %g\n" px py)
+
+  (var pp _ (& p))
+  (printf "pointers: %d %g\n" (-> pp x) (-> pp y))
+
+  (var table (¤ int 3))
+  (= (¤ table 0) 10)
+  (= (¤ table 1) 20)
+  (var first _ (¤ table 0))
+  (var second _ (¤ table 1))
+  (printf "arrays: %d\n" (+ first second))
+
+  ;; a for opens a scope, and its initializer is declared inside it
+  (printf "loop:")
+  (for (var i _ 0) (< i 3) (++ i)
+       (printf " %d" i))
+  (printf "\n")
+
+  ;; a block's declarations end with it
+  (do (var n _ 9)
+      (printf "shadowed: %d then " n))
+  (printf "%d\n" n)
+
+  ;; a wildcard inside a written type: only it is solved
+  (var pp2 (* _) (& p))
+  (printf "partial: %d %g\n" (-> pp2 x) (-> pp2 y))
+
+  ;; C's usual arithmetic conversions, far enough to answer `_'
+  (var d double 1.5)
+  (var l long 7)
+  (var g float 0.5)
+  (var mixed _ (+ n d))
+  (var same _ (+ n n))
+  (var wider _ (+ n l))
+  (var single _ (+ g g))
+  (printf "joined: %g %d %ld %g\n" mixed same wider single)
+
+  ;; 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
+  (var squares (¤ _ 4) #(0 1 4 9))
+  (var sparse (¤ _ 8) #(0 1))
+  (printf "from elements: %d %d %d\n" (¤ squares 2) (¤ squares 3) (¤ sparse 7))
+  (return 0))

tests/types.module.scm

@@ -6,8 +6,15 @@
      add-define
 
      type-match
+     type-pattern-matches?
      map-fields
 
+     add-name-type!
+     get-name-type
+     type-of
+     current-type-of
+     get-return-type
+
      get-type-info
      get-tag-info
      get-fields

tests/types.scm

@@ -166,9 +166,55 @@
         #f
         (type-match 'float (int 'yes)))
 
+  ;; `_' in a pattern matches anything in that position; written last it
+  ;; takes the rest, since a type's words are spread and not nested
+  (test "a wildcard matches an atom"
+        'yes (type-match 'int (_ 'yes) (else 'no)))
+  (test "a pointer to anything"
+        'yes (type-match '(* int) ((* _) 'yes) (else 'no)))
+  (test "including one spelled with qualifiers"
+        'yes (type-match '(* const char) ((* _) 'yes) (else 'no)))
+  (test "an array of anything, any length"
+        'yes (type-match '(¤ int 4) ((¤ _ _) 'yes) (else 'no)))
+  (test "but a sized pattern does not match an unsized array"
+        'no (type-match '(¤ int) ((¤ _ _) 'yes) (else 'no)))
+  (test "an aggregate of any tag"
+        'yes (type-match '(struct point) ((struct _) 'yes) (else 'no)))
+  (test "and the keyword still has to agree"
+        'no (type-match '(union point) ((struct _) 'yes) (else 'no)))
+  (test "a closure of any signature"
+        'yes (type-match '(closure ((float)) int) ((closure _ _) 'yes) (else 'no)))
+  (test "an exact pattern is still exact"
+        'no (type-match '(* int) ((* const char) 'yes) (else 'no)))
+
   (test "an undeclared name has no entry"
         #f
         (get-type-info 't-never-declared))
   (test "and no fields"
         #f
-        (get-fields 't-never-declared)))
+        (get-fields 't-never-declared))
+
+  ;; What type a *name* has -- the third table, which functions and
+  ;; variables share because a function type has a surface spelling
+  (add-name-type! 't-sum '(fn ((int) (int)) int))
+  (add-name-type! 't-origin '(struct t-point))
+  (test "a function's signature comes back whole"
+        '(fn ((int) (int)) int)
+        (get-name-type 't-sum))
+  (test "and a variable's type"
+        '(struct t-point)
+        (get-name-type 't-origin))
+  (test "the return type is what a call site wants"
+        'int
+        (get-return-type 't-sum))
+  (test "a variable has no return type"
+        #f
+        (get-return-type 't-origin))
+  ;; not an error: this is how a name from an included C header looks,
+  ;; and the caller decides what to make of it
+  (test "an undeclared name has no type"
+        #f
+        (get-name-type 't-never-declared))
+  (test "nor a return type"
+        #f
+        (get-return-type 't-never-declared)))

types.module.scm

@@ -6,8 +6,15 @@
      add-define
 
      type-match
+     type-pattern-matches?
      map-fields
 
+     add-name-type!
+     get-name-type
+     type-of
+     current-type-of
+     get-return-type
+
      get-type-info
      get-tag-info
      get-fields

types.scm

@@ -21,6 +21,12 @@
 (define +type-db+ (make-hash-table))    ; typedefs and defines
 (define +tag-db+ (make-hash-table))     ; struct, union and enums
 
+;;; What type a *name* has, which neither of the two above records:
+;;;
+;;;   (fn sum ((a int) (b int)) int ...) -> (fn ((int) (int)) int)
+;;;   (var origin (struct point) ...)    -> (struct point)
+(define +name-db+ (make-hash-table))
+
 (define (strip-pub form)
   (if (eq? (car form) 'pub) (cdr form) form))
 
@@ -74,6 +80,34 @@
   (hash-table-set! +type-db+ name
                    (list 'define name (cddr (strip-pub form)))))
 
+;;; `(type-of x)' inside a macro body: the type of the expression the
+;;; macro was handed, where `get-name-type' only answers for a name.
+;;; The walker that can answer it lives in `semen', which is compiled
+;;; after this, so it installs itself here for the length of one
+;;; expansion. Outside one there is no scope to ask about, and the
+;;; answer is #f.
+(define current-type-of (make-parameter (lambda (form) #f)))
+
+(define (type-of form) ((current-type-of) form))
+
+(define (add-name-type! name type)
+  (hash-table-set! +name-db+ name type))
+
+;;; #f for a name never declared, which is what `printf' looks like
+;;; until something parses stdio.h. Not an error here; the caller
+;;; decides.
+(define (get-name-type name)
+  (hash-table-ref/default +name-db+ name #f))
+
+;;; What `(make-adder 10)' has for a type: `make-adder's return type,
+;;; or #f when NAME is not a function with a signature on record
+(define (get-return-type name)
+  (let ((type (get-name-type name)))
+    (and (pair? type)
+         (eq? 'fn (car type))
+         (= 3 (length type))
+         (third type))))
+
 (define (get-tag-info name)
   (hash-table-ref/default +tag-db+ name #f))
 
@@ -142,21 +176,47 @@
 ;;;   (int ...)
 ;;;   ((* const char) ...)
 ;;;   ([int 10] ...)
+;;;   ((* _) ...)                     ; a pointer to anything
+;;;   ((¤ _ _) ...)                   ; an array of anything, any length
 ;;;   (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.
+;;; A type is a form, not an atom, so patterns are matched structurally
+;;; rather than dispatched on like `case'. They are literal types and
+;;; are not evaluated; `else' is optional and the whole thing is #f when
+;;; nothing matches and there is no else.
+;;;
+;;; `_' in a pattern matches anything in that position, the same thing
+;;; it means in a type. Without it every spelling has to be enumerated:
+;;; `(closure ((int)) int)' and `(closure ((float)) int)' are separate
+;;; clauses for what is one case.
+;;;
+;;; A `_' written last takes everything that remains, because a type's
+;;; words are spread rather than nested -- `(* const char)' is three
+;;; elements, so `(* _)' has to cover two of them to mean "a pointer to
+;;; anything".
+;;;
+;;; Nothing destructures: a macro body is ordinary Scheme and a type is
+;;; a list, so `(caddr (type-of x))' already reads the length out of
+;;; `(¤ int 4)'.
 (define-syntax type-match
   (syntax-rules (else)
     ((_ type) #f)
     ((_ type (else body ...)) (begin body ...))
     ((_ type (pattern body ...) clause ...)
-     (if (equal? type 'pattern)
+     (if (type-pattern-matches? 'pattern type)
          (begin body ...)
          (type-match type clause ...)))))
 
+(define (type-pattern-matches? pattern type)
+  (cond
+   ((eq? pattern '_) #t)
+   ((and (pair? pattern) (pair? type))
+    (if (and (eq? (car pattern) '_) (null? (cdr pattern)))
+        #t                              ; a trailing `_' takes the rest
+        (and (type-pattern-matches? (car pattern) (car type))
+             (type-pattern-matches? (cdr pattern) (cdr type)))))
+   (else (equal? pattern type))))
+
 ;;; 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

utils.module.scm

@@ -15,7 +15,10 @@
      copy-form-source!
      stamp-form-source!
      form-location
+     set-form-type!
+     form-type
      sex-error
+     sex-warning
      with-directory
      )
   "utils.scm")

utils.scm

@@ -101,6 +101,19 @@
 ;;; The file `parse-all' is currently reading. Bound by the reader
 (define current-source-file (make-parameter "<unknown>"))
 
+;;; What type a form has, once something has worked it out. Keyed by
+;;; cons cell like the sources above, so one form has one type: a body
+;;; typed at two instantiations has to be copied before the second.
+(define +form-types+ (make-hash-table eq?))
+
+(define (set-form-type! form type)
+  (when (pair? form)
+    (hash-table-set! +form-types+ form type))
+  type)
+
+(define (form-type form)
+  (hash-table-ref/default +form-types+ form #f))
+
 (define (set-form-source! form file line)
   (hash-table-set! +form-sources+ form (cons file line)))
 
@@ -138,6 +151,17 @@ wrap a form-building expression."
   "Signal an error about FORM, prefixed with where it was written."
   (apply error (string-append (form-location form) message) args))
 
+(define (sex-warning form message . args)
+  "Report something about FORM that does not stop the compilation.
+Goes to stderr, prefixed with where the form was written, so a warning
+reads like an error and sorts alongside one in a build log."
+  (let ((port (current-error-port)))
+    (display (form-location form) port)
+    (display "warning: " port)
+    (display message port)
+    (for-each (lambda (arg) (display " " port) (display arg port)) args)
+    (newline port)))
+
 (define (stamp-form-source! form src)
   "Give FORM and every subform that has none the location SRC. Used for
 macro expansions, which inherit the location of the call site the way a