Add typed mutable loop control flow
ober
2ebcd02622f1a37f706e7628907494f6bbffc4bc
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -317,7 +317,22 @@ (def (lookup-name name env) (let ([entry (assq name env)]) - (and entry (cdr entry)))) + (and entry + (let ([value (cdr entry)]) + (if (and (pair? value) + (eq? (car value) '*mutable-local*)) + (cadr value) + value))))) + + (def (mutable-local-value type) + (list '*mutable-local* type)) + + (def (lookup-mutable-local? name env) + (let ([entry (assq name env)]) + (and entry + (let ([value (cdr entry)]) + (and (pair? value) + (eq? (car value) '*mutable-local*)))))) (def (borrow-type? type) (and (pair? type) @@ -862,6 +877,9 @@ (def (extend-env name type env) (cons (cons name type) env)) + (def (extend-env/mutable name type env) + (cons (cons name (mutable-local-value type)) env)) + (def (symbol-list? xs) (and (list? xs) (let loop ([rest xs]) @@ -954,6 +972,104 @@ ir-bindings) (append (reverse value-errors) errors)))))))))])) + (def (infer-mutable-let bindings body env type-names expr) + (cond + [(not (expr-list? bindings)) + (values #f + (list (error-at expr 'bad-var-binding + "var bindings must be a list" + expr)))] + [else + (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 binding-list] + [local-env env] + [ir-bindings '()] + [errors '()]) + (if (null? rest) + (let-values ([(body-ir body-errors) + (infer-body body local-env type-names + (expr-source expr))]) + (let ([body-type (ir-type body-ir)]) + (values + (and body-type + (make-typed-ir-mutable-let body-type (expr-source expr) + (reverse ir-bindings) + (if body-ir + (typed-ir-begin-exprs body-ir) + '()))) + (append (reverse errors) body-errors)))) + (let* ([binding (car rest)] + [binding-value (expr-value binding)] + [name (expr-value (car binding-value))] + [value-expr (cadr binding-value)]) + (let-values ([(value-ir value-errors) + (infer-expression value-expr env type-names)]) + (let ([value-type (ir-type value-ir)]) + (loop (cdr rest) + (if value-type + (extend-env/mutable name value-type local-env) + local-env) + (cons (make-typed-ir-binding name value-ir) + ir-bindings) + (append (reverse value-errors) errors)))))))))])) + + (def (infer-set args env type-names expr) + (cond + [(not (= (length args) 2)) + (values #f + (list (error-at expr 'bad-set + "set! expects a local name and value expression" + expr)))] + [(not (expr-symbol? (car args))) + (values #f + (list (error-at expr 'bad-set + "set! target must be a local name" + expr)))] + [else + (let* ([name (expr-value (car args))] + [target-type (lookup-name name env)] + [mutable? (lookup-mutable-local? name env)]) + (let-values ([(value-ir value-errors) + (infer-expression (cadr args) env type-names)]) + (let* ([value-type (ir-type value-ir)] + [target-errors + (cond + [(not target-type) + (list (error-at expr 'unknown-value + "unknown local name in set!" + name))] + [(not mutable?) + (list (error-at expr 'immutable-local + "set! target must be introduced by var" + name))] + [(and value-type + (not (type-assignable? value-type target-type))) + (list (error-at expr 'assignment-type-mismatch + "set! value does not match local type" + (list name target-type value-type)))] + [else '()])] + [ok? (and value-ir + target-type + mutable? + (null? value-errors) + (null? target-errors))]) + (values + (and ok? + (make-typed-ir-set + 'Unit + (expr-source expr) + name + value-ir)) + (append value-errors target-errors)))))])) + (def (infer-if args env type-names expr) (if (not (= (length args) 3)) (values #f @@ -990,6 +1106,51 @@ (append cond-errors then-errors else-errors condition-errors branch-errors)))))) + (def (infer-while args env type-names expr) + (cond + [(null? args) + (values #f + (list (error-at expr 'bad-while + "while expects a condition and body" + expr)))] + [else + (let-values ([(test-ir test-errors) + (infer-expression (car args) env type-names)] + [(body-ir body-errors) + (infer-body (cdr args) env type-names + (expr-source expr))]) + (let* ([test-type (ir-type test-ir)] + [body-type (ir-type body-ir)] + [test-type-errors + (if (and test-type (not (equal? test-type 'Bool))) + (list (error-at expr 'condition-type-mismatch + "while condition must be Bool" + test-type)) + '())] + [body-type-errors + (if (and body-type (not (equal? body-type 'Unit))) + (list (error-at expr 'while-body-type-mismatch + "while body must be Unit" + body-type)) + '())] + [ok? (and test-ir + body-ir + (equal? test-type 'Bool) + (equal? body-type 'Unit) + (null? test-errors) + (null? body-errors) + (null? test-type-errors) + (null? body-type-errors))]) + (values + (and ok? + (make-typed-ir-while + 'Unit + (expr-source expr) + test-ir + body-ir)) + (append test-errors body-errors + test-type-errors body-type-errors))))])) + (def (lambda-param-value param) (strip-source-annotations param)) @@ -2794,6 +2955,14 @@ (if (< (length args) 2) (values moved '()) (check-let-ownership (car args) (cdr args) env moved expr))] + [(var) + (if (< (length args) 2) + (values moved '()) + (check-let-ownership (car args) (cdr args) env moved expr))] + [(set!) + (if (= (length args) 2) + (check-ownership-expression (cadr args) env moved) + (values moved '()))] [(if) (if (= (length args) 3) (let-values ([(after-cond cond-errors) @@ -2805,6 +2974,17 @@ (values after-cond (append cond-errors then-errors else-errors))) (values moved '()))] + [(while) + (if (null? args) + (values moved '()) + (let-values ([(after-cond cond-errors) + (check-ownership-expression (car args) env moved)] + [(_body body-errors) + (check-ownership-body (cdr args) env moved)]) + (values after-cond + (append cond-errors body-errors))))] + [(break continue) + (values moved '())] [(try) (if (= (length args) 2) (let ([catch-form (expr-value (cadr args))]) @@ -3101,8 +3281,33 @@ "let expects bindings and body" expr))) (infer-let (car args) (cdr args) env type-names expr))] + [(var) + (if (< (length args) 2) + (values #f + (list (error-at expr 'bad-var + "var expects bindings and body" + expr))) + (infer-mutable-let (car args) (cdr args) env type-names expr))] + [(set!) + (infer-set args env type-names expr)] [(if) (infer-if args env type-names expr)] + [(while) + (infer-while args env type-names expr)] + [(break) + (if (null? args) + (values (make-typed-ir-break 'Unit (expr-source expr)) '()) + (values #f + (list (error-at expr 'bad-break + "break expects no operands" + expr))))] + [(continue) + (if (null? args) + (values (make-typed-ir-continue 'Unit (expr-source expr)) '()) + (values #f + (list (error-at expr 'bad-continue + "continue expects no operands" + expr))))] [(throw) (infer-throw args env type-names expr)] [(try) --- a/lib/jerboa/typed/core.ss +++ b/lib/jerboa/typed/core.ss @@ -30,15 +30,38 @@ typed-ir-let-type typed-ir-let-source typed-ir-let-bindings typed-ir-let-body + typed-ir-mutable-let? + make-typed-ir-mutable-let + typed-ir-mutable-let-type typed-ir-mutable-let-source + typed-ir-mutable-let-bindings typed-ir-mutable-let-body + typed-ir-binding? make-typed-ir-binding typed-ir-binding-name typed-ir-binding-expr + typed-ir-set? + make-typed-ir-set + typed-ir-set-type typed-ir-set-source + typed-ir-set-name typed-ir-set-expr + typed-ir-if? make-typed-ir-if typed-ir-if-type typed-ir-if-source typed-ir-if-test typed-ir-if-then typed-ir-if-else + typed-ir-while? + make-typed-ir-while + typed-ir-while-type typed-ir-while-source + typed-ir-while-test typed-ir-while-body + + typed-ir-break? + make-typed-ir-break + typed-ir-break-type typed-ir-break-source + + typed-ir-continue? + make-typed-ir-continue + typed-ir-continue-type typed-ir-continue-source + typed-ir-throw? make-typed-ir-throw typed-ir-throw-type typed-ir-throw-source @@ -117,8 +140,13 @@ (defstruct typed-ir-var (type source name)) (defstruct typed-ir-begin (type source exprs)) (defstruct typed-ir-let (type source bindings body)) + (defstruct typed-ir-mutable-let (type source bindings body)) (defstruct typed-ir-binding (name expr)) + (defstruct typed-ir-set (type source name expr)) (defstruct typed-ir-if (type source test then else)) + (defstruct typed-ir-while (type source test body)) + (defstruct typed-ir-break (type source)) + (defstruct typed-ir-continue (type source)) (defstruct typed-ir-throw (type source exception)) (defstruct typed-ir-try (type source body catch-name catch-type catch-body)) (defstruct typed-ir-lambda (type source params body)) @@ -242,7 +270,12 @@ (typed-ir-var? x) (typed-ir-begin? x) (typed-ir-let? x) + (typed-ir-mutable-let? x) + (typed-ir-set? x) (typed-ir-if? x) + (typed-ir-while? x) + (typed-ir-break? x) + (typed-ir-continue? x) (typed-ir-throw? x) (typed-ir-try? x) (typed-ir-lambda? x) @@ -258,7 +291,12 @@ [(typed-ir-var? node) (typed-ir-var-type node)] [(typed-ir-begin? node) (typed-ir-begin-type node)] [(typed-ir-let? node) (typed-ir-let-type node)] + [(typed-ir-mutable-let? node) (typed-ir-mutable-let-type node)] + [(typed-ir-set? node) (typed-ir-set-type node)] [(typed-ir-if? node) (typed-ir-if-type node)] + [(typed-ir-while? node) (typed-ir-while-type node)] + [(typed-ir-break? node) (typed-ir-break-type node)] + [(typed-ir-continue? node) (typed-ir-continue-type node)] [(typed-ir-throw? node) (typed-ir-throw-type node)] [(typed-ir-try? node) (typed-ir-try-type node)] [(typed-ir-lambda? node) (typed-ir-lambda-type node)] @@ -275,7 +313,12 @@ [(typed-ir-var? node) (typed-ir-var-source node)] [(typed-ir-begin? node) (typed-ir-begin-source node)] [(typed-ir-let? node) (typed-ir-let-source node)] + [(typed-ir-mutable-let? node) (typed-ir-mutable-let-source node)] + [(typed-ir-set? node) (typed-ir-set-source node)] [(typed-ir-if? node) (typed-ir-if-source node)] + [(typed-ir-while? node) (typed-ir-while-source node)] + [(typed-ir-break? node) (typed-ir-break-source node)] + [(typed-ir-continue? node) (typed-ir-continue-source node)] [(typed-ir-throw? node) (typed-ir-throw-source node)] [(typed-ir-try? node) (typed-ir-try-source node)] [(typed-ir-lambda? node) (typed-ir-lambda-source node)] --- a/lib/jerboa/typed/kotlin/ast.ss +++ b/lib/jerboa/typed/kotlin/ast.ss @@ -49,9 +49,16 @@ kt-for-range-var kt-for-range-start kt-for-range-end kt-for-range-body + kt-while? make-kt-while + kt-while-test kt-while-body + kt-expr-stmt? make-kt-expr-stmt kt-expr-stmt-expr + kt-break? make-kt-break + + kt-continue? make-kt-continue + kt-lit? make-kt-lit kt-lit-type kt-lit-value @@ -134,9 +141,12 @@ (defstruct kt-val (mutable? name type init)) (defstruct kt-assign (target expr)) (defstruct kt-for-range (var start end body)) + (defstruct kt-while (test body)) (defstruct kt-expr-stmt (expr)) ;; Expressions. + (defstruct kt-break ()) + (defstruct kt-continue ()) (defstruct kt-lit (type value)) (defstruct kt-name (parts)) (defstruct kt-call (callee args)) --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -723,6 +723,34 @@ (typed-ir-let-bindings ir)) (lower-begin (typed-ir-let-body ir)))) + (def (lower-mutable-let ir) + (make-kt-block + (map (lambda (binding) + (make-kt-val + #t + (typed-ir-binding-name binding) + (typed-type->kotlin-type + (typed-ir-node-type (typed-ir-binding-expr binding))) + (lower-expr (typed-ir-binding-expr binding)))) + (typed-ir-mutable-let-bindings ir)) + (lower-begin (typed-ir-mutable-let-body ir)))) + + (def (lower-set ir) + (make-kt-block + (list + (make-kt-assign + (kt-name1 (typed-ir-set-name ir)) + (lower-expr (typed-ir-set-expr ir)))) + (make-kt-lit 'Unit '()))) + + (def (lower-while ir) + (make-kt-block + (list + (make-kt-while + (lower-expr (typed-ir-while-test ir)) + (lower-unit-statements (typed-ir-while-body ir)))) + (make-kt-lit 'Unit '()))) + (def (lower-for-fold ir) (let ([acc-name (typed-ir-for-fold-acc-name ir)]) (make-kt-block @@ -792,11 +820,21 @@ (lower-begin (typed-ir-begin-exprs ir))] [(typed-ir-let? ir) (lower-let ir)] + [(typed-ir-mutable-let? ir) + (lower-mutable-let ir)] + [(typed-ir-set? ir) + (lower-set ir)] [(typed-ir-if? ir) (make-kt-if (lower-expr (typed-ir-if-test ir)) (lower-expr (typed-ir-if-then ir)) (lower-expr (typed-ir-if-else ir)))] + [(typed-ir-while? ir) + (lower-while ir)] + [(typed-ir-break? ir) + (make-kt-break)] + [(typed-ir-continue? ir) + (make-kt-continue)] [(typed-ir-throw? ir) (make-kt-throw (lower-expr (typed-ir-throw-exception ir)))] [(typed-ir-try? ir) @@ -829,6 +867,38 @@ (cond [(typed-ir-begin? ir) (append-map lower-unit-statements (typed-ir-begin-exprs ir))] + [(typed-ir-let? ir) + (append + (map (lambda (binding) + (make-kt-val + #f + (typed-ir-binding-name binding) + (typed-type->kotlin-type + (typed-ir-node-type (typed-ir-binding-expr binding))) + (lower-expr (typed-ir-binding-expr binding)))) + (typed-ir-let-bindings ir)) + (append-map lower-unit-statements (typed-ir-let-body ir)))] + [(typed-ir-mutable-let? ir) + (append + (map (lambda (binding) + (make-kt-val + #t + (typed-ir-binding-name binding) + (typed-type->kotlin-type + (typed-ir-node-type (typed-ir-binding-expr binding))) + (lower-expr (typed-ir-binding-expr binding)))) + (typed-ir-mutable-let-bindings ir)) + (append-map lower-unit-statements (typed-ir-mutable-let-body ir)))] + [(typed-ir-set? ir) + (list + (make-kt-assign + (kt-name1 (typed-ir-set-name ir)) + (lower-expr (typed-ir-set-expr ir))))] + [(typed-ir-while? ir) + (list + (make-kt-while + (lower-expr (typed-ir-while-test ir)) + (lower-unit-statements (typed-ir-while-body ir))))] [(and (typed-ir-call? ir) (eq? (typed-ir-call-kind ir) 'record-setter)) (list (lower-record-setter-statement ir))] --- a/lib/jerboa/typed/kotlin/print.ss +++ b/lib/jerboa/typed/kotlin/print.ss @@ -267,6 +267,8 @@ (def (kotlin-expr->string expr) (cond [(kt-lit? expr) (kotlin-lit->string expr)] + [(kt-break? expr) "break"] + [(kt-continue? expr) "continue"] [(kt-name? expr) (kotlin-name->string expr)] [(kt-call? expr) (string-append @@ -429,6 +431,15 @@ (for-each (lambda (body-stmt) (write-statement port (+ indent 1) body-stmt)) (kt-for-range-body stmt)) (write-line port indent "}")] + [(kt-while? stmt) + (write-line port indent + (string-append + "while (" + (kotlin-expr->string (kt-while-test stmt)) + ") {")) + (for-each (lambda (body-stmt) (write-statement port (+ indent 1) body-stmt)) + (kt-while-body stmt)) + (write-line port indent "}")] [(kt-expr-stmt? stmt) (write-line port indent (kotlin-expr->string (kt-expr-stmt-expr stmt)))] [else (error 'write-statement "unsupported Kotlin statement" stmt)])) --- a/lib/jerboa/typed/rust.ss +++ b/lib/jerboa/typed/rust.ss @@ -1587,7 +1587,12 @@ [(typed-ir-var? ir) (rust-symbol-name (typed-ir-var-name ir))] [(typed-ir-begin? ir) (emit-begin (typed-ir-begin-exprs ir))] [(typed-ir-let? ir) (emit-ir-let ir)] + [(typed-ir-mutable-let? ir) (emit-ir-mutable-let ir)] + [(typed-ir-set? ir) (emit-ir-set ir)] [(typed-ir-if? ir) (emit-ir-if ir)] + [(typed-ir-while? ir) (emit-ir-while ir)] + [(typed-ir-break? ir) "break"] + [(typed-ir-continue? ir) "continue"] [(typed-ir-for-fold? ir) (emit-ir-for-fold ir)] [(typed-ir-bytes-build? ir) (emit-ir-bytes-build ir)] [(typed-ir-match? ir) (emit-ir-match ir)] @@ -1612,6 +1617,33 @@ " ") " }")) + (def (emit-ir-mutable-let ir) + (string-append + "{ " + (rust-inline-source-comment (typed-ir-node-source ir)) + (join-strings + (append + (map (lambda (binding) + (string-append + "let mut " + (rust-symbol-name (typed-ir-binding-name binding)) + " = " + (emit-expression (typed-ir-binding-expr binding)) + ";")) + (typed-ir-mutable-let-bindings ir)) + (list (emit-begin (typed-ir-mutable-let-body ir)))) + " ") + " }")) + + (def (emit-ir-set ir) + (string-append + "{ " + (rust-inline-source-comment (typed-ir-node-source ir)) + (rust-symbol-name (typed-ir-set-name ir)) + " = " + (emit-expression (typed-ir-set-expr ir)) + "; () }")) + (def (emit-ir-if ir) (string-append (rust-inline-source-comment (typed-ir-node-source ir)) @@ -1623,6 +1655,16 @@ (emit-expression (typed-ir-if-else ir)) " }")) + (def (emit-ir-while ir) + (string-append + "{ " + (rust-inline-source-comment (typed-ir-node-source ir)) + "while " + (emit-expression (typed-ir-while-test ir)) + " { " + (emit-expression (typed-ir-while-body ir)) + "; } () }")) + ;; (for/fold ([acc init]) ([i (in-range start end)]) body) lowers to a block ;; that seeds a mutable accumulator, runs a Rust `for` over the half-open ;; range, reassigns the accumulator from the body each step, and yields it. --- a/tests/test-typed-checker.ss +++ b/tests/test-typed-checker.ss @@ -439,7 +439,7 @@ x (catch (error : Exception) "bad"))))) - '(branch-type-mismatch return-type-mismatch)) + '(branch-type-mismatch)) (test "try catch bad shape" (error-kinds @@ -1963,6 +1963,59 @@ (map elaborated-def-name consumer-defs))) '(use-inc use-pair use-tag)) +(test "mutable locals and while typecheck" + (error-kinds + '(typed-library (control flow) + (export countTo) + (type Int32) + (def (countTo (end : Int32)) : Int32 + (var ((x (int32 0))) + (begin + (while (< x end) + (set! x (+ x (int32 1)))) + x))))) + '()) + +(test "set! rejects immutable let locals" + (error-kinds + '(typed-library (control immutable) + (export f) + (type Int32) + (def (f) : Unit + (let ((x (int32 0))) + (set! x (int32 1)))))) + '(immutable-local)) + +(test "set! rejects mismatched value type" + (error-kinds + '(typed-library (control set-type) + (export f) + (type Int32) + (def (f) : Unit + (var ((x (int32 0))) + (set! x "wrong"))))) + '(assignment-type-mismatch)) + +(test "while rejects non-Bool condition" + (error-kinds + '(typed-library (control while-cond) + (export f) + (type Int32) + (def (f) : Unit + (while (int32 1) + (begin))))) + '(condition-type-mismatch)) + +(test "while rejects non-Unit body" + (error-kinds + '(typed-library (control while-body) + (export f) + (type Int32) + (def (f) : Unit + (while #t + (int32 1))))) + '(while-body-type-mismatch)) + (printf "~%Typed checker: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1)) --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -1330,5 +1330,40 @@ (test-contains "String compare-to lowers to Kotlin compareTo" ocr-string-kotlin "a.lowercase().compareTo(b.lowercase())") +(define control-flow-form + '(typed-library (sample typed control) + (export countTo skipOrStop) + (type Int32) + (def (countTo (end : Int32)) : Int32 + (var ((x (int32 0))) + (begin + (while (< x end) + (set! x (+ x (int32 1)))) + x))) + (def (skipOrStop (read : Int32)) : Unit + (while #t + (begin + (if (= read (int32 0)) (break) (begin)) + (if (< read (int32 0)) (continue) (begin))))))) + +(define control-flow-kotlin + (typed-library-form->kotlin-string control-flow-form)) + +(test-contains "mutable local lowers to Kotlin var" + control-flow-kotlin + "var x: Int = 0") +(test-contains "while lowers to Kotlin loop" + control-flow-kotlin + "while ((x < end)) {") +(test-contains "set! lowers to Kotlin assignment" + control-flow-kotlin + "x = (x + 1)") +(test-contains "break lowers in loop body" + control-flow-kotlin + "if ((read == 0)) break else Unit") +(test-contains "continue lowers in loop body" + control-flow-kotlin + "if ((read < 0)) continue else Unit") + (printf "typed-kotlin tests: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1)) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -856,6 +856,31 @@ "pub fn inc(x: u64) -> u64")) #t) +(define control-flow-form + '(typed-library (sample typed control) + (export count-to) + (def (count-to (end : Nat)) : Nat + (var ((x 0)) + (begin + (while (< x end) + (set! x (+ x 1))) + x))))) + +(define control-flow-rust + (typed-library-form->rust-string control-flow-form)) + +(test "mutable local lowers to Rust let mut" + (substring? control-flow-rust "let mut x = 0u64;") + #t) + +(test "while lowers to Rust loop" + (substring? control-flow-rust "while (x < end)") + #t) + +(test "set! lowers to Rust assignment" + (substring? control-flow-rust "x = (x + 1u64);") + #t) + (printf "~%Typed Rust emitter: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))