From aa5cfc1b7d680989f37395ccd7f699c2d14a32ca Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 29 Sep 2026 16:09:51 +0300 Subject: [PATCH 01/17] remove capture list from lambdas, they are always pure Explicitly rename capturing lambdas to closures, they will be implemented later --- example/lambdas.sex | 29 +++++++++++++---------------- semen.scm | 8 +++----- tests/sex-programs/lambdas.sex | 8 ++++---- 3 files changed, 20 insertions(+), 25 deletions(-) diff --git a/example/lambdas.sex b/example/lambdas.sex index 48eb54a..676eef2 100644 --- a/example/lambdas.sex +++ b/example/lambdas.sex @@ -10,12 +10,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 +24,25 @@ (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)))))) + ;; Not supported yet -- captures belong to `closure' now, see + ;; Function-values.org + ;; (fn make-adder ((a int)) (closure ((int)) int) + ;; (return (closure ((b int)) int (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)) diff --git a/semen.scm b/semen.scm index 4262fa1..0872ff5 100644 --- a/semen.scm +++ b/semen.scm @@ -242,7 +242,7 @@ (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) + (append (lift-lambda lambda-name form) (hash-table-ref env :lambda-aux-code))) (set! (hash-table-ref env :lambda-counter) (+ (hash-table-ref env :lambda-counter) 1)) @@ -253,11 +253,9 @@ (string->symbol (fmt #f "__lambda_" 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)))) diff --git a/tests/sex-programs/lambdas.sex b/tests/sex-programs/lambdas.sex index 8de9a5d..0c67de7 100644 --- a/tests/sex-programs/lambdas.sex +++ b/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)) -- 2.52.0 From 1084b7d266e4c6c278d7f08469010fce545bdf4d Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 29 Sep 2026 21:05:52 +0300 Subject: [PATCH 02/17] add static-assert to sex Expands to C11 _Static_assert keyword --- fmt-c-writer.scm | 1 + tests/codegen.scm | 13 ++++++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index c881ae0..570ec0d 100644 --- a/fmt-c-writer.scm +++ b/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 diff --git a/tests/codegen.scm b/tests/codegen.scm index 2b94fe4..f43a255 100644 --- a/tests/codegen.scm +++ b/tests/codegen.scm @@ -259,4 +259,15 @@ 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 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("))))) -- 2.52.0 From 8a3f51e83353bfa5d21a7473716d9bcf383e17c1 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 29 Sep 2026 21:07:16 +0300 Subject: [PATCH 03/17] implement closures --- Makefile | 2 +- example/lambdas.sex | 18 +- semen.scm | 399 ++++++++++++++++++++++++++++++-- sexc.scm | 25 +- tests/codegen.scm | 57 ++++- tests/modules/Makefile | 7 +- tests/modules/greet-app.sex | 7 + tests/modules/greet.sex | 13 ++ tests/sex-programs/closures.sex | 80 +++++++ tests/sex-programs/fixpoint.sex | 55 +++++ 10 files changed, 622 insertions(+), 41 deletions(-) create mode 100644 tests/sex-programs/closures.sex create mode 100644 tests/sex-programs/fixpoint.sex diff --git a/Makefile b/Makefile index 56e9a9f..759bb42 100644 --- a/Makefile +++ b/Makefile @@ -94,7 +94,7 @@ 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 # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/example/lambdas.sex b/example/lambdas.sex index 676eef2..25e337f 100644 --- a/example/lambdas.sex +++ b/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) @@ -36,13 +42,7 @@ (return (+ 600 (l-2 a))))) (printf "Calling nested lambdas: %d\n" (l-1 6)) - ;; Not supported yet -- captures belong to `closure' now, see - ;; Function-values.org - ;; (fn make-adder ((a int)) (closure ((int)) int) - ;; (return (closure ((b int)) int (a) - ;; (return (+ a b))))) - ;; - ;; (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)) + (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)) diff --git a/semen.scm b/semen.scm index 0872ff5..7c79852 100644 --- a/semen.scm +++ b/semen.scm @@ -17,6 +17,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,8 +38,18 @@ (macroexpand (car forms) (cdr forms)) acc)) (else - (process-rec (cdr forms) - (match-sex-form (car forms) acc))))) + ;; 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 + (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, @@ -225,7 +236,7 @@ (extract-fn-docstring (strip-fn-header-comments sex-fn-raw)))) (let* ((expanded (macro-expand sex-fn)) (env (make-hash-table)) - (processed + (lifted (walk-form expanded fn-walker @@ -233,25 +244,133 @@ (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)))) + (set! (hash-table-ref env :var-types) + (declared-types (sex-fn-arglist expanded))) + env))) + (processed (rewrite-closure-calls-in-body lifted env))) (with-docstring doc processed (append (hash-table-ref env :lambda-aux-code) acc))))) +(define (declared-types arglist) + (let ((types (make-hash-table))) + (for-each (lambda (param) + (when (and (pair? param) (pair? (cdr param))) + (hash-table-set! types (first param) (second param)))) + arglist) + types)) + +(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)))) + (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 (lift-lambda 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) - form)) + (let ((head (car form))) + (cond + ((eq? 'lambda head) + (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) + (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)))) + (copy-form-source! + form + (if type + `(,(register-closure-call! type form) + ,(rewrite (car form)) + ,@(map rewrite (cdr form))) + (map rewrite form)))))) + +;;; 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) + ((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. +(define (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) + (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))))) + ((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))))) + +(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 (lift-lambda name form) (match form @@ -260,13 +379,255 @@ (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-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. +(define (resolve-closure-types form) + (cond + ((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-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))) + +;;; 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. +(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))) + (unless type + (sex-error form "closure captures an undeclared name" capture)) + (list capture type))) + +(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)) @@ -280,7 +641,9 @@ ((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 + (cons (resolve-closure-types sex-var) acc)) ;;; Utils (define (non-empty-list? form) diff --git a/sexc.scm b/sexc.scm index 3bb54ae..ac612a0 100644 --- a/sexc.scm +++ b/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)) diff --git a/tests/codegen.scm b/tests/codegen.scm index f43a255..d103dd4 100644 --- a/tests/codegen.scm +++ b/tests/codegen.scm @@ -270,4 +270,59 @@ compiles." "_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("))))) + "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 {"))) + ;; 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)")))) diff --git a/tests/modules/Makefile b/tests/modules/Makefile index bd1e966..5ff1468 100644 --- a/tests/modules/Makefile +++ 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 diff --git a/tests/modules/greet-app.sex b/tests/modules/greet-app.sex index 6229e91..5903f81 100644 --- a/tests/modules/greet-app.sex +++ b/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)) diff --git a/tests/modules/greet.sex b/tests/modules/greet.sex index 50c1aa0..43da31e 100644 --- a/tests/modules/greet.sex +++ b/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")) diff --git a/tests/sex-programs/closures.sex b/tests/sex-programs/closures.sex new file mode 100644 index 0000000..815d8c9 --- /dev/null +++ b/tests/sex-programs/closures.sex @@ -0,0 +1,80 @@ +(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" + "Nested: 33") +(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 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 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)) + (return 0)) diff --git a/tests/sex-programs/fixpoint.sex b/tests/sex-programs/fixpoint.sex new file mode 100644 index 0000000..84d8f4f --- /dev/null +++ b/tests/sex-programs/fixpoint.sex @@ -0,0 +1,55 @@ +(input) +(output "direct: 120" + "fac: 120 3628800" + "fib: 55 6765") +(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)) + (return 0)) -- 2.52.0 From d3f05cecaedaffd6ccee6aa601a5257e83ac6763 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 29 Sep 2026 21:37:18 +0300 Subject: [PATCH 04/17] fix (. (* p) x) expanding to *(p).x Was an fmt-c-writer bug: unary-op must parenthize itself, and not it's arg --- sex-fmt-c.scm | 17 ++++++++++++++++- tests/codegen.scm | 22 +++++++++++++++++++++- 2 files changed, 37 insertions(+), 2 deletions(-) diff --git a/sex-fmt-c.scm b/sex-fmt-c.scm index 8d78d58..fd05daf 100644 --- a/sex-fmt-c.scm +++ b/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 diff --git a/tests/codegen.scm b/tests/codegen.scm index d103dd4..e6860b6 100644 --- a/tests/codegen.scm +++ b/tests/codegen.scm @@ -325,4 +325,24 @@ compiles." (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)")))) + "g(c)"))) + + ;; 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")))) -- 2.52.0 From cd3016b6b8faa904a48a2d22840db311f3475300 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 29 Sep 2026 21:38:36 +0300 Subject: [PATCH 05/17] =?UTF-8?q?fix=20(=C2=A4=20int=20N)=20expanding=20to?= =?UTF-8?q?=20int=20N=20a[]?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Now only C type keywords will stay as a part of type, i.e. (¤ unsigned int) -> unsigned int a[] was and is okay --- fmt-c-writer.scm | 23 ++++++++++++++++++++++- tests/codegen.scm | 21 ++++++++++++++++++++- 2 files changed, 42 insertions(+), 2 deletions(-) diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 570ec0d..4ca7c43 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -292,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 @@ -302,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)) diff --git a/tests/codegen.scm b/tests/codegen.scm index e6860b6..4124dbd 100644 --- a/tests/codegen.scm +++ b/tests/codegen.scm @@ -345,4 +345,23 @@ compiles." (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")))) + (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[]")))) -- 2.52.0 From 6f54bfbe0843f0f525a731525e1dbb9dc8312005 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 29 Sep 2026 23:48:32 +0300 Subject: [PATCH 06/17] restore type inference layer 0 The type IR, unification with the unknown type, constraints and schemes, built and tested on its own. Nothing calls it yet. --- Makefile | 9 +- infer.module.scm | 44 +++ infer.scm | 642 +++++++++++++++++++++++++++++++++++++++++ tests/Makefile | 11 +- tests/infer.module.scm | 44 +++ tests/infer.scm | 309 ++++++++++++++++++++ tests/run.scm | 1 + utils.module.scm | 1 + utils.scm | 11 + 9 files changed, 1065 insertions(+), 7 deletions(-) create mode 100644 infer.module.scm create mode 100644 infer.scm create mode 100644 tests/infer.module.scm create mode 100644 tests/infer.scm diff --git a/Makefile b/Makefile index 759bb42..648e004 100644 --- a/Makefile +++ b/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 @@ -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: diff --git a/infer.module.scm b/infer.module.scm new file mode 100644 index 0000000..f53f1f3 --- /dev/null +++ b/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") diff --git a/infer.scm b/infer.scm new file mode 100644 index 0000000..64b19d5 --- /dev/null +++ b/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 + (%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 + (make-prim name quals) + prim-type? + (name prim-name) + (quals prim-quals)) + +(define-record-type + (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 + (make-array-type elt size) + array-type? + (elt array-elt) + (size array-size)) + +(define-record-type + (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 + (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 + (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 + (%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 + (%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 + (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)))) diff --git a/tests/Makefile b/tests/Makefile index 7297715..0cc5af4 100644 --- a/tests/Makefile +++ b/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 @@ -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) diff --git a/tests/infer.module.scm b/tests/infer.module.scm new file mode 100644 index 0000000..5cf5645 --- /dev/null +++ b/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") diff --git a/tests/infer.scm b/tests/infer.scm new file mode 100644 index 0000000..587fe1e --- /dev/null +++ b/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 Date: Tue, 29 Sep 2026 23:51:41 +0300 Subject: [PATCH 07/17] mark multi-form macro expansions with $ A bare list was read as several forms, so a macro returning `((make-adder 10) 5)' -- a call of what make-adder returns -- was spliced into two. Add a new $ char to denote splicing, so ($ form ...) splices. --- Readme.org | 14 ++++++++++++++ semen.scm | 27 +++++++++++++++++---------- tests/codegen.scm | 31 +++++++++++++++++++++++++++++++ 3 files changed, 62 insertions(+), 10 deletions(-) diff --git a/Readme.org b/Readme.org index 622d6ab..57d7e66 100644 --- a/Readme.org +++ b/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 diff --git a/semen.scm b/semen.scm index 7c79852..e8ae7b2 100644 --- a/semen.scm +++ b/semen.scm @@ -52,22 +52,29 @@ (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 diff --git a/tests/codegen.scm b/tests/codegen.scm index 4124dbd..e20ee7a 100644 --- a/tests/codegen.scm +++ b/tests/codegen.scm @@ -327,6 +327,37 @@ compiles." (fn f ((c (closure ((int)) int))) int (return (g c)))" "g(c)"))) + ;; `(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;"))) + ;; 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" -- 2.52.0 From 1f445f0f9b9a4985c86474295a82c60738d164ab Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 29 Sep 2026 23:52:08 +0300 Subject: [PATCH 08/17] implement type inference 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. --- Makefile | 7 +- semen.scm | 534 ++++++++++++++++++++++++++----- sex-macros.scm | 7 +- tests/Makefile | 4 +- tests/codegen.scm | 215 ++++++++++++- tests/sex-programs/closures.sex | 43 ++- tests/sex-programs/fixpoint.sex | 8 +- tests/sex-programs/inference.sex | 178 +++++++++++ tests/sex-programs/wildcards.sex | 83 +++++ tests/types.module.scm | 7 + tests/types.scm | 48 ++- types.module.scm | 7 + types.scm | 70 +++- utils.module.scm | 2 + utils.scm | 13 + 15 files changed, 1126 insertions(+), 100 deletions(-) create mode 100644 tests/sex-programs/inference.sex create mode 100644 tests/sex-programs/wildcards.sex diff --git a/Makefile b/Makefile index 648e004..5be8aa2 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/semen.scm b/semen.scm index e8ae7b2..c9459d2 100644 --- a/semen.scm +++ b/semen.scm @@ -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))) - (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 (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))) - (cond - ((eq? 'lambda head) - (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)))) +;;; 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. - ((eq? 'closure head) - (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)))))) +(define (declare-name! env name type) + (hash-table-set! (car (hash-table-ref env :scopes)) name type)) - ;; 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) +(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)))))) - (else form)))) +(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))) -(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))))) +;;; 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 (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)))) +(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 - (if type - `(,(register-closure-call! type form) - ,(rewrite (car form)) - ,@(map rewrite (cdr form))) - (map rewrite 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))) - (unless type - (sex-error form "closure captures an undeclared name" capture)) - (list capture type))) + (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 @@ -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) diff --git a/sex-macros.scm b/sex-macros.scm index ade2ce0..350bddb 100644 --- a/sex-macros.scm +++ b/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) diff --git a/tests/Makefile b/tests/Makefile index 0cc5af4..ab046d8 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -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 diff --git a/tests/codegen.scm b/tests/codegen.scm index e20ee7a..51b0a48 100644 --- a/tests/codegen.scm +++ b/tests/codegen.scm @@ -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)'. diff --git a/tests/sex-programs/closures.sex b/tests/sex-programs/closures.sex index 815d8c9..d5d3e06 100644 --- a/tests/sex-programs/closures.sex +++ b/tests/sex-programs/closures.sex @@ -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)) diff --git a/tests/sex-programs/fixpoint.sex b/tests/sex-programs/fixpoint.sex index 84d8f4f..9d62771 100644 --- a/tests/sex-programs/fixpoint.sex +++ b/tests/sex-programs/fixpoint.sex @@ -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)) diff --git a/tests/sex-programs/inference.sex b/tests/sex-programs/inference.sex new file mode 100644 index 0000000..4dfbfb6 --- /dev/null +++ b/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" + "" + "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 "\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. diff --git a/tests/sex-programs/wildcards.sex b/tests/sex-programs/wildcards.sex new file mode 100644 index 0000000..2fe4c8b --- /dev/null +++ b/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)) diff --git a/tests/types.module.scm b/tests/types.module.scm index c262cd7..cbce298 100644 --- a/tests/types.module.scm +++ b/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 diff --git a/tests/types.scm b/tests/types.scm index 94ce626..ec17c68 100644 --- a/tests/types.scm +++ b/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))) diff --git a/types.module.scm b/types.module.scm index afdb80f..742bfea 100644 --- a/types.module.scm +++ b/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 diff --git a/types.scm b/types.scm index 700146c..0a0ad22 100644 --- a/types.scm +++ b/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 diff --git a/utils.module.scm b/utils.module.scm index 940ba16..79ec527 100644 --- a/utils.module.scm +++ b/utils.module.scm @@ -15,6 +15,8 @@ copy-form-source! stamp-form-source! form-location + set-form-type! + form-type sex-error sex-warning with-directory diff --git a/utils.scm b/utils.scm index d007648..ee0a3a1 100644 --- a/utils.scm +++ b/utils.scm @@ -101,6 +101,19 @@ ;;; The file `parse-all' is currently reading. Bound by the reader (define current-source-file (make-parameter "")) +;;; 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))) -- 2.52.0 From 9daaa42d6aae3160ce4ea2e138570e0d2c09f68d Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 29 Sep 2026 23:52:08 +0300 Subject: [PATCH 09/17] ignore the attic directory --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index d588d9c..db46251 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,6 @@ sexc sex-tests sextest tools/sextest/sextest + +# Scrapped design docs, kept for reference +/attic -- 2.52.0 From 2b73fcf1c4838247082bc87e7386d2e87e0f9f9d Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 30 Sep 2026 12:54:21 +0300 Subject: [PATCH 10/17] answer where a written type ends in one place An arglist entry, an array's bound and its element type ask one question, and disagreed: `(unsigned int)' was a name plus a type, a trailing typedef a bound, a subscript the type's second word. --- Makefile | 6 +-- fmt-c-writer.scm | 48 ++----------------- semen.scm | 7 +-- tests/Makefile | 4 +- tests/sex-programs/type-shapes.sex | 72 +++++++++++++++++++++++++++++ tests/types.module.scm | 8 +++- types.module.scm | 8 +++- types.scm | 74 ++++++++++++++++++++++++++++++ 8 files changed, 173 insertions(+), 54 deletions(-) create mode 100644 tests/sex-programs/type-shapes.sex diff --git a/Makefile b/Makefile index 5be8aa2..04094b6 100644 --- a/Makefile +++ b/Makefile @@ -81,8 +81,8 @@ semen.o: semen.module.scm semen.scm infer.o sex-macros.o sex-modules.o types.o u sex-fmt-c.o: sex-fmt-c.scm $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c -fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o - $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils +fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o types.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,types,utils sexc.o: sexc.module.scm infer.o types.o sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,infer,types,utils @@ -98,7 +98,7 @@ sextest: SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \ feature-flags lambdas compound-literals closures fixpoint \ - wildcards inference + wildcards inference type-shapes # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 4ca7c43..da1f38f 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -13,6 +13,7 @@ (chicken irregex) ; unkebabify srfi-1 ; lists srfi-13 ; strings + types ; array-bound?, named-arg? utils) ;;; egg `tree' not ported to CHICKEN 6 yet @@ -292,27 +293,6 @@ forms, and what remains." (list) (walk-expr (drop form 3)))))) ; optional init expression -;;; `(¤ int N)' is N of int -;;; `(¤ unsigned int)' is an unsized array of unsigned int -;;; An aggregate is the exception -- `(¤ struct point)' ends in a tag, -;;; which is part of the type and not a bound. - -(define +c-type-words+ - '(void char short int long float double signed unsigned - bool _Bool complex _Complex _Atomic const volatile restrict)) - -(define (array-bound? array-type) - (and (> (length array-type) 1) - (let ((bound (last array-type)) - (preceding (last (drop-right array-type 1)))) - (cond - ((not (symbol? bound)) #t) - ((memq bound +c-type-words+) #f) - ;; a tag always follows its keyword, so `(¤ * struct tt)' ends - ;; in a name belonging to the type - ((memq preceding '(struct union enum)) #f) - (else #t))))) - (define (walk-type form) ;; int -> int ;; (const int) -> const int @@ -323,16 +303,11 @@ forms, and what remains." ;; (fn ((int) (float)) void) -> (%fun void ((int) (float))) (match form (('¤ . array-type) - (if (array-bound? array-type) - ;; sized array - (let* ((type-list (drop-right array-type 1)) - (type (maybe-unwrap-type type-list)) - (size (last array-type))) - `(%array ,(walk-type type) - ,size)) + (if (array-bound? form) + `(%array ,(walk-type (array-element-type form)) ,(last array-type)) ;; sugar for pointer... Do we really need it? Guess why not, ;; it's a strong semantic cue - `(%array ,(walk-type (maybe-unwrap-type array-type))))) + `(%array ,(walk-type (array-element-type form))))) (('fn arglist ret-type) `(%fun ,(walk-type ret-type) ,(walk-arg-types arglist))) (('fn . _) @@ -398,21 +373,6 @@ forms, and what remains." . ,(walk-body maybe-body))))) -;;; TODO: isn't there a better way? -(define (is-probably-type form) - (case (car form) - ((¤ * const volatile struct union) #t) - (else #f))) - -;;; Does the parameter name itself? -;;; (f1 float) does -;;; (float), (const char) and (¤ float 4) do not -(define (named-arg? arg) - (and (pair? arg) - (pair? (cdr arg)) ; 1 element args are always type - (not (eq? (car arg) '¤)) - (not (is-probably-type arg)))) - ;;; The type of one parameter (define (arg-type arg) (if (named-arg? arg) diff --git a/semen.scm b/semen.scm index c9459d2..23081ed 100644 --- a/semen.scm +++ b/semen.scm @@ -276,7 +276,7 @@ ;;; through untouched. (define (fn-type-of fn-form) `(fn ,(map (lambda (param) - (if (and (pair? param) (= 2 (length param))) + (if (and (pair? param) (= 2 (length param)) (named-arg? param)) (list (second param)) param)) (sex-fn-arglist fn-form)) @@ -550,9 +550,10 @@ (and (symbol? (car expr)) (get-return-type (car expr)))) (else (case (car expr) + ;; subscripting an array gives its element type, and a pointer + ;; subscripts the same way ((¤) (let ((base (expression-type (second expr) env))) - (and (list? base) (>= (length base) 2) (eq? '¤ (car base)) - (second base)))) + (or (array-element-type base) (pointer-target base)))) ((&) (and (= 2 (length expr)) (let ((target (expression-type (second expr) env))) (and target `(* ,target))))) diff --git a/tests/Makefile b/tests/Makefile index ab046d8..deae867 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -38,8 +38,8 @@ semen.o: semen.module.scm ../semen.scm infer.o sex-macros.o sex-modules.o types. sex-fmt-c.o: ../sex-fmt-c.scm $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) ../sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c -fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o utils.o - $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils +fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o types.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,types,utils sexc.o: sexc.module.scm infer.o types.o ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,infer,types,utils diff --git a/tests/sex-programs/type-shapes.sex b/tests/sex-programs/type-shapes.sex new file mode 100644 index 0000000..56a99df --- /dev/null +++ b/tests/sex-programs/type-shapes.sex @@ -0,0 +1,72 @@ +(input) +(output "aggregate element: 3 4" + "pointer element: there" + "multi-word element: 9" + "through a pointer: 55" + "unsized of a typedef: 1 2" + "unsized of a pointer: 5" + "unnamed parameters: 7 -1 2") +(return 0) + +;;; Three questions about a written type that used to be answered in +;;; three places and disagreed: is `(a b)' a named parameter or a bare +;;; type, is the last element of a `¤' its bound or the last word of +;;; its element type, and what is one element of an array. +;;; +;;; They are one question -- where does the type end -- so the answer +;;; lives in `types' and everything else asks it. + +(include stdio.h) + +(struct point ((x int) (y int))) + +(typedef small int) + +;;; a parameter that names nothing is a type, however many words it +;;; takes: `(unsigned int)' is one of them, not a `unsigned' called +;;; `int' +(fn width ((n unsigned int)) int + (return (cast n int))) + +(fn sign ((c const char)) int + (if (== c #\a) (return -1)) + (return 1)) + +(fn twice ((n small)) int + (return (* n 2))) + +(pub fn main () int + ;; an element keeps every word of its type, tag and all + (var pts (¤ (struct point) 2) #(#((struct point) : 1 2) + #((struct point) : 3 4))) + (var p _ (¤ pts 1)) + (printf "aggregate element: %d %d\n" (. p x) (. p y)) + + (var names (¤ (* const char) 2) #("hi" "there")) + (var s _ (¤ names 1)) + (printf "pointer element: %s\n" s) + + (var nums (¤ unsigned int 3) #(7 8 9)) + (var u _ (¤ nums 2)) + (printf "multi-word element: %u\n" u) + + ;; subscripting a pointer answers the same as subscripting an array + (var q (* (struct point)) (& (¤ pts 0))) + (var r _ (¤ q 1)) + (printf "through a pointer: %d\n" (+ (. r x) (* 13 (. r y)))) + + ;; the last word of an unsized array's type is not its bound: neither + ;; a typedef name nor the target of a `*' can be one + (var tail (¤ const small) #(1 2)) + (printf "unsized of a typedef: %d %d\n" (¤ tail 0) (¤ tail 1)) + + (var one size-t 5) + (var sizes (¤ * size-t) #((& one))) + (var w _ (¤ sizes 0)) + (printf "unsized of a pointer: %d\n" (cast (* w) int)) + + ;; the same question in type position: `(fn ((unsigned int)) int)' + ;; takes one parameter, not two + (var fp (fn ((unsigned int)) int) width) + (printf "unnamed parameters: %d %d %d\n" (fp 7) (sign #\a) (twice 1)) + (return 0)) diff --git a/tests/types.module.scm b/tests/types.module.scm index cbce298..cf06139 100644 --- a/tests/types.module.scm +++ b/tests/types.module.scm @@ -18,5 +18,11 @@ get-type-info get-tag-info get-fields - get-underlying-type) + get-underlying-type + + type-head? + named-arg? + typedef-name? + array-bound? + array-element-type) "../types.scm") diff --git a/types.module.scm b/types.module.scm index 742bfea..ed00b5c 100644 --- a/types.module.scm +++ b/types.module.scm @@ -18,5 +18,11 @@ get-type-info get-tag-info get-fields - get-underlying-type) + get-underlying-type + + type-head? + named-arg? + typedef-name? + array-bound? + array-element-type) "types.scm") diff --git a/types.scm b/types.scm index 0a0ad22..2f8e937 100644 --- a/types.scm +++ b/types.scm @@ -237,3 +237,77 @@ (map (lambda (value) (fn value type)) (caddr info)))) (else #f))))) + +;;; The shape of a written type +;;; +;;; Three places have to tell a type from something that merely +;;; contains one: an arglist entry is either `(name type)' or a bare +;;; type, and an array's last element is either a bound or the last +;;; word of its element type. They used to answer it separately, and +;;; disagreed. + +;;; A qualifier can never end a type, which is what tells `(¤ const t)' +;;; -- an unsized array of `t' -- from `(¤ int 4)'. +(define +c-qualifiers+ '(const volatile restrict _Atomic)) + +(define +c-specifiers+ + '(void char short int long float double signed unsigned + bool _Bool complex _Complex)) + +;;; Does this list start a type rather than name one? `(const char)' +;;; and `(unsigned int)' are types; `(f1 float)' is a named parameter. +(define (type-head? form) + (and (pair? form) + (symbol? (car form)) + (or (memq (car form) '(* ¤ struct union enum)) + (memq (car form) +c-qualifiers+) + (memq (car form) +c-specifiers+)))) + +;;; Does the parameter name itself? +;;; (f1 float) does +;;; (float), (const char), (unsigned int) and (¤ float 4) do not +(define (named-arg? arg) + (and (pair? arg) + (pair? (cdr arg)) ; 1 element args are always type + (not (type-head? arg)))) + +;;; Is NAME a typedef, as opposed to a `define'd constant? Both live in +;;; the same table, and only the first is part of a type. +(define (typedef-name? name) + (let ((info (and (symbol? name) (get-type-info name)))) + (and info (memq (car info) '(typedef struct union enum)) #t))) + +;;; `(¤ int N)' is N of int +;;; `(¤ unsigned int)' is an unsized array of unsigned int +;;; +;;; The last element is a bound only if what precedes it is already a +;;; complete type, so `(¤ const mytype)' and `(¤ * size-t)' end in the +;;; last word of their element type and not in a bound. A type is +;;; complete when it ends in a specifier, in a tag following its +;;; keyword, or in a typedef we have seen declared. +;;; +;;; TYPE is the whole `(¤ ...)' form. +(define (array-bound? type) + (and (> (length type) 2) + (let ((bound (last type)) + (preceding (last (drop-right type 1)))) + (cond + ((not (symbol? bound)) #t) + ((or (memq bound +c-specifiers+) (memq bound +c-qualifiers+)) #f) + ((memq preceding +c-specifiers+) #t) + ;; a tag always follows its keyword, so `(¤ * struct tt)' ends + ;; in a name belonging to the type + ((memq preceding '(struct union enum)) #f) + (else (typedef-name? preceding)))))) + +;;; What one element of a written array type is: +;;; (¤ struct point 2) -> (struct point), (¤ * const char 2) -> (* const char) +(define (array-element-type type) + (and (pair? type) + (eq? '¤ (car type)) + (pair? (cdr type)) + (let ((words (if (array-bound? type) + (drop-right (cdr type) 1) + (cdr type)))) + (and (pair? words) + (if (null? (cdr words)) (car words) words))))) -- 2.52.0 From 2da5b5005b86e23a7bc1beb8b2dd8e15996dd61a Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 30 Sep 2026 13:22:07 +0300 Subject: [PATCH 11/17] give fmt-c a name for every parameter fmt-c takes a parameter's name with `cadr', so an unnamed one handed over bare lost its second word to it: `(* const char)' dropped its star, and `(int)' had no second word at all. --- Makefile | 2 +- fmt-c-writer.scm | 17 ++++----- tests/fmt-c-writer.scm | 10 +++--- tests/sex-programs/unnamed-params.sex | 51 +++++++++++++++++++++++++++ 4 files changed, 66 insertions(+), 14 deletions(-) create mode 100644 tests/sex-programs/unnamed-params.sex diff --git a/Makefile b/Makefile index 04094b6..3b4a8f4 100644 --- a/Makefile +++ b/Makefile @@ -98,7 +98,7 @@ sextest: SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \ feature-flags lambdas compound-literals closures fixpoint \ - wildcards inference type-shapes + wildcards inference type-shapes unnamed-params # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index da1f38f..53cbe05 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -378,20 +378,21 @@ forms, and what remains." (if (named-arg? arg) (walk-type (maybe-unwrap-type (cdr arg))) ;; A lone type may arrive wrapped in parens of its own, and those - ;; are not part of it: ((* const char)) - ;; Plain names e.g. (int) are left as is - (walk-type (if (and (pair? arg) (null? (cdr arg)) (pair? (car arg))) - (car arg) - arg)))) + ;; are not part of it: ((* const char)), (int) + (walk-type (maybe-unwrap-type arg)))) +;;; A parameter reaches fmt-c as `(type name)' and nothing else: it +;;; reads the name out with `cadr', so a nameless one is the type and +;;; an explicit #f. Handing it the bare type instead made it read the +;;; type's own second word as the name -- `(* const char)' lost its +;;; star -- and a one-word type had no second word to read at all. (define (walk-arglist form) ;; E.g.: ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32)) ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4))) (map (lambda (arg) - (if (named-arg? arg) - (list (arg-type arg) (walk-type (car arg))) - (arg-type arg))) + (list (arg-type arg) + (and (named-arg? arg) (walk-type (car arg))))) (remove comment-form? form))) (define (walk-arg-types form) diff --git a/tests/fmt-c-writer.scm b/tests/fmt-c-writer.scm index 9cf76c9..152662a 100644 --- a/tests/fmt-c-writer.scm +++ b/tests/fmt-c-writer.scm @@ -40,15 +40,15 @@ (walk-type '(const * const char))) (test - '(%fun void ((int) (float) (%array (struct what * const)))) + '(%fun void (int float (%array (struct what * const)))) (walk-type '(fn ((int) (float) (¤ (const * struct what))) void))) (test - '(%fun void ((int) (%array float) (%array (struct what * const)))) + '(%fun void (int (%array float) (%array (struct what * const)))) (walk-type '(fn ((int) (¤ float) (¤ (const * struct what))) void))) (test - '(%array (%fun void ((int) (%array float) (%array (struct what * const))))) + '(%array (%fun void (int (%array float) (%array (struct what * const))))) (walk-type '(¤ (fn ((int) (¤ float) (¤ (const * struct what))) void)))) ;; Type convert to C @@ -136,7 +136,7 @@ ;;; Fn defs (test - '(%fun void puk ((int) (%array float 8))) + '(%fun void puk ((int #f) ((%array float 8) #f))) (walk-fn-def '(fn puk ((int) (¤ float 8)) void))) (test @@ -183,7 +183,7 @@ (test '(struct mega_kebab ((int a) ((struct ((int year) (int month) (int day))) dob) - ((%fun bool ((int) (%array int))) min))) + ((%fun bool (int (%array int))) min))) (walk-struct '(struct mega-kebab ((a int) (dob (struct ((year int) diff --git a/tests/sex-programs/unnamed-params.sex b/tests/sex-programs/unnamed-params.sex new file mode 100644 index 0000000..34e1940 --- /dev/null +++ b/tests/sex-programs/unnamed-params.sex @@ -0,0 +1,51 @@ +(input) +(output "one word: 7" + "pointer: 2" + "aggregate: 3" + "array: 2.5" + "variadic: 1 two") +(return 0) + +;;; A parameter that names nothing still has to reach the C writer as a +;;; type and a name, the name being absent. Handed the bare type +;;; instead, fmt-c read the type's own second word as the name -- so +;;; `(* const char)' came out `const char', which is a different +;;; function -- and a one-word type had no second word to read at all. + +(include stdio.h) +(include stdarg.h) + +(struct point ((x int) (y int))) + +;;; declared here rather than included, so the prototype we emit is the +;;; one the C compiler checks the call against +(extern fn abs ((int)) int) +(extern fn strlen ((* const char)) size-t) + +(fn origin-x ((p (* (struct point)))) int + (return (. (* p) x))) + +(fn second-of ((xs (¤ float 4))) float + (return (¤ xs 1))) + +(fn say ((fmt (* const char)) ...) void + (var ap va-list) + (va-start ap fmt) + (vprintf fmt ap) + (va-end ap)) + +(pub fn main () int + (printf "one word: %d\n" (abs -7)) + (printf "pointer: %d\n" (cast (strlen "hi") int)) + + ;; the same parameter lists written as types + (var p (struct point) #((struct point) : 3 4)) + (var f (fn ((* (struct point))) int) origin-x) + (printf "aggregate: %d\n" (f (& p))) + + (var xs (¤ float 4) #(1.5 2.5 3.5 4.5)) + (var g (fn ((¤ float 4)) float) second-of) + (printf "array: %g\n" (g xs)) + + (say "variadic: %d %s\n" 1 "two") + (return 0)) -- 2.52.0 From 578feb6b73e1dee18ce5f9e3bc2ad14ddc74a948 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 30 Sep 2026 14:13:19 +0300 Subject: [PATCH 12/17] scope and promote the way C does A `while' or `switch' body is a block with no `do' around it, and its declarations landed in the enclosing frame. Two operands of one narrow type skipped the conversions, so `(+ c c)' answered `char'. --- semen.scm | 29 +++++++++++++++++++++++------ tests/sex-programs/wildcards.sex | 28 +++++++++++++++++++++++++++- 2 files changed, 50 insertions(+), 7 deletions(-) diff --git a/semen.scm b/semen.scm index 23081ed..9ddbaf7 100644 --- a/semen.scm +++ b/semen.scm @@ -295,8 +295,13 @@ ;;; The scope chain ;;; ;;; `(do (var c int 9) ...)' declares a `c' that ends with the block, so -;;; a closure-typed `c' outside it is still a closure after it. `do' and -;;; `for' each open a frame; innermost first. +;;; a closure-typed `c' outside it is still a closure after it. Every +;;; form whose body C brackets opens a frame; innermost first. +;;; +;;; One frame per form is enough, rather than one per arm: a `case' label +;;; opens no scope in C either, and a declaration is not a statement, so +;;; the only way to write one in an `if' arm is the `do' that already +;;; brings its own. (define (declare-name! env name type) (hash-table-set! (car (hash-table-ref env :scopes)) name type)) @@ -351,7 +356,8 @@ (cons walk-embed-result (walk-body expansion env))))) (else (case (car form) - ((do for) (with-scope env (lambda () (walk-parts form env)))) + ((do for while if switch) + (with-scope env (lambda () (walk-parts form env)))) ((lambda) (let ((name (aux-name! env make-lambda-name))) @@ -595,15 +601,26 @@ (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)))))) + ((< (conversion-rank l) (conversion-rank r)) (promoted right r)) + (else (promoted left l))))))) + +;;; Anything narrower than `int' is promoted to one before the +;;; arithmetic happens, so two `char's join as `int' and not as `char'. +;;; Operands of the same type reach here too, which is the whole point: +;;; `(+ c c)' is where the promotion is invisible and the truncation is +;;; not. `unsigned' alone is `unsigned int' and stays as written. +(define (promoted written type) + (if (and (prim-type? type) + (any (lambda (word) (memq word '(char short bool _Bool))) + (prim-name type))) + 'int + written)) ;;; `char' and `short' promote to `int', so the ranks start there (define (conversion-rank type) diff --git a/tests/sex-programs/wildcards.sex b/tests/sex-programs/wildcards.sex index 2fe4c8b..20b7752 100644 --- a/tests/sex-programs/wildcards.sex +++ b/tests/sex-programs/wildcards.sex @@ -6,8 +6,10 @@ "arrays: 30" "loop: 0 1 2" "shadowed: 9 then 42" + "still an int: 200" "partial: 1 2.5" "joined: 43.5 84 49 1" + "promoted: 200 60000 3705032704" "from elements: 4 9 0") (return 0) @@ -55,11 +57,24 @@ (printf " %d" i)) (printf "\n") - ;; a block's declarations end with it + ;; a block's declarations end with it, and so do the declarations of + ;; everything else C brackets -- a `while' body is a block with no + ;; `do' written around it (do (var n _ 9) (printf "shadowed: %d then " n)) (printf "%d\n" n) + (var wide int 200) + (while false (var wide char 1) (printf "%d" wide)) + (if false (do (var wide char 1) (printf "%d" wide))) + ;; a statement before the declaration: a label may not be followed by + ;; one until C23 + (switch a (case 1 (printf "") (var wide char 1) (printf "%d" wide) (break))) + ;; a copy, not a sum: an arithmetic result would be promoted to `int' + ;; whatever leaked, and say nothing + (var copy _ wide) + (printf "still an int: %d\n" copy) + ;; a wildcard inside a written type: only it is solved (var pp2 (* _) (& p)) (printf "partial: %d %g\n" (-> pp2 x) (-> pp2 y)) @@ -74,6 +89,17 @@ (var single _ (+ g g)) (printf "joined: %g %d %ld %g\n" mixed same wider single) + ;; ...including the promotions, which two operands of one narrow type + ;; are exactly where they show: `char' + `char' is an `int' + (var c1 char 100) + (var c2 char 100) + (var h1 short 30000) + (var narrow _ (+ c1 c2)) + (var narrower _ (+ h1 h1)) + (var kept (unsigned int) 4000000000) + (var unpromoted _ (+ kept kept)) + (printf "promoted: %d %d %u\n" narrow narrower unpromoted) + ;; a brace initializer has no type of its own, but its elements solve ;; the hole in the array type around it -- and the length stays as ;; written, whether or not every slot is initialized -- 2.52.0 From 024e97553b7deccc6fcdd7ba2f7231ba5186c9a7 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 30 Sep 2026 14:33:57 +0300 Subject: [PATCH 13/17] keep closure signatures apart when mangled The argument list was flattened with one separator throughout, so `((long long))' and `((long) (long))' named one struct. A capture borrowing a name looked only at the local scope chain. --- Makefile | 3 +- semen.scm | 22 ++++++++-- tests/sex-programs/closure-signatures.sex | 52 +++++++++++++++++++++++ 3 files changed, 72 insertions(+), 5 deletions(-) create mode 100644 tests/sex-programs/closure-signatures.sex diff --git a/Makefile b/Makefile index 3b4a8f4..664ff72 100644 --- a/Makefile +++ b/Makefile @@ -98,7 +98,8 @@ sextest: SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \ feature-flags lambdas compound-literals closures fixpoint \ - wildcards inference type-shapes unnamed-params + wildcards inference type-shapes unnamed-params \ + closure-signatures # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/semen.scm b/semen.scm index 9ddbaf7..c547e25 100644 --- a/semen.scm +++ b/semen.scm @@ -765,10 +765,24 @@ *pending-closure-structs*))))) (delete-duplicates (aggregates-in type)))) +;;; Where one argument ends and the next begins has to survive the +;;; flattening, or `((long long))' and `((long) (long))' mangle alike and +;;; the second signature silently reuses the first one's struct. Words +;;; within an argument keep the single separator; the arguments take a +;;; doubled one. +;;; +;;; Not proof against a type name that mangles to a trailing `_' of its +;;; own -- for that the arguments would have to carry their lengths, and +;;; the name in the C is worth more than the last of the ambiguity. +(define (mangle-arglist args) + (if (null? args) + "void" + (string-intersperse (map mangle-type args) "__"))) + (define (closure-struct-name type) ;; the glyph says `closure' already, so the tag is just the signature (string->symbol (string-append "ƛ" - (mangle-type (second type)) + (mangle-arglist (second type)) "_" (mangle-type (third type))))) @@ -937,9 +951,9 @@ (let ((name (capture-name capture))) (unless (symbol? name) (sex-error form "a closure capture needs a name" capture)) - (let ((type (if (pair? capture) - (expression-type (capture-argument capture) env) - (lookup-name env name)))) + ;; the same lookup either way: a capture that borrows a name can + ;; borrow a global's or a function's, not only a local's + (let ((type (expression-type (capture-argument capture) env))) (unless type (sex-error form "cannot infer what is captured as" name)) (list name type)))) diff --git a/tests/sex-programs/closure-signatures.sex b/tests/sex-programs/closure-signatures.sex new file mode 100644 index 0000000..494bcde --- /dev/null +++ b/tests/sex-programs/closure-signatures.sex @@ -0,0 +1,52 @@ +(input) +(output "one argument of two words: 7" + "two arguments of one: 7" + "unsigned, one argument: 9" + "unsigned, two arguments: 3" + "captured global: 12" + "captured function: 8") +(return 0) + +;;; A closure's struct is named after its signature, so that two +;;; translation units agree on it without sharing a header. The name is +;;; built by flattening the argument list, and flattening loses where one +;;; argument ends and the next begins: `((long long))' and +;;; `((long) (long))' are different signatures that used to mangle alike, +;;; and the second quietly reused the first one's struct. +;;; +;;; A capture that borrows a name reads it from wherever the name is +;;; declared, a global or a function included. + +(include stdio.h) + +(var scale int 3) + +(fn double-it ((n int)) int + (return (* n 2))) + +(pub fn main () int + (var one-wide (closure ((long long)) int) + (closure ((a (long long))) int () (return (cast a int)))) + (printf "one argument of two words: %d\n" (one-wide 7)) + + (var two-longs (closure ((long) (long)) int) + (closure ((a long) (b long)) int () (return (cast (+ a b) int)))) + (printf "two arguments of one: %d\n" (two-longs 3 4)) + + (var one-unsigned (closure ((unsigned int)) int) + (closure ((a (unsigned int))) int () (return (cast a int)))) + (printf "unsigned, one argument: %d\n" (one-unsigned 9)) + + (var two-unsigned (closure ((unsigned) (int)) int) + (closure ((a unsigned) (b int)) int () (return (+ (cast a int) b)))) + (printf "unsigned, two arguments: %d\n" (two-unsigned 1 2)) + + ;; a capture names what it borrows, and the name need not be a local + (var scaled (closure ((int)) int) + (closure ((x int)) int (scale) (return (* x scale)))) + (printf "captured global: %d\n" (scaled 4)) + + (var doubled (closure ((int)) int) + (closure ((x int)) int (double-it) (return (double-it x)))) + (printf "captured function: %d\n" (doubled 4)) + (return 0)) -- 2.52.0 From f5eee71eb7c7aca0097b9db33c0c443cec57dbce Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 30 Sep 2026 14:36:07 +0300 Subject: [PATCH 14/17] declare the closure environment in c99 `max_align_t' is C11 and the union goes into every unit, so a program with no closure in it stopped building under -std=c99. `unify' also bound a rigid variable one way round only. --- Makefile | 2 +- infer.scm | 10 ++++++---- semen.scm | 14 ++++++++++---- tests/infer.scm | 12 +++++++++++- tests/sex-programs/c99.sex | 28 ++++++++++++++++++++++++++++ 5 files changed, 56 insertions(+), 10 deletions(-) create mode 100644 tests/sex-programs/c99.sex diff --git a/Makefile b/Makefile index 664ff72..a769559 100644 --- a/Makefile +++ b/Makefile @@ -99,7 +99,7 @@ sextest: SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \ feature-flags lambdas compound-literals closures fixpoint \ wildcards inference type-shapes unnamed-params \ - closure-signatures + closure-signatures c99 # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/infer.scm b/infer.scm index 64b19d5..3ba37b0 100644 --- a/infer.scm +++ b/infer.scm @@ -509,10 +509,12 @@ ((eq? a b) #t) ((unknown-type? a) #t) ((unknown-type? b) #t) - ((and (tvar? a) (tvar? b) (tvar-rigid? b) (not (tvar-rigid? a))) - (bind-tvar! a b form)) - ((tvar? a) (bind-tvar! a b form)) - ((tvar? b) (bind-tvar! b a form)) + ;; Whichever side is free takes the binding, so that a rigid + ;; variable is solved *to* rather than solved, in either order. + ;; Both rigid and distinct is the mismatch `eq?' above let through. + ((and (tvar? a) (not (tvar-rigid? a))) (bind-tvar! a b form)) + ((and (tvar? b) (not (tvar-rigid? b))) (bind-tvar! b a form)) + ((or (tvar? a) (tvar? b)) (type-mismatch a b form)) ;; A typedef unifies as what it stands for. Its name survives in ;; whichever side is printed later, since neither side is rebuilt. ((alias-type? a) (unify (alias-expansion a) b form)) diff --git a/semen.scm b/semen.scm index c547e25..c47866f 100644 --- a/semen.scm +++ b/semen.scm @@ -693,13 +693,19 @@ (define +closure-env-bytes+ 16) -;;; +closure-env-bytes+ for maximum capacity, max-align-t for -;;; effectiveness, hence union +;;; +closure-env-bytes+ for maximum capacity, and an alignment wide +;;; enough for anything that fits in them, hence union. `max_align_t' +;;; would say that in one word, but it is C11 and the target is C99, so +;;; the widest built-ins say it instead: a union is aligned for the +;;; strictest of its members. (define +closure-env-type+ 'ƛenv) (define (closure-env-declaration) - `(union ,+closure-env-type+ ((align max-align-t) - (bytes (¤ char ,+closure-env-bytes+))))) + `(union ,+closure-env-type+ ((bytes (¤ char ,+closure-env-bytes+)) + (align-integer (long long)) + (align-real (long double)) + (align-pointer (* void)) + (align-code (fn ((* void)) void))))) (define +closure-structs+ (make-hash-table)) (define +closure-forwards+ (make-hash-table)) diff --git a/tests/infer.scm b/tests/infer.scm index 587fe1e..2d13c64 100644 --- a/tests/infer.scm +++ b/tests/infer.scm @@ -183,7 +183,17 @@ (test-assert "an ordinary variable binds to it instead" (unify a r #f)) ;; An unsolved variable resolves to itself. - (test-assert "it is still open" (tvar? (resolve r)))))) + (test-assert "it is still open" (tvar? (resolve r)))) + ;; ...and the same the other way round: it is which side is free + ;; that decides, not which side was written first. + (let ((r (fresh-rigid-tvar)) + (a (fresh-tvar))) + (test-assert "rigid first binds the free one" (unify r a #f)) + (test-assert "to the parameter itself" (eq? r (resolve a)))) + (let ((r1 (fresh-rigid-tvar)) + (r2 (fresh-rigid-tvar))) + (test-error "two parameters do not unify with each other" + (unify r1 r2 #f))))) (test-group "constraints" (test #t (entails? 'numeric (parse-type 'int))) diff --git a/tests/sex-programs/c99.sex b/tests/sex-programs/c99.sex new file mode 100644 index 0000000..f65cd37 --- /dev/null +++ b/tests/sex-programs/c99.sex @@ -0,0 +1,28 @@ +(compilation "-- -std=c99 -pedantic-errors") +(input) +(output "c99: 42") +(return 0) + +;;; The closure environment is part of the ABI, so its union is declared +;;; in every translation unit whether or not one is used. That put +;;; whatever it was written with into every program: `max_align_t' named +;;; the alignment in one word, and made C11 the floor for a program with +;;; no closure in it at all. +;;; +;;; The widest built-ins say the same thing -- a union is aligned for the +;;; strictest of its members -- and say it in C99. +;;; +;;; Closures themselves still want C11 for the `_Static_assert' that +;;; checks the captures fit, so this program keeps clear of them. + +(include stdio.h) + +(struct point ((x int) (y int))) + +(fn area ((p (struct point))) int + (return (* (. p x) (. p y)))) + +(pub fn main () int + (var p (struct point) #((struct point) : 6 7)) + (printf "c99: %d\n" (area p)) + (return 0)) -- 2.52.0 From e87463be87fdc1aa8254cdd1aa846e08a4039906 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 30 Sep 2026 23:12:52 +0300 Subject: [PATCH 15/17] type the operators the walk had no rule for `&&', the bitwise operators, the shifts and `++' each stopped with `cannot infer'; an array operand came back as the array; a rank tie went to whichever operand came first; and a toplevel `_' reached the writer unsolved. --- Makefile | 21 +++++++++--- infer.module.scm | 1 + semen.scm | 76 +++++++++++++++++++++++++++++++++++++----- tests/infer.module.scm | 1 + 4 files changed, 86 insertions(+), 13 deletions(-) diff --git a/Makefile b/Makefile index a769559..6cfb23f 100644 --- a/Makefile +++ b/Makefile @@ -96,10 +96,23 @@ sextest: $(MAKE) -C ./tools/sextest sextest cp ./tools/sextest/sextest . -SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \ - feature-flags lambdas compound-literals closures fixpoint \ - wildcards inference type-shapes unnamed-params \ - closure-signatures c99 +SEX_TEST_PROGRAMS = c99 \ + closure-signatures \ + closures \ + comments \ + compound-literals \ + feature-flags \ + features \ + fixpoint \ + hello-world \ + inference \ + lambdas \ + lists \ + serialize \ + type-shapes \ + unicode \ + unnamed-params \ + wildcards # Multi-module linking is checked end to end; see tests/modules/Makefile. check-modules: sexc diff --git a/infer.module.scm b/infer.module.scm index f53f1f3..dc9c3b3 100644 --- a/infer.module.scm +++ b/infer.module.scm @@ -17,6 +17,7 @@ resolve underlying + c-primitive? type-quals free-tvars decay diff --git a/semen.scm b/semen.scm index c47866f..8f545b4 100644 --- a/semen.scm +++ b/semen.scm @@ -560,9 +560,11 @@ ;; subscripts the same way ((¤) (let ((base (expression-type (second expr) env))) (or (array-element-type base) (pointer-target base)))) - ((&) (and (= 2 (length expr)) - (let ((target (expression-type (second expr) env))) - (and target `(* ,target))))) + ;; unary `&' takes an address; with two operands it is bitwise and + ((&) (if (= 2 (length expr)) + (let ((target (expression-type (second expr) env))) + (and target `(* ,target))) + (arithmetic-type expr env))) ;; unary `*' is a dereference; with two operands it is a product ((*) (if (= 2 (length expr)) (pointer-target (expression-type (second expr) env)) @@ -573,8 +575,17 @@ (cddr expr))) ((cast) (and (= 3 (length expr)) (third expr))) ((sizeof) 'size-t) - ((== != < > <= >= c-and c-or !) 'bool) + ;; `c-and' and `c-or' are the names from before `&&' and `||' + ((== != < > <= >= && |\|\|| ! c-and c-or) 'bool) ((+ - / %) (arithmetic-type expr env)) + ;; the bitwise operators join like the arithmetic ones + ((^ |\||) (arithmetic-type expr env)) + ;; a shift does not join: the result is the promoted left operand, + ;; and the right one says only how far + ((<< >>) (promoted-type (expression-type (second expr) env))) + ;; ...and an increment is not a join either -- it is the operand, + ;; unpromoted, being what is written back to it + ((++ --) (expression-type (second expr) env)) ;; otherwise a call: a closure answers with its own return type, ;; anything else with what its signature says (else @@ -605,16 +616,45 @@ (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) + ((or (ptr-type? l) (array-type? l)) (decayed left l)) + ((or (ptr-type? r) (array-type? r)) (decayed right r)) + ;; one type on both sides needs no ranking, which is the only way + ;; a name we never parsed a declaration for joins at all + ((and (prim-type? l) (prim-type? r) (equal? (prim-name l) (prim-name r))) + (promoted left l)) + ((or (unrankable? l) (unrankable? r)) '?) ((< (conversion-rank l) (conversion-rank r)) (promoted right r)) + ((> (conversion-rank l) (conversion-rank r)) (promoted left l)) + ;; at equal rank C takes the unsigned one, whichever side it is + ;; written on + ((unsigned-type? r) (promoted right r)) (else (promoted left l))))))) +;;; A name we never parsed a declaration for -- `size-t', `GLuint' -- +;;; has no rank we can know, so a join that would have to compare one +;;; answers `?' instead of taking whichever operand came first. +;;; `resolve-wildcard' turns that into "write it out", which is the only +;;; honest thing to say about it. +(define (unrankable? type) + (and (prim-type? type) (not (c-primitive? type)))) + +(define (unsigned-type? type) + (and (prim-type? type) (memq 'unsigned (prim-name type)) #t)) + ;;; Anything narrower than `int' is promoted to one before the ;;; arithmetic happens, so two `char's join as `int' and not as `char'. ;;; Operands of the same type reach here too, which is the whole point: ;;; `(+ c c)' is where the promotion is invisible and the truncation is ;;; not. `unsigned' alone is `unsigned int' and stays as written. +;;; An array is a pointer to its first element the moment it is an +;;; operand, so `(+ a 1)' is a `(* int)' and not the `(¤ int 4)' that +;;; `a' was declared as -- which is not a type an initializer can have. +(define (decayed written type) + (if (array-type? type) (unparse-type (decay type)) written)) + +(define (promoted-type written) + (and written (promoted written (underlying (parse-type written))))) + (define (promoted written type) (if (and (prim-type? type) (any (lambda (word) (memq word '(char short bool _Bool))) @@ -1045,11 +1085,29 @@ ((union) (add-union name form)) ((enum) (add-enum name form)))))) +;;; A toplevel form has no function around it and so no scope chain. A +;;; name in a global's initializer is another global's or a function's, +;;; which `get-name-type' answers without one. +(define (make-toplevel-env) + (let ((env (make-hash-table))) + (set! (hash-table-ref env :scopes) (list)) + env)) + (define (process-global-var sex-var acc) ;; A global is not walked for lambdas, but its type still has to stop - ;; saying `closure' before the writer sees it - (let* ((form (resolve-closure-types sex-var)) - (core (if (memq (car form) '(pub extern)) (cdr form) form))) + ;; saying `closure' before the writer sees it, and a `_' still has to + ;; be written out: the writer has no spelling for one either way. + (let* ((resolved (resolve-closure-types sex-var)) + (qualifier (and (memq (car resolved) '(pub extern)) (car resolved))) + (core (if qualifier (cdr resolved) resolved)) + ;; `extern' declares without initializing, so there is nothing + ;; for a `_' to be worked out from + (core (if (eq? 'extern qualifier) + core + (resolve-wildcard core (make-toplevel-env)))) + (form (if qualifier + (copy-form-source! resolved (cons qualifier core)) + core))) (when (and (pair? (cdr core)) (pair? (cddr core)) (symbol? (second core))) (add-name-type! (second core) (third core))) (cons form acc))) diff --git a/tests/infer.module.scm b/tests/infer.module.scm index 5cf5645..5b55c47 100644 --- a/tests/infer.module.scm +++ b/tests/infer.module.scm @@ -17,6 +17,7 @@ resolve underlying + c-primitive? type-quals free-tvars decay -- 2.52.0 From fe72a109bfd4e8fcc610735b5f44d2e5aa8e7b82 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 30 Sep 2026 23:20:55 +0300 Subject: [PATCH 16/17] read a var's type as a type, not as a call `walk-parts' walked the whole `var' form, and a `fn' type's parameter list is shaped like a call: `(fn ((c int)) int)' came out as `int (*fp)(c int)'. A closure literal had no type, so calling one in place missed the rewrite; sextest fed sexc symbols Sex cannot read. --- Makefile | 1 + semen.scm | 69 +++++++++++++++++++----- tests/sex-programs/operators.sex | 90 ++++++++++++++++++++++++++++++++ tools/sextest/sextest.scm | 6 +++ 4 files changed, 153 insertions(+), 13 deletions(-) create mode 100644 tests/sex-programs/operators.sex diff --git a/Makefile b/Makefile index 6cfb23f..a0924ab 100644 --- a/Makefile +++ b/Makefile @@ -108,6 +108,7 @@ SEX_TEST_PROGRAMS = c99 \ inference \ lambdas \ lists \ + operators \ serialize \ type-shapes \ unicode \ diff --git a/semen.scm b/semen.scm index 8f545b4..ccbed18 100644 --- a/semen.scm +++ b/semen.scm @@ -274,12 +274,15 @@ ;;; (fn sum ((a int) (b int)) int ...) -> (fn ((int) (int)) int). ;;; Anything that is not a plain (name type) -- a variadic tail -- goes ;;; through untouched. +(define (arglist-types arglist) + (map (lambda (param) + (if (and (pair? param) (= 2 (length param)) (named-arg? param)) + (list (second param)) + param)) + arglist)) + (define (fn-type-of fn-form) - `(fn ,(map (lambda (param) - (if (and (pair? param) (= 2 (length param)) (named-arg? param)) - (list (second param)) - param)) - (sex-fn-arglist fn-form)) + `(fn ,(arglist-types (sex-fn-arglist fn-form)) ,(sex-fn-return-type fn-form))) (define (aux-name! env make) @@ -379,8 +382,24 @@ (fourth form)))))))) ((var) - ;; the initializer is walked before the name it binds is in scope - (let* ((walked (resolve-wildcard (walk-parts form env) env)) + ;; the initializer is walked before the name it binds is in + ;; scope; the type is resolved rather than walked, a `fn' type's + ;; parameter list being indistinguishable from a call -- walking + ;; `(fn ((c int)) int)' with a closure named `c' in scope would + ;; rewrite the parameter as a call of it + (let* ((prefix (if (>= (length form) 3) + (append (take form 2) + (list (resolve-closure-types + (expand-type (third form) env)))) + form)) + (walked (resolve-wildcard + (copy-form-source! + form + (append prefix + (if (> (length form) 3) + (walk-body (drop form 3) env) + (list)))) + env)) (bound (if (>= (length walked) 4) (copy-form-source! walked @@ -408,12 +427,16 @@ (else (let ((closure (receiver-closure-type (car form) env))) (if closure - (copy-form-source! - form - `(,(register-closure-call! closure form) - ,(walk-statement (car form) env) - ,@(map (lambda (argument) (walk-statement argument env)) - (cdr form)))) + ;; the receiver is walked first: a closure written where it + ;; is called registers its struct on the way, and the call + ;; helper's signature mentions that struct + (let ((receiver (walk-statement (car form) env))) + (copy-form-source! + form + `(,(register-closure-call! closure form) + ,receiver + ,@(map (lambda (argument) (walk-statement argument env)) + (cdr form))))) (convert-arguments (walk-parts form env) env)))))))) ;;; `(var n _ (strlen s))' becomes `(var n size-t (strlen s))'. @@ -507,6 +530,21 @@ (else (pair (cdr params) (- remaining 1) (cons (unwrap-type (car params)) acc)))))) +;;; A `fn' header has its macros expanded and its closure types +;;; resolved without being walked; a `var' type is the same thing in the +;;; same position, and gets the same two. A macro standing in for a type +;;; may still ask `(type-of x)' while it does so. +(define (expand-type type env) + (let ((expanded + (parameterize ((current-type-of + (lambda (queried) + (unresolve-closure-types + (expression-type queried env))))) + (macro-expand (list type))))) + (if (and (pair? expanded) (null? (cdr expanded))) + (car expanded) + expanded))) + (define (walk-parts form env) (copy-form-source! form (walk-body form env))) @@ -575,6 +613,11 @@ (cddr expr))) ((cast) (and (= 3 (length expr)) (third expr))) ((sizeof) 'size-t) + ;; a closure literal is its own type: the first three elements + ;; already spell one, so calling one where it is written resolves + ;; like calling one through a name + ((closure) (and (closure-expression? expr) + `(closure ,(arglist-types (second expr)) ,(third expr)))) ;; `c-and' and `c-or' are the names from before `&&' and `||' ((== != < > <= >= && |\|\|| ! c-and c-or) 'bool) ((+ - / %) (arithmetic-type expr env)) diff --git a/tests/sex-programs/operators.sex b/tests/sex-programs/operators.sex new file mode 100644 index 0000000..bd730bc --- /dev/null +++ b/tests/sex-programs/operators.sex @@ -0,0 +1,90 @@ +(input) +(output "logical: 1 1 0" + "bitwise: 7 2 5" + "shifts: 48 0 12" + "increment: 7" + "decayed: 2 2 there" + "unsigned wins either way: 4294967295 4294967295" + "toplevel: 1 2.5 hi 12" + "closure in place: 5" + "a type is not a call: 7") +(return 0) + +;;; The walk types an expression by its head, and the heads it had a +;;; rule for were the ones inference was written against. `&&', the +;;; bitwise operators, the shifts and `++' were not among them and each +;;; stopped with `cannot infer'. +;;; +;;; The rest of this is the same mistake in three other places: an array +;;; is a pointer the moment it is an operand, a rank tie is not decided +;;; by which operand was written first, and `_' is not a local's +;;; privilege. + +(include stdio.h) + +(fn area ((w int) (h int)) int + (return (* w h))) + +;;; a toplevel `_' reads the same table a local's does, so it can name +;;; anything declared above it +(var n _ 1) +(var d _ 2.5) +(var s _ "hi") +(var a _ (+ 3 (* 3 3))) + +(fn make-adder ((k int)) (closure ((int)) int) + (return (closure ((b int)) int (k) (return (+ k b))))) + +(pub fn main () int + (var x int 6) + (var y int 3) + (var ok _ (&& x y)) + (var orr _ (|| x y)) + (var neg _ (! x)) + (printf "logical: %d %d %d\n" ok orr neg) + + (var bor _ (| x y)) + (var band _ (& x y)) + (var bxor _ (^ x y)) + (printf "bitwise: %d %d %d\n" bor band bxor) + + ;; a shift is the promoted left operand, not a join: the right one + ;; says only how far + (var c char 12) + (var shl _ (<< x y)) + (var shr _ (>> x y)) + (var wide _ (>> c 0)) + (printf "shifts: %d %d %d\n" shl shr wide) + + ;; ...and an increment is the operand, unpromoted + (var inc _ (++ x)) + (printf "increment: %d\n" inc) + + ;; an array operand decays, so this is a pointer and not an array + (var xs (¤ int 4) #(1 2 3 4)) + (var p _ (+ xs 1)) + (var q _ (+ 1 xs)) + (var names (¤ (* const char) 2) #("hi" "there")) + (var np _ (+ names 1)) + (printf "decayed: %d %d %s\n" (* p) (* q) (* np)) + + ;; at equal rank C takes the unsigned operand, whichever side it is on + (var i int -1) + (var u (unsigned int) 1) + (var u1 _ (+ i u)) + (var u2 _ (+ u i)) + (printf "unsigned wins either way: %u %u\n" (- u1 1) (- u2 1)) + + (printf "toplevel: %d %g %s %d\n" n d s a) + + ;; a closure literal is its own type, so it can be called where it is + ;; written, the way a lambda already could + (printf "closure in place: %d\n" + ((closure ((v int)) int () (return v)) 5)) + + ;; a `fn' type's parameter list looks exactly like a call; with a + ;; closure named `f' in scope it used to be read as one + (var f (closure ((int)) int) (make-adder 1)) + (var fp (fn ((f int) (g int)) int) area) + (printf "a type is not a call: %d\n" (f 6)) + (return 0)) diff --git a/tools/sextest/sextest.scm b/tools/sextest/sextest.scm index 4ce6229..e07319e 100644 --- a/tools/sextest/sextest.scm +++ b/tools/sextest/sextest.scm @@ -86,8 +86,14 @@ (compiled-file (create-temporary-file))) ;; `process' returns one record; `process-input-port' is named from ;; the child's side, so it is the port we write to. + ;; + ;; Sex has no symbol escaping -- `|' is an operator there, not a + ;; quote -- so the forms go out the way they were written. Left to + ;; escape, `||' would leave here as `|\|\||' and reach sexc as a + ;; different symbol. (let* ((proc (process compiler (append (list "-o" compiled-file) flags))) (sexc-stdin (process-input-port proc))) + (symbol-escape #f) (with-output-to-port sexc-stdin (fn (map (fn (fmt #t x)) src))) (close-output-port sexc-stdin) -- 2.52.0 From a860da6d7edbfd095de5d8600e369a4cf0fb23cc Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 30 Sep 2026 23:48:31 +0300 Subject: [PATCH 17/17] show the cases the comments were describing --- fmt-c-writer.scm | 12 ++-- infer.scm | 6 +- semen.scm | 131 +++++++++++++++++++------------------- tools/sextest/sextest.scm | 7 +- types.scm | 34 +++++----- 5 files changed, 97 insertions(+), 93 deletions(-) diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 53cbe05..05f9b8b 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -381,11 +381,13 @@ forms, and what remains." ;; are not part of it: ((* const char)), (int) (walk-type (maybe-unwrap-type arg)))) -;;; A parameter reaches fmt-c as `(type name)' and nothing else: it -;;; reads the name out with `cadr', so a nameless one is the type and -;;; an explicit #f. Handing it the bare type instead made it read the -;;; type's own second word as the name -- `(* const char)' lost its -;;; star -- and a one-word type had no second word to read at all. +;;; fmt-c reads a parameter as `(type name)', taking the name with +;;; `cadr'. A nameless one is the type and an explicit #f: +;;; +;;; (* const char) -> const char the star read as the name +;;; ((* const char) #f) -> const char * +;;; (int) -> (cadr) error +;;; (int #f) -> int (define (walk-arglist form) ;; E.g.: ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32)) diff --git a/infer.scm b/infer.scm index 3ba37b0..0ad6574 100644 --- a/infer.scm +++ b/infer.scm @@ -509,9 +509,9 @@ ((eq? a b) #t) ((unknown-type? a) #t) ((unknown-type? b) #t) - ;; Whichever side is free takes the binding, so that a rigid - ;; variable is solved *to* rather than solved, in either order. - ;; Both rigid and distinct is the mismatch `eq?' above let through. + ;; Whichever side is free takes the binding: `(unify a r)' and + ;; `(unify r a)' both leave `a' bound to `r'. Two rigid and + ;; distinct is the mismatch `eq?' above let through. ((and (tvar? a) (not (tvar-rigid? a))) (bind-tvar! a b form)) ((and (tvar? b) (not (tvar-rigid? b))) (bind-tvar! b a form)) ((or (tvar? a) (tvar? b)) (type-mismatch a b form)) diff --git a/semen.scm b/semen.scm index ccbed18..e1952ea 100644 --- a/semen.scm +++ b/semen.scm @@ -299,12 +299,15 @@ ;;; ;;; `(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. Every -;;; form whose body C brackets opens a frame; innermost first. +;;; form whose body C brackets opens a frame; innermost first: ;;; -;;; One frame per form is enough, rather than one per arm: a `case' label -;;; opens no scope in C either, and a declaration is not a statement, so -;;; the only way to write one in an `if' arm is the `do' that already -;;; brings its own. +;;; (var v double 3.75) +;;; (while (< v 0) (var v char 1) ...) +;;; (var m _ (+ v 1)) ; double, not char +;;; +;;; One frame per form, not one per arm: a `case' label opens no scope +;;; in C, and an `if' arm can only declare inside a `do', which brings +;;; its own. (define (declare-name! env name type) (hash-table-set! (car (hash-table-ref env :scopes)) name type)) @@ -383,10 +386,11 @@ ((var) ;; the initializer is walked before the name it binds is in - ;; scope; the type is resolved rather than walked, a `fn' type's - ;; parameter list being indistinguishable from a call -- walking - ;; `(fn ((c int)) int)' with a closure named `c' in scope would - ;; rewrite the parameter as a call of it + ;; scope; the type is resolved rather than walked, a parameter + ;; list being shaped like a call: + ;; + ;; (var c (closure ((int)) int) ...) + ;; (var fp (fn ((c int)) int) ...) ; int (*fp)(int) (let* ((prefix (if (>= (length form) 3) (append (take form 2) (list (resolve-closure-types @@ -427,9 +431,9 @@ (else (let ((closure (receiver-closure-type (car form) env))) (if closure - ;; the receiver is walked first: a closure written where it - ;; is called registers its struct on the way, and the call - ;; helper's signature mentions that struct + ;; the receiver is walked first: `((closure ((x int)) int + ;; () ...) 5)' registers `struct ƛint_int' on the way, and + ;; the call helper's signature names it (let ((receiver (walk-statement (car form) env))) (copy-form-source! form @@ -530,10 +534,12 @@ (else (pair (cdr params) (- remaining 1) (cons (unwrap-type (car params)) acc)))))) -;;; A `fn' header has its macros expanded and its closure types -;;; resolved without being walked; a `var' type is the same thing in the -;;; same position, and gets the same two. A macro standing in for a type -;;; may still ask `(type-of x)' while it does so. +;;; What a `fn' header gets, a `var' type gets -- macro expansion and +;;; closure resolution, no walk: +;;; +;;; (defmacro (ty) 'int) (var x (ty) 0) -> int x = 0; +;;; +;;; and the macro may ask `(type-of x)' while it stands in for a type. (define (expand-type type env) (let ((expanded (parameterize ((current-type-of @@ -594,8 +600,8 @@ (and (symbol? (car expr)) (get-return-type (car expr)))) (else (case (car expr) - ;; subscripting an array gives its element type, and a pointer - ;; subscripts the same way + ;; (¤ pts 1), pts : (¤ struct point 2) -> (struct point) + ;; (¤ p 1), p : (* int) -> int ((¤) (let ((base (expression-type (second expr) env))) (or (array-element-type base) (pointer-target base)))) ;; unary `&' takes an address; with two operands it is bitwise and @@ -613,9 +619,8 @@ (cddr expr))) ((cast) (and (= 3 (length expr)) (third expr))) ((sizeof) 'size-t) - ;; a closure literal is its own type: the first three elements - ;; already spell one, so calling one where it is written resolves - ;; like calling one through a name + ;; `(closure ((x int)) int () ...)' is a `(closure ((int)) int)', + ;; so `((closure ((x int)) int () (return x)) 5)' is a call ((closure) (and (closure-expression? expr) `(closure ,(arglist-types (second expr)) ,(third expr)))) ;; `c-and' and `c-or' are the names from before `&&' and `||' @@ -623,11 +628,11 @@ ((+ - / %) (arithmetic-type expr env)) ;; the bitwise operators join like the arithmetic ones ((^ |\||) (arithmetic-type expr env)) - ;; a shift does not join: the result is the promoted left operand, - ;; and the right one says only how far + ;; a shift is the promoted left operand, not a join: + ;; (<< l b), l : long -> long; (>> c b), c : char -> int ((<< >>) (promoted-type (expression-type (second expr) env))) - ;; ...and an increment is not a join either -- it is the operand, - ;; unpromoted, being what is written back to it + ;; ...and an increment is the operand unpromoted: + ;; (++ c), c : char -> char ((++ --) (expression-type (second expr) env)) ;; otherwise a call: a closure answers with its own return type, ;; anything else with what its signature says @@ -661,37 +666,36 @@ (cond ((or (ptr-type? l) (array-type? l)) (decayed left l)) ((or (ptr-type? r) (array-type? r)) (decayed right r)) - ;; one type on both sides needs no ranking, which is the only way - ;; a name we never parsed a declaration for joins at all + ;; one type on both sides needs no ranking: + ;; (+ n n), n : size-t -> size-t ((and (prim-type? l) (prim-type? r) (equal? (prim-name l) (prim-name r))) (promoted left l)) ((or (unrankable? l) (unrankable? r)) '?) ((< (conversion-rank l) (conversion-rank r)) (promoted right r)) ((> (conversion-rank l) (conversion-rank r)) (promoted left l)) - ;; at equal rank C takes the unsigned one, whichever side it is - ;; written on + ;; (+ i u) and (+ u i) are both unsigned int ((unsigned-type? r) (promoted right r)) (else (promoted left l))))))) -;;; A name we never parsed a declaration for -- `size-t', `GLuint' -- -;;; has no rank we can know, so a join that would have to compare one -;;; answers `?' instead of taking whichever operand came first. -;;; `resolve-wildcard' turns that into "write it out", which is the only -;;; honest thing to say about it. +;;; `size-t', `GLuint': no declaration parsed, so no rank to compare. +;;; +;;; (var m _ (+ 1 n)) n : size-t -> type of this is unknown +;;; (var m size-t (+ 1 n)) -> size_t m = 1 + n; (define (unrankable? type) (and (prim-type? type) (not (c-primitive? type)))) (define (unsigned-type? type) (and (prim-type? type) (memq 'unsigned (prim-name type)) #t)) -;;; Anything narrower than `int' is promoted to one before the -;;; arithmetic happens, so two `char's join as `int' and not as `char'. -;;; Operands of the same type reach here too, which is the whole point: -;;; `(+ c c)' is where the promotion is invisible and the truncation is -;;; not. `unsigned' alone is `unsigned int' and stays as written. -;;; An array is a pointer to its first element the moment it is an -;;; operand, so `(+ a 1)' is a `(* int)' and not the `(¤ int 4)' that -;;; `a' was declared as -- which is not a type an initializer can have. +;;; Narrower than `int' promotes to one: +;;; +;;; (+ c c) c : char 100 -> int 200, not char -56 +;;; (+ h h) h : short 30000 -> int 60000, not short -5536 +;;; (+ u u) u : unsigned -> unsigned -- `unsigned' is unsigned int +;;; An array operand is a pointer to its first element: +;;; +;;; (var p _ (+ a 1)) a : (¤ int 4) -> int * p = a + 1; +;;; not int p[4] = a + 1; (define (decayed written type) (if (array-type? type) (unparse-type (decay type)) written)) @@ -776,11 +780,11 @@ (define +closure-env-bytes+ 16) -;;; +closure-env-bytes+ for maximum capacity, and an alignment wide -;;; enough for anything that fits in them, hence union. `max_align_t' -;;; would say that in one word, but it is C11 and the target is C99, so -;;; the widest built-ins say it instead: a union is aligned for the -;;; strictest of its members. +;;; +closure-env-bytes+ for capacity, the widest built-ins for +;;; alignment, hence union -- a union takes the strictest alignment of +;;; its members. `max_align_t' would say the second in one word: +;;; +;;; sexc hello-world.sex -- -std=c99 unknown type name 'max_align_t' (define +closure-env-type+ 'ƛenv) (define (closure-env-declaration) @@ -854,15 +858,14 @@ *pending-closure-structs*))))) (delete-duplicates (aggregates-in type)))) -;;; Where one argument ends and the next begins has to survive the -;;; flattening, or `((long long))' and `((long) (long))' mangle alike and -;;; the second signature silently reuses the first one's struct. Words -;;; within an argument keep the single separator; the arguments take a -;;; doubled one. +;;; The words inside an argument take the single separator, the +;;; arguments a doubled one: ;;; -;;; Not proof against a type name that mangles to a trailing `_' of its -;;; own -- for that the arguments would have to carry their lengths, and -;;; the name in the C is worth more than the last of the ambiguity. +;;; (closure ((long long)) int) -> ƛlong_long_int +;;; (closure ((long) (long)) int) -> ƛlong__long_int +;;; +;;; A word whose first character mangles to `_' still aliases the +;;; doubled separator: `((a -b))' and `((a) (b))' are both `a__b'. (define (mangle-arglist args) (if (null? args) "void" @@ -1040,8 +1043,8 @@ (let ((name (capture-name capture))) (unless (symbol? name) (sex-error form "a closure capture needs a name" capture)) - ;; the same lookup either way: a capture that borrows a name can - ;; borrow a global's or a function's, not only a local's + ;; the same lookup either way, so `(closure ((x int)) int (scale) + ;; ...)' borrows a global's `scale' as readily as a local's (let ((type (expression-type (capture-argument capture) env))) (unless type (sex-error form "cannot infer what is captured as" name)) @@ -1128,23 +1131,21 @@ ((union) (add-union name form)) ((enum) (add-enum name form)))))) -;;; A toplevel form has no function around it and so no scope chain. A -;;; name in a global's initializer is another global's or a function's, -;;; which `get-name-type' answers without one. +;;; No function around a toplevel form, so no scope chain: what a +;;; global's initializer names comes from `get-name-type' alone. (define (make-toplevel-env) (let ((env (make-hash-table))) (set! (hash-table-ref env :scopes) (list)) env)) (define (process-global-var sex-var acc) - ;; A global is not walked for lambdas, but its type still has to stop - ;; saying `closure' before the writer sees it, and a `_' still has to - ;; be written out: the writer has no spelling for one either way. + ;; A global is not walked for lambdas, but the writer spells neither + ;; `closure' nor `_': `(var n _ 1)' has to reach it as `int n = 1' (let* ((resolved (resolve-closure-types sex-var)) (qualifier (and (memq (car resolved) '(pub extern)) (car resolved))) (core (if qualifier (cdr resolved) resolved)) - ;; `extern' declares without initializing, so there is nothing - ;; for a `_' to be worked out from + ;; `(extern var n int)' has no initializer to work a `_' out + ;; from (core (if (eq? 'extern qualifier) core (resolve-wildcard core (make-toplevel-env)))) diff --git a/tools/sextest/sextest.scm b/tools/sextest/sextest.scm index e07319e..43f3d5f 100644 --- a/tools/sextest/sextest.scm +++ b/tools/sextest/sextest.scm @@ -87,10 +87,9 @@ ;; `process' returns one record; `process-input-port' is named from ;; the child's side, so it is the port we write to. ;; - ;; Sex has no symbol escaping -- `|' is an operator there, not a - ;; quote -- so the forms go out the way they were written. Left to - ;; escape, `||' would leave here as `|\|\||' and reach sexc as a - ;; different symbol. + ;; Sex reads no symbol escaping -- `|' is an operator there. Left + ;; on, `(|| a b)' leaves here as `(|\|\|| a b)' and reaches sexc + ;; as a different symbol. (let* ((proc (process compiler (append (list "-o" compiled-file) flags))) (sexc-stdin (process-input-port proc))) (symbol-escape #f) diff --git a/types.scm b/types.scm index 2f8e937..f2cfd5e 100644 --- a/types.scm +++ b/types.scm @@ -240,14 +240,14 @@ ;;; The shape of a written type ;;; -;;; Three places have to tell a type from something that merely -;;; contains one: an arglist entry is either `(name type)' or a bare -;;; type, and an array's last element is either a bound or the last -;;; word of its element type. They used to answer it separately, and -;;; disagreed. +;;; Where a type ends, asked by an arglist and by an array bound: +;;; +;;; (f1 float) a name and a type (unsigned int) a type +;;; (¤ int 4) four of int (¤ const t) unsized, of const t +;;; (¤ mytype N) N of mytype (¤ * size-t) unsized, of (* size-t) -;;; A qualifier can never end a type, which is what tells `(¤ const t)' -;;; -- an unsized array of `t' -- from `(¤ int 4)'. +;;; A qualifier cannot end a type: `(¤ const t)' is unsized, `(¤ int 4)' +;;; is four of int. (define +c-qualifiers+ '(const volatile restrict _Atomic)) (define +c-specifiers+ @@ -271,20 +271,22 @@ (pair? (cdr arg)) ; 1 element args are always type (not (type-head? arg)))) -;;; Is NAME a typedef, as opposed to a `define'd constant? Both live in -;;; the same table, and only the first is part of a type. +;;; A typedef and a `define' share +type-db+; only the typedef is part +;;; of a type: +;;; +;;; (typedef small int) -> (¤ small N) is N of small +;;; (define CAP 4) -> (¤ int CAP) is CAP of int (define (typedef-name? name) (let ((info (and (symbol? name) (get-type-info name)))) (and info (memq (car info) '(typedef struct union enum)) #t))) -;;; `(¤ int N)' is N of int -;;; `(¤ unsigned int)' is an unsized array of unsigned int +;;; The last element is a bound only where what precedes it already +;;; spells a whole type -- a specifier, a tag after its keyword, or a +;;; typedef we have seen declared: ;;; -;;; The last element is a bound only if what precedes it is already a -;;; complete type, so `(¤ const mytype)' and `(¤ * size-t)' end in the -;;; last word of their element type and not in a bound. A type is -;;; complete when it ends in a specifier, in a tag following its -;;; keyword, or in a typedef we have seen declared. +;;; (¤ int 4) four of int (¤ unsigned int) unsized +;;; (¤ mytype CAP) CAP of mytype (¤ struct point) unsized +;;; (¤ const mytype) unsized (¤ * size-t) unsized ;;; ;;; TYPE is the whole `(¤ ...)' form. (define (array-bound? type) -- 2.52.0