Add typed function value invocation
ober
6d63174685d3b838c20b1b559e442e6d745ee03b
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -2732,6 +2732,73 @@ (typed-call-sig-info sig))) (append arg-errors type-errors effect-errors))))))))) + (def (function-type? type) + (and (pair? type) + (eq? (car type) '->) + (pair? (cdr type)))) + + (def (function-type-param-types type) + (let loop ([xs (cdr type)]) + (if (or (null? xs) (null? (cdr xs))) + '() + (cons (car xs) (loop (cdr xs)))))) + + (def (function-type-return-type type) + (let loop ([xs (cdr type)]) + (if (null? (cdr xs)) (car xs) (loop (cdr xs))))) + + (def (infer-function-value-invoke args env type-names expr) + (cond + [(null? args) + (values #f + (list (error-at expr 'bad-call-arity + "invoke expects a function value and zero or more arguments" + expr)))] + [else + (let-values ([(fn-ir fn-errors) + (infer-expression (car args) env type-names)]) + (let ([fn-type (ir-type fn-ir)]) + (cond + [(not (function-type? fn-type)) + (values #f + (append fn-errors + (list (error-at (car args) 'not-callable + "invoke target must have a function type" + fn-type))))] + [else + (let* ([expected-types (function-type-param-types fn-type)] + [return-type (function-type-return-type fn-type)] + [arg-exprs (cdr args)]) + (if (not (= (length arg-exprs) (length expected-types))) + (values #f + (append fn-errors + (list (error-at expr 'bad-call-arity + "function value call arity does not match type" + (list 'invoke + (length expected-types) + (length arg-exprs)))))) + (let-values ([(arg-irs arg-errors) + (infer-args arg-exprs env type-names)]) + (let* ([actual-types (ir-list-types arg-irs)] + [type-errors + (argument-type-errors + 'invoke expected-types actual-types arg-exprs)] + [ok? (and (null? fn-errors) + (null? arg-errors) + (null? type-errors) + fn-ir + (all-irs-valid? arg-irs))]) + (values + (and ok? + (make-typed-ir-call + return-type + (expr-source expr) + 'function-value + 'invoke + (cons fn-ir arg-irs) + '())) + (append fn-errors arg-errors type-errors))))))])))])) + (def (infer-expression expr env type-names) (let ([value (expr-value expr)] [src (expr-source expr)]) @@ -2777,6 +2844,8 @@ (infer-if args env type-names expr)] [(lambda) (infer-lambda args env type-names expr)] + [(invoke) + (infer-function-value-invoke args env type-names expr)] [(match) (infer-match args env type-names expr)] [(+ - * / mod) --- a/lib/jerboa/typed/core.ss +++ b/lib/jerboa/typed/core.ss @@ -119,6 +119,7 @@ (def typed-ir-call-kinds '(function + function-value prim-arith prim-cmp prim-eq --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -210,6 +210,8 @@ (case kind [(function) (make-kt-call (kt-name1 operator) args)] + [(function-value) + (make-kt-call (car args) (cdr args))] [(prim-arith) (chain-binary (arith-op operator) args)] [(prim-cmp) --- a/tests/test-typed-checker.ss +++ b/tests/test-typed-checker.ss @@ -498,6 +498,50 @@ x)))) '(return-type-mismatch)) +(test "typed function value invoke" + (error-kinds + '(typed-library (body invoke-ok) + (export apply-inc) + (type Int32) + (def (apply-inc (f : (-> Int32 Int32)) (x : Int32)) : Int32 + (invoke f x)))) + '()) + +(test "typed zero-argument function value invoke" + (error-kinds + '(typed-library (body invoke-zero-ok) + (export call-now) + (def (call-now (action : (-> Unit))) : Unit + (invoke action)))) + '()) + +(test "typed function value invoke arity mismatch" + (error-kinds + '(typed-library (body invoke-arity) + (export bad) + (type Int32) + (def (bad (f : (-> Int32 Int32))) : Int32 + (invoke f)))) + '(bad-call-arity)) + +(test "typed function value invoke argument mismatch" + (error-kinds + '(typed-library (body invoke-arg) + (export bad) + (type Int32) + (def (bad (f : (-> String String)) (x : Int32)) : String + (invoke f x)))) + '(argument-type-mismatch)) + +(test "typed function value invoke rejects non-function" + (error-kinds + '(typed-library (body invoke-non-function) + (export bad) + (type Int32) + (def (bad (x : Int32)) : Int32 + (invoke x)))) + '(not-callable)) + (test "extern kotlin call can be used from typed code" (error-kinds '(typed-library (body extern-ok) --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -336,14 +336,18 @@ (define lambda-form '(typed-library (sample typed lambdas) - (export plusOne noop) + (export plusOne noop applyNow callNow) (type Int32) (def (plusOne) : (-> Int32 Int32) (lambda ((x : Int32)) (+ x (int32 1)))) (def (noop) : (-> Unit) (lambda () - (begin))))) + (begin))) + (def (applyNow (f : (-> Int32 Int32)) (x : Int32)) : Int32 + (invoke f x)) + (def (callNow (action : (-> Unit))) : Unit + (invoke action)))) (define lambda-kotlin (typed-library-form->kotlin-string lambda-form)) @@ -363,6 +367,14 @@ lambda-kotlin "return { Unit }") +(test-contains "typed function value invocation lowers to Kotlin call" + lambda-kotlin + "return f(x)") + +(test-contains "typed zero-arg function value invocation lowers to Kotlin call" + lambda-kotlin + "action()") + (define geometry-form '(typed-library (sample typed geometry) (export make-SsdCell SsdCell? SsdCell-x SsdCell-y SsdCell-w SsdCell-h