Preserve Typed Jerboa expression sources
ober
b5bf43d395ed3403847398cce9bcc58766999c04
--- a/docs/jerboa-to-rust.md +++ b/docs/jerboa-to-rust.md @@ -88,8 +88,10 @@ Still open: - Direct Scheme conversions for Option/Result instead of opaque handles. - Resource `#:close` lowering and Rust `Drop` integration. - Borrow-aware lowering. Current generated Rust clones liberally. -- Source-map plumbing from parser spans to checker diagnostics and generated - Rust comments. +- Generated Rust source comments tied to typed source spans. Checker + diagnostics now carry expression-level `(path,line,column)` triples through + `typed-check-error-source`; the Rust emitter does not yet thread that into + generated `// source: ...` comments. - Direct `rustc`/static integration polish and eventual LLVM parity tests. ## Output Layout --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -137,9 +137,10 @@ Current landing: - `(jerboa typed parser)` parses and validates `(typed-library ...)` datums into a first AST layer. It preserves reader source locations on the module - and declaration-level AST records while stripping annotations from semantic - names, type expressions, and function bodies so file based `typecheck` and - backend generation use the same AST path as unit tests. + and declaration-level AST records, and now also keeps annotated datums + inside function bodies so the checker can attach file/line/column to + expression diagnostics. The Rust emitter strips annotations at its + boundary so generated code remains deterministic. - `(jerboa typed checker)` performs the first backend-neutral validation pass: duplicate names, export resolution, type-reference resolution, compound type arities, duplicate fields, duplicate params, duplicate variant cases, and a @@ -147,7 +148,8 @@ Current landing: - `support/typecheck.ss` and the `make typecheck` / `make typed-test` targets run the parser/checker over typed source files without invoking Rust. The typecheck CLI now prints structured diagnostics with module context, detail, - and a short hint for common errors. + source location (file:line:column) when available, and a short hint for + common errors. - `(jerboa typed rust)` emits deterministic safe Rust text for checked typed modules. The first emitter covers Rust identifiers, primitive types, records, variants, primitive function bodies, record accessors/constructors, @@ -204,6 +206,8 @@ Current landing: `typed-type-decl-source`, `typed-field-source`, `typed-record-source`, `typed-resource-source`, `typed-variant-source`, `typed-variant-case-source`, `typed-param-source`, and `typed-def-source`. + Function body expressions retain their reader source annotations; checker + diagnostics expose them through `typed-check-error-source`. - This is still a front-end milestone. Function-body checking currently covers literals, variables, `begin`, simple `let`, `if`, arithmetic primitives, numeric comparisons, same-type `equal?`, boolean primitives, calls to typed @@ -264,28 +268,31 @@ Code that has landed: The next model should continue in small commits with tests and docs per step. Highest-value next steps: -1. Add expression-level source spans and thread them into `typed-check-error` - so diagnostics can report file/line/column for bad calls, mismatched branch - types, and ownership errors. Declaration-level spans now exist; body spans - do not. -2. Introduce an explicit typed core IR between parser/checker and backends. +1. Introduce an explicit typed core IR between parser/checker and backends. Today the checker and Rust emitter both walk surface datums, which keeps the MVP simple but will make imports, source maps, and optimization harder. -3. Resolve imports between typed modules. The checker currently handles calls +2. Resolve imports between typed modules. The checker currently handles calls within one typed module only; imported calls are intentionally unsupported. -4. Improve boundary semantics for Option/Result. They currently cross the FFI +3. Improve boundary semantics for Option/Result. They currently cross the FFI boundary as opaque handles; direct conversion to idiomatic Scheme result values is still open. -5. Make resource lowering borrow-aware. The checker has straight-line owned +4. Make resource lowering borrow-aware. The checker has straight-line owned move rules, but the Rust backend still uses a conservative Clone-heavy model and does not use resource `#:close` hooks for generated `Drop`. -6. Add structured error returns. Rust ABI wrappers catch panics and return +5. Add structured error returns. Rust ABI wrappers catch panics and return conservative defaults; there is not yet a typed error/result ABI for wrapper failures. +6. Thread expression-level source spans through to generated Rust comments so + compiler errors can map back to typed source line and column. 7. Add fuzz/property tests for parser/checker and broader differential tests against dynamic Jerboa implementations before moving to LLVM or static integration. +Expression-level source spans have landed: the parser preserves annotated +datums inside function bodies, the checker captures each diagnostic's source +through `typed-check-error-source`, and `support/typecheck.ss` renders +`file:line:column` for any error carrying a location. + Expected verification before each commit: - `jerboa_compile_check` on any changed `.ss`/`.sls` implementation files. @@ -913,12 +920,13 @@ Minimum excluded features: - Read typed module forms. Initial datum parser landed as `(jerboa typed parser)`. -- Preserve source spans. Initial module-level source preservation has landed: - `typed-module-source` stores the reader source location for annotated - `typed-library` forms, and declaration-level AST records now retain source - accessors for type declarations, records, fields, resources, variants, - variant cases, params, and defs. Function body/expression spans are still - future work. +- Preserve source spans. Module-level, declaration-level, and expression-level + source preservation has landed. `typed-module-source` stores the reader + source location for annotated `typed-library` forms, declaration-level AST + records retain source accessors for type declarations, records, fields, + resources, variants, variant cases, params, and defs, and function bodies + now keep annotated datums so checker diagnostics can attach + `typed-check-error-source` with file/line/column. - Parse type expressions. Initial symbolic and compound type parsing landed. - Parse records, variants, and function definitions. Initial AST records landed. - Reject unsupported forms clearly. --- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -8,6 +8,7 @@ (export typed-check-error? make-typed-check-error typed-check-error-kind typed-check-error-message typed-check-error-detail + typed-check-error-source typed-check-error-hint typed-check-error->string check-typed-module @@ -16,9 +17,11 @@ (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed compiler checker module (only (jerboa core) def defstruct) + (only (jerboa reader) source-location? source-location-path + source-location-line source-location-column) (jerboa typed parser)) - (defstruct typed-check-error (kind message detail)) + (defstruct typed-check-error (kind message detail source)) (defstruct typed-call-sig (param-types return-type effects)) (def *call-env* (make-parameter '())) @@ -43,8 +46,29 @@ (def any-value-type (gensym "typed-any")) - (def (make-check-error kind message detail) - (make-typed-check-error kind message detail)) + (def (make-check-error kind message detail . source*) + (let ([source (cond + [(null? source*) #f] + [(null? (cdr source*)) (car source*)] + [else (error 'make-check-error + "expected at most one source argument" + source*)])]) + (make-typed-check-error + kind + message + (strip-source-annotations detail) + source))) + + (def (error-at expr kind message detail) + (make-check-error kind message detail (expr-source expr))) + + (def (expr-head expr) + (and (expr-pair? expr) + (let ([h (car (expr-value expr))]) + (and (expr-symbol? h) (expr-value h))))) + + (def (expr-args expr) + (cdr (expr-value expr))) (def (typed-check-error-hint err) (case (typed-check-error-kind err) @@ -100,20 +124,31 @@ "Add clauses for every variant case, or use _/else as an explicit fallback."] [else #f])) + (def (source-location->string source) + (and (source-location? source) + (format "~a:~a:~a" + (or (source-location-path source) "<unknown>") + (source-location-line source) + (source-location-column source)))) + (def (typed-check-error->string path module-name err) (let ([port (open-output-string)] - [hint (typed-check-error-hint err)]) - (fprintf port "~a: module ~s: ~s~%" - path - module-name - (typed-check-error-kind err)) - (fprintf port " message: ~a~%" - (typed-check-error-message err)) - (fprintf port " detail: ~s~%" - (typed-check-error-detail err)) - (when hint - (fprintf port " hint: ~a~%" hint)) - (get-output-string port))) + [hint (typed-check-error-hint err)] + [source (typed-check-error-source err)]) + (let ([source-str (source-location->string source)]) + (fprintf port "~a: module ~s: ~s~%" + (or source-str path) + module-name + (typed-check-error-kind err)) + (fprintf port " message: ~a~%" + (typed-check-error-message err)) + (fprintf port " detail: ~s~%" + (typed-check-error-detail err)) + (when source-str + (fprintf port " at: ~a~%" source-str)) + (when hint + (fprintf port " hint: ~a~%" hint)) + (get-output-string port)))) (def (append-map f xs) (let loop ([rest xs] [out '()]) @@ -503,44 +538,48 @@ (extend-env (car rest-names) (car rest-types) out))]))) (def (binding-name binding) - (and (pair? binding) (car binding))) + (let ([v (expr-value binding)]) + (and (pair? v) (expr-value (car v))))) (def (check-let-binding-shape binding) - (cond - [(and (pair? binding) - (pair? (cdr binding)) - (null? (cddr binding)) - (symbol? (car binding))) - '()] - [else - (list (make-check-error 'bad-let-binding - "expected let binding (name expr)" - binding))])) + (let ([v (expr-value binding)]) + (cond + [(and (pair? v) + (pair? (cdr v)) + (null? (cddr v)) + (expr-symbol? (car v))) + '()] + [else + (list (error-at binding 'bad-let-binding + "expected let binding (name expr)" + binding))]))) (def (infer-let bindings body env type-names expr) (cond - [(not (list? bindings)) + [(not (expr-list? bindings)) (values #f - (list (make-check-error 'bad-let-binding + (list (error-at expr 'bad-let-binding "let bindings must be a list" expr)))] [else - (let ([shape-errors (append-map check-let-binding-shape bindings)] - [duplicate-name-errors - (duplicate-errors 'duplicate-local - "duplicate local binding" - (map binding-name bindings))]) + (let* ([binding-list (expr->list bindings)] + [shape-errors (append-map check-let-binding-shape binding-list)] + [duplicate-name-errors + (duplicate-errors 'duplicate-local + "duplicate local binding" + (map binding-name binding-list))]) (if (or (not (null? shape-errors)) (not (null? duplicate-name-errors))) (values #f (append duplicate-name-errors shape-errors)) - (let loop ([rest bindings] [local-env env] [errors '()]) + (let loop ([rest binding-list] [local-env env] [errors '()]) (if (null? rest) (let-values ([(body-type body-errors) (infer-body body local-env type-names)]) (values body-type (append (reverse errors) body-errors))) (let* ([binding (car rest)] - [name (car binding)] - [value-expr (cadr binding)]) + [binding-value (expr-value binding)] + [name (expr-value (car binding-value))] + [value-expr (cadr binding-value)]) (let-values ([(value-type value-errors) (infer-expression value-expr env type-names)]) (loop (cdr rest) @@ -552,7 +591,7 @@ (def (infer-if args env type-names expr) (if (not (= (length args) 3)) (values #f - (list (make-check-error 'bad-if + (list (error-at expr 'bad-if "if expects condition, then branch, and else branch" expr))) (let-values ([(cond-type cond-errors) @@ -563,13 +602,13 @@ (infer-expression (caddr args) env type-names)]) (let ([condition-errors (if (and cond-type (not (eq? cond-type 'Bool))) - (list (make-check-error 'condition-type-mismatch + (list (error-at (car args) 'condition-type-mismatch "if condition must be Bool" cond-type)) '())] [branch-errors (if (and then-type else-type (not (equal? then-type else-type))) - (list (make-check-error 'branch-type-mismatch + (list (error-at expr 'branch-type-mismatch "if branches must have the same type" (list then-type else-type))) '())]) @@ -599,7 +638,8 @@ [else (loop (cdr rest) (cons (car rest) out))]))) (def (fallback-match-pattern? pattern) - (and (symbol? pattern) (memq pattern '(else _)) #t)) + (let ([v (expr-value pattern)]) + (and (symbol? v) (memq v '(else _)) #t))) (def (known-branch-types types) (let loop ([rest types] [out '()]) @@ -631,32 +671,38 @@ [(null? rest) '()] [(equal? (car rest) first) (loop (cdr rest))] [else - (list (make-check-error 'branch-type-mismatch + (list (error-at detail 'branch-type-mismatch "match branches must have the same type" detail))])))]))) + (def (expr-symbol-list? xs) + (and (expr-list? xs) + (for-all expr-symbol? (expr->list xs)))) + (def (infer-match-case-clause clause pattern body variant env type-names seen) - (let* ([case-name (car pattern)] - [vars (cdr pattern)] + (let* ([pattern-list (expr->list pattern)] + [case-name (expr-value (car pattern-list))] + [vars (cdr pattern-list)] + [var-values (map expr-value vars)] [case-decl (lookup-variant-case variant case-name)]) (cond [(not case-decl) (values #f - (list (make-check-error 'unknown-match-case + (list (error-at (car pattern-list) 'unknown-match-case "match pattern is not a case of the variant" case-name)) #f #f)] - [(not (symbol-list? vars)) + [(not (and (for-all expr-symbol? vars))) (values #f - (list (make-check-error 'bad-match-pattern + (list (error-at pattern 'bad-match-pattern "match case fields must be symbols" clause)) case-name #f)] [(memq case-name seen) (values #f - (list (make-check-error 'duplicate-match-case + (list (error-at (car pattern-list) 'duplicate-match-case "duplicate variant case in match" case-name)) case-name @@ -667,7 +713,7 @@ [arity-errors (if (= (length vars) (length case-field-types)) '() - (list (make-check-error 'bad-match-arity + (list (error-at pattern 'bad-match-arity "match pattern field count does not match variant case" (list case-name (length case-field-types) @@ -675,7 +721,7 @@ [duplicate-binding-errors (duplicate-errors 'duplicate-pattern-binding "duplicate binding in match pattern" - (pattern-binding-names vars))]) + (pattern-binding-names var-values))]) (if (or (not (null? arity-errors)) (not (null? duplicate-binding-errors))) (values #f @@ -685,44 +731,47 @@ (let-values ([(body-type body-errors) (infer-body body - (extend-env* vars case-field-types env) + (extend-env* var-values case-field-types env) type-names)]) (values body-type body-errors case-name #f))))]))) (def (infer-match-clause clause variant env type-names seen) - (cond - [(or (not (pair? clause)) (not (list? clause))) - (values #f - (list (make-check-error 'bad-match-clause - "match clause must be a proper list" - clause)) - #f - #f)] - [(null? (cdr clause)) - (values #f - (list (make-check-error 'bad-match-clause - "match clause needs a body" - clause)) - #f - #f)] - [else - (let ([pattern (car clause)] - [body (cdr clause)]) - (cond - [(fallback-match-pattern? pattern) - (let-values ([(body-type body-errors) - (infer-body body env type-names)]) - (values body-type body-errors #f #t))] - [(and (pair? pattern) (list? pattern) (symbol? (car pattern))) - (infer-match-case-clause - clause pattern body variant env type-names seen)] - [else - (values #f - (list (make-check-error 'bad-match-pattern - "match pattern must be a variant case, _, or else" - pattern)) - #f - #f)]))])) + (let ([cv (expr-value clause)]) + (cond + [(or (not (pair? cv)) (not (list? cv))) + (values #f + (list (error-at clause 'bad-match-clause + "match clause must be a proper list" + clause)) + #f + #f)] + [(null? (cdr cv)) + (values #f + (list (error-at clause 'bad-match-clause + "match clause needs a body" + clause)) + #f + #f)] + [else + (let ([pattern (car cv)] + [body (cdr cv)]) + (cond + [(fallback-match-pattern? pattern) + (let-values ([(body-type body-errors) + (infer-body body env type-names)]) + (values body-type body-errors #f #t))] + [(and (expr-pair? pattern) + (expr-list? pattern) + (expr-symbol? (car (expr-value pattern)))) + (infer-match-case-clause + clause pattern body variant env type-names seen)] + [else + (values #f + (list (error-at pattern 'bad-match-pattern + "match pattern must be a variant case, _, or else" + pattern)) + #f + #f)]))]))) (def (infer-match-clauses clauses variant env type-names expr) (let loop ([rest clauses] @@ -743,7 +792,7 @@ [exhaustiveness-errors (if (null? missing) '() - (list (make-check-error 'non-exhaustive-match + (list (error-at expr 'non-exhaustive-match "match does not cover all variant cases" missing)))] [result-type (consistent-branch-type ordered-types)]) @@ -762,7 +811,7 @@ (def (infer-match args env type-names expr) (if (< (length args) 2) (values #f - (list (make-check-error 'bad-match + (list (error-at expr 'bad-match "match expects a target expression and at least one clause" expr))) (let-values ([(target-type target-errors) @@ -773,7 +822,7 @@ (append target-errors (if target-type - (list (make-check-error 'match-type-mismatch + (list (error-at (car args) 'match-type-mismatch "match target must have a declared variant type" target-type)) '()))) @@ -803,38 +852,45 @@ (cons type types) (append (reverse arg-errors) errors)))))) - (def (operand-type-errors expected-kind types detail) - (let loop ([rest types] [out '()]) + (def (operand-type-errors expected-kind types arg-exprs detail) + (let loop ([rest types] [rest-exprs arg-exprs] [out '()]) (cond [(null? rest) (reverse out)] [(not (car rest)) - (loop (cdr rest) out)] + (loop (cdr rest) (if (null? rest-exprs) '() (cdr rest-exprs)) out)] [(eq? expected-kind 'numeric) (if (numeric-type? (car rest)) - (loop (cdr rest) out) + (loop (cdr rest) (if (null? rest-exprs) '() (cdr rest-exprs)) out) (loop (cdr rest) + (if (null? rest-exprs) '() (cdr rest-exprs)) (cons (make-check-error 'operand-type-mismatch "expected numeric operand" - detail) + detail + (and (not (null? rest-exprs)) + (expr-source (car rest-exprs)))) out)))] [(eq? expected-kind 'Bool) (if (eq? (car rest) 'Bool) - (loop (cdr rest) out) + (loop (cdr rest) (if (null? rest-exprs) '() (cdr rest-exprs)) out) (loop (cdr rest) + (if (null? rest-exprs) '() (cdr rest-exprs)) (cons (make-check-error 'operand-type-mismatch "expected Bool operand" - detail) + detail + (and (not (null? rest-exprs)) + (expr-source (car rest-exprs)))) out)))] - [else (loop (cdr rest) out)]))) + [else + (loop (cdr rest) (if (null? rest-exprs) '() (cdr rest-exprs)) out)]))) (def (infer-arithmetic op args env type-names expr) (if (null? args) (values #f - (list (make-check-error 'bad-primitive-arity + (list (error-at expr 'bad-primitive-arity "arithmetic primitive needs at least one operand" expr))) (let-values ([(types errors) (infer-args args env type-names)]) - (let ([operand-errors (operand-type-errors 'numeric types expr)]) + (let ([operand-errors (operand-type-errors 'numeric types args expr)]) (values (if (and (null? errors) (null? operand-errors)) (merge-numeric-types types) @@ -844,11 +900,11 @@ (def (infer-comparison op args env type-names expr) (if (not (= (length args) 2)) (values #f - (list (make-check-error 'bad-primitive-arity + (list (error-at expr 'bad-primitive-arity "comparison primitive needs exactly two operands" expr))) (let-values ([(types errors) (infer-args args env type-names)]) - (let ([operand-errors (operand-type-errors 'numeric types expr)]) + (let ([operand-errors (operand-type-errors 'numeric types args expr)]) (values (if (and (null? errors) (null? operand-errors)) 'Bool #f) (append errors operand-errors)))))) @@ -856,7 +912,7 @@ (def (infer-equality args env type-names expr) (if (not (= (length args) 2)) (values #f - (list (make-check-error 'bad-primitive-arity + (list (error-at expr 'bad-primitive-arity "equal? needs exactly two operands" expr))) (let-values ([(types errors) (infer-args args env type-names)]) @@ -870,14 +926,14 @@ errors (if (or (not (null? errors)) same-type?) '() - (list (make-check-error 'operand-type-mismatch + (list (error-at expr 'operand-type-mismatch "equal? operands must have the same type" expr))))))))) (def (infer-debug-string args env type-names expr) (if (not (= (length args) 1)) (values #f - (list (make-check-error 'bad-primitive-arity + (list (error-at expr 'bad-primitive-arity "debug-string needs exactly one operand" expr))) (let-values ([(type errors) (infer-expression (car args) env type-names)]) @@ -888,24 +944,24 @@ (cond [(and (eq? op 'not) (not (= (length args) 1))) (values #f - (list (make-check-error 'bad-primitive-arity + (list (error-at expr 'bad-primitive-arity "not needs exactly one operand" expr)))] [else (let-values ([(types errors) (infer-args args env type-names)]) - (let ([operand-errors (operand-type-errors 'Bool types expr)]) + (let ([operand-errors (operand-type-errors 'Bool types args expr)]) (values (if (and (null? errors) (null? operand-errors)) 'Bool #f) (append errors operand-errors))))])) - (def (bad-constructor-arity name expected args) - (list (make-check-error 'bad-call-arity + (def (bad-constructor-arity expr name expected args) + (list (error-at expr 'bad-call-arity "typed constructor arity does not match" (list name expected (length args))))) (def (infer-option-some args env type-names expr) (if (not (= (length args) 1)) - (values #f (bad-constructor-arity 'option-some 1 args)) + (values #f (bad-constructor-arity expr 'option-some 1 args)) (let-values ([(value-type errors) (infer-expression (car args) env type-names)]) (values (and value-type (list 'Option value-type)) @@ -913,55 +969,66 @@ (def (infer-option-none args env type-names expr) (if (not (= (length args) 1)) - (values #f (bad-constructor-arity 'option-none 1 args)) - (let ([errors (check-type (car args) type-names)]) - (values (and (null? errors) (list 'Option (car args))) + (values #f (bad-constructor-arity expr 'option-none 1 args)) + (let* ([type-arg (strip-source-annotations (car args))] + [errors (check-type type-arg type-names)]) + (values (and (null? errors) (list 'Option type-arg)) errors)))) (def (infer-result-ok args env type-names expr) (if (not (= (length args) 2)) - (values #f (bad-constructor-arity 'result-ok 2 args)) + (values #f (bad-constructor-arity expr 'result-ok 2 args)) (let-values ([(value-type value-errors) (infer-expression (car args) env type-names)]) - (let ([error-type-errors (check-type (cadr args) type-names)]) + (let* ([err-type (strip-source-annotations (cadr args))] + [error-type-errors (check-type err-type type-names)]) (values (and value-type (null? error-type-errors) - (list 'Result value-type (cadr args))) + (list 'Result value-type err-type)) (append value-errors error-type-errors)))))) (def (infer-result-err args env type-names expr) (if (not (= (length args) 2)) - (values #f (bad-constructor-arity 'result-err 2 args)) + (values #f (bad-constructor-arity expr 'result-err 2 args)) (let-values ([(error-type error-errors) (infer-expression (cadr args) env type-names)]) - (let ([value-type-errors (check-type (car args) type-names)]) + (let* ([val-type (strip-source-annotations (car args))] + [value-type-errors (check-type val-type type-names)]) (values (and error-type (null? value-type-errors) - (list 'Result (car args) error-type)) + (list 'Result val-type error-type)) (append value-type-errors error-errors)))))) - (def (argument-type-errors name expected-types actual-types) - (let loop ([expected expected-types] [actual actual-types] [out '()]) + (def (argument-type-errors name expected-types actual-types arg-exprs) + (let loop ([expected expected-types] + [actual actual-types] + [exprs arg-exprs] + [out '()]) (cond [(or (null? expected) (null? actual)) (reverse out)] [(or (not (car actual)) (type-assignable? (car actual) (car expected))) - (loop (cdr expected) (cdr actual) out)] + (loop (cdr expected) (cdr actual) + (if (null? exprs) '() (cdr exprs)) + out)] [else (loop (cdr expected) (cdr actual) + (if (null? exprs) '() (cdr exprs)) (cons (make-check-error 'argument-type-mismatch "function argument type does not match parameter type" - (list name (car expected) (car actual))) + (list name (car expected) (car actual)) + (and (not (null? exprs)) + (expr-source (car exprs)))) out))]))) - (def (call-effect-errors name callee-effects caller-effects) + (def (call-effect-errors expr name callee-effects caller-effects) (if (and (effect-list-valid-for-flow? callee-effects) (effect-list-valid-for-flow? caller-effects) (not (effect-subset? callee-effects caller-effects))) - (list (make-check-error 'effect-mismatch + (list (error-at expr 'effect-mismatch "callee effects are not covered by caller" (list name (normalize-effects callee-effects) @@ -969,11 +1036,12 @@ '())) (def (moved-name-errors expr moved) - (if (and (symbol? expr) (memq expr moved)) - (list (make-check-error 'use-after-move - "owned value used after move" - expr)) - '())) + (let ([value (expr-value expr)]) + (if (and (symbol? value) (memq value moved)) + (list (error-at expr 'use-after-move + "owned value used after move" + value)) + '()))) (def (call-owned-argument-names name args) (let ([sig (lookup-name name (*call-env*))]) @@ -986,16 +1054,16 @@ [(or (null? expected) (null? actual)) (reverse out)] [(and (owned-type? (car expected)) - (symbol? (car actual))) + (expr-symbol? (car actual))) (loop (cdr expected) (cdr actual) - (cons (car actual) out))] + (cons (expr-value (car actual)) out))] [else (loop (cdr expected) (cdr actual) out)]))))) (def (duplicate-move-errors names expr) (map (lambda (name) - (make-check-error 'duplicate-move + (error-at expr 'duplicate-move "owned value moved more than once in one call" (list name expr))) (duplicates names))) @@ -1030,92 +1098,95 @@ (append arg-errors duplicate-errors))))) (def (check-let-ownership bindings body env moved expr) - (if (not (list? bindings)) + (if (not (expr-list? bindings)) (values moved '()) - (let-values ([(after-bindings binding-errors) - (check-ownership-body - (map cadr - (let loop ([rest bindings] [out '()]) - (cond - [(null? rest) (reverse out)] - [(and (pair? (car rest)) - (pair? (cdr (car rest)))) - (loop (cdr rest) (cons (car rest) out))] - [else (loop (cdr rest) out)]))) - env - moved)]) - (let-values ([(after-body body-errors) - (check-ownership-body body env after-bindings)]) - (values after-body - (append binding-errors body-errors)))))) + (let* ([binding-list (expr->list bindings)] + [value-exprs + (let loop ([rest binding-list] [out '()]) + (cond + [(null? rest) (reverse out)] + [else + (let ([bv (expr-value (car rest))]) + (if (and (pair? bv) (pair? (cdr bv))) + (loop (cdr rest) (cons (cadr bv) out)) + (loop (cdr rest) out)))]))]) + (let-values ([(after-bindings binding-errors) + (check-ownership-body value-exprs env moved)]) + (let-values ([(after-body body-errors) + (check-ownership-body body env after-bindings)]) + (values after-body + (append binding-errors body-errors))))))) (def (check-ownership-expression expr env moved) - (cond - [(symbol? expr) - (values moved (moved-name-errors expr moved))] - [(not (pair? expr)) - (values moved '())] - [else - (case (car expr) - [(begin) - (check-ownership-sequence (cdr expr) env moved)] - [(let) - (if (< (length expr) 3) - (values moved '()) - (check-let-ownership (cadr expr) (cddr expr) env moved expr))] - [(if) - (if (= (length expr) 4) - (let-values ([(after-cond cond-errors) - (check-ownership-expression (cadr expr) env moved)] - [(_then then-errors) - (check-ownership-expression (caddr expr) env moved)] - [(_else else-errors) - (check-ownership-expression (cadddr expr) env moved)]) - (values after-cond - (append cond-errors then-errors else-errors))) - (values moved '()))] - [(match) - (if (< (length expr) 2) - (values moved '()) - (let-values ([(after-target target-errors) - (check-ownership-expression (cadr expr) env moved)]) - (let loop ([rest (cddr expr)] [errors target-errors]) - (if (null? rest) - (values after-target errors) - (let ([clause (car rest)]) - (if (and (pair? clause) (pair? (cdr clause))) - (let-values ([(_branch branch-errors) - (check-ownership-body - (cdr clause) - env - moved)]) - (loop (cdr rest) - (append errors branch-errors))) - (loop (cdr rest) errors)))))))] - [else - (if (symbol? (car expr)) - (check-ownership-call (car expr) (cdr expr) env moved expr) - (values moved '()))])])) + (let ([value (expr-value expr)]) + (cond + [(symbol? value) + (values moved (moved-name-errors expr moved))] + [(not (pair? value)) + (values moved '())] + [else + (let ([head (expr-head expr)] + [args (expr-args expr)]) + (case head + [(begin) + (check-ownership-sequence args env moved)] + [(let) + (if (< (length args) 2) + (values moved '()) + (check-let-ownership (car args) (cdr args) env moved expr))] + [(if) + (if (= (length args) 3) + (let-values ([(after-cond cond-errors) + (check-ownership-expression (car args) env moved)] + [(_then then-errors) + (check-ownership-expression (cadr args) env moved)] + [(_else else-errors) + (check-ownership-expression (caddr args) env moved)]) + (values after-cond + (append cond-errors then-errors else-errors))) + (values moved '()))] + [(match) + (if (< (length args) 1) + (values moved '()) + (let-values ([(after-target target-errors) + (check-ownership-expression (car args) env moved)]) + (let loop ([rest (cdr args)] [errors target-errors]) + (if (null? rest) + (values after-target errors) + (let ([cv (expr-value (car rest))]) + (if (and (pair? cv) (pair? (cdr cv))) + (let-values ([(_branch branch-errors) + (check-ownership-body + (cdr cv) env moved)]) + (loop (cdr rest) + (append errors branch-errors))) + (loop (cdr rest) errors)))))))] + [else + (if head + (check-ownership-call head args env moved expr) + (values moved '()))]))]))) (def (infer-function-call name args env type-names expr) (let ([sig (lookup-name name (*call-env*))]) (if (not sig) (values #f - (list (make-check-error 'unsupported-expression + (list (error-at expr 'unsupported-expression "expression form is not in the typed checker subset yet" expr))) (let ([expected-types (typed-call-sig-param-types sig)]) (if (not (= (length args) (length expected-types))) (values #f - (list (make-check-error 'bad-call-arity + (list (error-at expr 'bad-call-arity "function call arity does not match definition" (list name (length expected-types) (length args))))) (let-values ([(actual-types arg-errors) (infer-args args env type-names)]) (let ([type-errors - (argument-type-errors name expected-types actual-types)] + (argument-type-errors + name expected-types actual-types args)] [effect-errors (call-effect-errors + expr name (typed-call-sig-effects sig) (*current-effects*))]) @@ -1128,82 +1199,83 @@ (append arg-errors type-errors effect-errors))))))))) (def (infer-expression expr env type-names) - (cond - [(boolean? expr) (values 'Bool '())] - [(char? expr) (values 'Char '())] - [(string? expr) (values 'String '())] - [(bytevector? expr) (values 'Bytes '())] - [(integer? expr) - (values (if (>= expr 0) 'Nat 'Int) '())] - [(symbol? expr) - (let ([type (lookup-name expr env)]) - (if type - (values type '()) - (values #f - (list (make-check-error 'unknown-value - "unknown value in expression" - expr)))))] - [(pair? expr) - (case (car expr) - [(begin) - (infer-body (cdr expr) env type-names)] - [(let) - (if (< (length expr) 3) - (values #f - (list (make-check-error 'bad-let - "let expects bindings and body" - expr))) - (infer-let (cadr expr) (cddr expr) env type-names expr))] - [(if) - (infer-if (cdr expr) env type-names expr)] - [(match) - (infer-match (cdr expr) env type-names expr)] - [(+ - * /) - (infer-arithmetic (car expr) (cdr expr) env type-names expr)] - [(= < <= > >=) - (infer-comparison (car expr) (cdr expr) env type-names expr)] - [(equal?) - (infer-equality (cdr expr) env type-names expr)] - [(debug-string) - (infer-debug-string (cdr expr) env type-names expr)] - [(not and or) - (infer-boolean (car expr) (cdr expr) env type-names expr)] - [(option-some) - (infer-option-some (cdr expr) env type-names expr)] - [(option-none) - (infer-option-none (cdr expr) env type-names expr)] - [(result-ok) - (infer-result-ok (cdr expr) env type-names expr)] - [(result-err) - (infer-result-err (cdr expr) env type-names expr)] - [else - (if (symbol? (car expr)) - (infer-function-call (car expr) (cdr expr) env type-names expr) - (values #f - (list (make-check-error 'unsupported-expression - "expression form is not in the typed checker subset yet" - expr))))])] - [else - (values #f - (list (make-check-error 'unsupported-expression - "expression is not in the typed checker subset yet" - expr)))])) + (let ([value (expr-value expr)]) + (cond + [(boolean? value) (values 'Bool '())] + [(char? value) (values 'Char '())] + [(string? value) (values 'String '())] + [(bytevector? value) (values 'Bytes '())] + [(integer? value) + (values (if (>= value 0) 'Nat 'Int) '())] + [(symbol? value) + (let ([type (lookup-name value env)]) + (if type + (values type '()) + (values #f + (list (error-at expr 'unknown-value + "unknown value in expression" + value)))))] + [(pair? value) + (let ([head (expr-head expr)] + [args (expr-args expr)]) + (case head + [(begin) + (infer-body args env type-names)] + [(let) + (if (< (length args) 2) + (values #f + (list (error-at expr 'bad-let + "let expects bindings and body" + expr))) + (infer-let (car args) (cdr args) env type-names expr))] + [(if) + (infer-if args env type-names expr)] + [(match) + (infer-match args env type-names expr)] + [(+ - * /) + (infer-arithmetic head args env type-names expr)] + [(= < <= > >=) + (infer-comparison head args env type-names expr)] + [(equal?) + (infer-equality args env type-names expr)] + [(debug-string) + (infer-debug-string args env type-names expr)] + [(not and or)