alex-eg/sex
1
0
Fork 1
Code Issues 3 Pull Requests 1 Actions Packages Projects 1 Releases Wiki Activity

implement type inference

Browse Source 
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.
This commit is contained in:
alex-eg
2026-09-29 23:52:08 +03:00
parent 53f92727a5
commit 1f445f0f9b
15 changed files with 1126 additions and 100 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
Makefile
View File

@@ -75,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
@@ -97,7 +97,8 @@ sextest:
cp ./tools/sextest/sextest .
SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \
feature-flags lambdas compound-literals closures fixpoint
feature-flags lambdas compound-literals closures fixpoint \
wildcards inference
# Multi-module linking is checked end to end; see tests/modules/Makefile.
check-modules: sexc

530
semen.scm
View File

@@ -7,6 +7,7 @@
(chicken string)
(chicken module)
fmt
infer
sex-macros
sex-modules
types
@@ -38,9 +39,9 @@
(macroexpand (car forms) (cdr forms))
acc))
(else
;; A closure type's struct is emitted before the toplevel form that
;; first mentioned it, which is why the new forms are lifted off and
;; the structs slide underneath them
;; `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)
@@ -241,30 +242,45 @@
(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))
(lifted
(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))
(set! (hash-table-ref env :var-types)
(declared-types (sex-fn-arglist expanded)))
env)))
(processed (rewrite-closure-calls-in-body lifted env)))
(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)))))
(append (hash-table-ref env :lambda-aux-code) acc))))))
(define (declared-types arglist)
(let ((types (make-hash-table)))
(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! types (first param) (second param))))
arglist)
types))
(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)))
@@ -275,55 +291,220 @@
(set! (hash-table-ref env :lambda-aux-code)
(append forms (hash-table-ref env :lambda-aux-code))))
(define (fn-walker form env)
(let ((head (car form)))
;;; 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
((eq? 'lambda head)
((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))
;; a type, not an expression -- becomes the struct for its signature
((closure-type? form)
(copy-form-source! form `(struct ,(register-closure-type! form form))))
((eq? 'closure head)
((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 forms) (lift-closure base form env)))
(add-aux-code! env (fold match-sex-form (list) forms))
(copy-form-source! form `(,construct ,@(fourth form))))))
;; every binding site is written, so tracking the declarations is
;; enough to know a receiver's type without inference
((and (eq? 'var head) (>= (length form) 3))
(hash-table-set! (hash-table-ref env :var-types) (second form) (third form))
form)
(else form))))
(define (rewrite-closure-calls-in-body fn-form env)
(let ((header (fn-header-length fn-form)))
(append (take fn-form header)
(map (lambda (form) (rewrite-closure-calls form env))
(drop fn-form header)))))
(define (rewrite-closure-calls form env)
(if (not (list? form))
form
(let ((type (and (pair? form) (receiver-closure-type (car form) env)))
(rewrite (lambda (sub) (rewrite-closure-calls sub env))))
(let-values (((construct lifted) (lift-closure base form env)))
(add-aux-code! env (fold match-sex-form (list) lifted))
(copy-form-source!
form
(if type
`(,(register-closure-call! type form)
,(rewrite (car form))
,@(map rewrite (cdr form)))
(map rewrite 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)))
;;; A closure type has two spellings: `(closure ...)' as written, and
;;; `(struct ƛ...)' once resolved -- which is what a struct
;;; field holds, since the type database is populated after resolution.
;;; Both name the same thing, so a receiver is recognised either way.
(define (as-closure-type type)
(cond
((closure-type? type) type)
@@ -337,26 +518,111 @@
;;; 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
((symbol? expr)
(hash-table-ref/default (hash-table-ref env :var-types) expr #f))
((not (and (list? expr) (>= (length expr) 2))) #f)
((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 ((base (expression-type (second expr) env)))
(and (list? base) (= 2 (length base)) (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)))
((->) (let ((base (expression-type (second expr) env)))
(and (list? base) (= 2 (length base)) (eq? '* (car base))
(member-path-type (second base) (cddr expr)))))
(else #f)))))
((->) (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)
@@ -421,6 +687,12 @@
(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))
@@ -506,14 +778,90 @@
;;; 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
@@ -563,16 +911,28 @@
(define (suffixed name suffix)
(string->symbol (string-append (symbol->string name) suffix)))
;;; A capture is a plain name, whose type comes from the declarations
;;; the walker has passed. `(name expr)' captures want the type of an
;;; expression, which is inference, and wait for it.
;;; `(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)
(unless (symbol? capture)
(sex-error form "a closure capture must be a plain name for now" capture))
(let ((type (hash-table-ref/default (hash-table-ref env :var-types) capture #f)))
(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 "closure captures an undeclared name" capture))
(list capture 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
@@ -650,7 +1010,11 @@
(define (process-global-var sex-var acc)
;; A global is not walked for lambdas, but its type still has to stop
;; saying `closure' before the writer sees it
(cons (resolve-closure-types sex-var) acc))
(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)

7
sex-macros.scm
View File

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

4
tests/Makefile
View File

@@ -32,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

215
tests/codegen.scm
View File

@@ -320,6 +320,73 @@ compiles."
(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"
@@ -327,6 +394,136 @@ compiles."
(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"
@@ -356,7 +553,23 @@ compiles."
"b (void)"))
(test-assert "and ($) is nothing at all"
(emits? "(defmacro (quiet) (list '$)) (quiet) (fn f () int (return 1))"
"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)'.

43
tests/sex-programs/closures.sex
View File

@@ -6,7 +6,11 @@
"From an array: 1 2 3"
"Index evaluated once: 21 i 1"
"Through a struct member: 8"
"Nested: 33")
"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
@@ -22,6 +26,14 @@
(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)))))
@@ -71,10 +83,39 @@
(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))

8
tests/sex-programs/fixpoint.sex
View File

@@ -1,7 +1,8 @@
(input)
(output "direct: 120"
"fac: 120 3628800"
"fib: 55 6765")
"fib: 55 6765"
"applied on the spot: 120")
(return 0)
;;; A fixed point built out of closures, which is the hardest thing to
@@ -52,4 +53,9 @@
(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))

178
tests/sex-programs/inference.sex Normal file
View File

@@ -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.

83
tests/sex-programs/wildcards.sex Normal file
View File

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

7
tests/types.module.scm
View File

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

48
tests/types.scm
View File

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

7
types.module.scm
View File

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

70
types.scm
View File

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

2
utils.module.scm
View File

@@ -15,6 +15,8 @@
copy-form-source!
stamp-form-source!
form-location
set-form-type!
form-type
sex-error
sex-warning
with-directory

13
utils.scm
View File

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