Add typed Kotlin throw expression
ober
c197af0ad57779d2caba08505d22ef23fc18eb9b
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -2951,6 +2951,30 @@ '())) (append fn-errors arg-errors type-errors))))))])))])) + (def (infer-throw args env type-names expr) + (cond + [(not (= (length args) 2)) + (values #f + (list (error-at expr 'bad-throw + "throw expects an exception expression and result type" + expr)))] + [else + (let* ([result-type (parse-typed-type (cadr args))] + [result-type-errors (check-type result-type type-names)]) + (let-values ([(exception-ir exception-errors) + (infer-expression (car args) env type-names)]) + (let ([ok? (and exception-ir + (null? exception-errors) + (null? result-type-errors) + (valid-type? result-type type-names))]) + (values + (and ok? + (make-typed-ir-throw + result-type + (expr-source expr) + exception-ir)) + (append exception-errors result-type-errors)))))])) + (def (infer-expression expr env type-names) (let ([value (expr-value expr)] [src (expr-source expr)]) @@ -2994,6 +3018,8 @@ (infer-let (car args) (cdr args) env type-names expr))] [(if) (infer-if args env type-names expr)] + [(throw) + (infer-throw args env type-names expr)] [(lambda) (infer-lambda args env type-names expr)] [(object) --- a/lib/jerboa/typed/core.ss +++ b/lib/jerboa/typed/core.ss @@ -39,6 +39,11 @@ typed-ir-if-type typed-ir-if-source typed-ir-if-test typed-ir-if-then typed-ir-if-else + typed-ir-throw? + make-typed-ir-throw + typed-ir-throw-type typed-ir-throw-source + typed-ir-throw-exception + typed-ir-lambda? make-typed-ir-lambda typed-ir-lambda-type typed-ir-lambda-source @@ -108,6 +113,7 @@ (defstruct typed-ir-let (type source bindings body)) (defstruct typed-ir-binding (name expr)) (defstruct typed-ir-if (type source test then else)) + (defstruct typed-ir-throw (type source exception)) (defstruct typed-ir-lambda (type source params body)) (defstruct typed-ir-object (type source super-type super-args methods)) (defstruct typed-ir-object-method @@ -230,6 +236,7 @@ (typed-ir-begin? x) (typed-ir-let? x) (typed-ir-if? x) + (typed-ir-throw? x) (typed-ir-lambda? x) (typed-ir-object? x) (typed-ir-for-fold? x) @@ -244,6 +251,7 @@ [(typed-ir-begin? node) (typed-ir-begin-type node)] [(typed-ir-let? node) (typed-ir-let-type node)] [(typed-ir-if? node) (typed-ir-if-type node)] + [(typed-ir-throw? node) (typed-ir-throw-type node)] [(typed-ir-lambda? node) (typed-ir-lambda-type node)] [(typed-ir-object? node) (typed-ir-object-type node)] [(typed-ir-for-fold? node) (typed-ir-for-fold-type node)] @@ -259,6 +267,7 @@ [(typed-ir-begin? node) (typed-ir-begin-source node)] [(typed-ir-let? node) (typed-ir-let-source node)] [(typed-ir-if? node) (typed-ir-if-source node)] + [(typed-ir-throw? node) (typed-ir-throw-source node)] [(typed-ir-lambda? node) (typed-ir-lambda-source node)] [(typed-ir-object? node) (typed-ir-object-source node)] [(typed-ir-for-fold? node) (typed-ir-for-fold-source node)] --- a/lib/jerboa/typed/kotlin/ast.ss +++ b/lib/jerboa/typed/kotlin/ast.ss @@ -85,6 +85,9 @@ kt-if? make-kt-if kt-if-test kt-if-then kt-if-else + kt-throw? make-kt-throw + kt-throw-exception + kt-block? make-kt-block kt-block-statements kt-block-result @@ -139,6 +142,7 @@ (defstruct kt-binary (op left right)) (defstruct kt-unary (op expr)) (defstruct kt-if (test then else)) + (defstruct kt-throw (exception)) (defstruct kt-block (statements result)) (defstruct kt-new (type args)) (defstruct kt-when (subject branches)) --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -797,6 +797,8 @@ (lower-expr (typed-ir-if-test ir)) (lower-expr (typed-ir-if-then ir)) (lower-expr (typed-ir-if-else ir)))] + [(typed-ir-throw? ir) + (make-kt-throw (lower-expr (typed-ir-throw-exception ir)))] [(typed-ir-lambda? ir) (lower-lambda ir)] [(typed-ir-object? ir) --- a/lib/jerboa/typed/kotlin/print.ss +++ b/lib/jerboa/typed/kotlin/print.ss @@ -332,6 +332,8 @@ (kotlin-expr->string (kt-if-then expr)) " else " (kotlin-expr->string (kt-if-else expr)))] + [(kt-throw? expr) + (string-append "throw " (kotlin-expr->string (kt-throw-exception expr)))] [(kt-block? expr) (emit-to-string (lambda (port) --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -135,6 +135,14 @@ "\n" "}")) +(test "throw expression printer" + (kotlin-expr->string + (make-kt-throw + (make-kt-call + (make-kt-name '(CertificateException)) + (list (make-kt-lit 'String "bad"))))) + "throw CertificateException(\"bad\")") + (define ast-file-text (string-append "// Generated by Jerboa's typed Kotlin backend. Do not edit.\n\n" @@ -482,6 +490,26 @@ object-constructor-kotlin "return object : ScaleListener(step) {") +(define throw-form + '(typed-library (sample typed throwexpr) + (export failUnit nameOrThrow) + (type CertificateException) + (extern (certificateException (message : String)) : CertificateException + (kotlin-call CertificateException)) + (def (failUnit) : Unit + (throw (certificateException "bad") Unit)) + (def (nameOrThrow (ok : Bool)) : String + (if ok + "ok" + (throw (certificateException "bad") String))))) + +(define throw-kotlin + (typed-library-form->kotlin-string throw-form)) + +(test-contains "typed throw expression lowers to Kotlin throw" + throw-kotlin + "throw CertificateException(\"bad\")") + (define geometry-form '(typed-library (sample typed geometry) (export make-SsdCell SsdCell? SsdCell-x SsdCell-y SsdCell-w SsdCell-h