Add Kotlin FloatArray interop helpers
ober
a7491bbb339d09bee93fd657b1188a657ce974bb
--- a/docs/typed-kotlin.md +++ b/docs/typed-kotlin.md @@ -23,6 +23,15 @@ ML Kit models. The Kotlin backend also accepts `(MutableList T)` for JVM APIs and Android model objects that require mutable Kotlin collections, and `(Nullable T)` for Kotlin nullable types such as `FloatArray?`. +JVM-sized numeric and array helpers are explicit typed forms: + +- `(float32 value)` narrows any numeric value to Kotlin `Float`. +- `(int32 value)` narrows any numeric value to Kotlin `Int`. +- `(float-array value ...)` produces a Kotlin `FloatArray`; each value must be + `Float32`. +- `(float-array-ref array index)` reads a `Float32` from a `FloatArray` at an + `Int32` index. + Public entry points: ```scheme --- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -392,6 +392,11 @@ (cons 'log2 (make-typed-call-sig (list 'Float) 'Float '() 'log2 '())) + ;; Kotlin/JVM interop helpers used by Android code. Conversions are + ;; inferred specially because they accept any numeric source type. + (cons 'float-array-ref + (make-typed-call-sig (list 'FloatArray 'Int32) 'Float32 '() + 'jvm-float-array-ref '())) ;; crypto primitives — FFI to vetted RustCrypto crates, never reimplemented. ;; Each carries kind 'crypto-prim and an info `prim` the emitter dispatches ;; on; the Rust block they emit references the crate (sha2/hmac/hkdf) that @@ -1006,12 +1011,14 @@ (append target-errors clause-errors)))))))) (def (numeric-type? type) - (and type (memq type '(Nat Int Fixnum Float)) #t)) + (and type (memq type '(Nat Int Fixnum Int32 Float Float32)) #t)) (def (merge-numeric-types types) (cond [(memq 'Float types) 'Float] + [(memq 'Float32 types) 'Float32] [(memq 'Int types) 'Int] + [(memq 'Int32 types) 'Int32] [(memq 'Fixnum types) 'Fixnum] [else 'Nat])) @@ -1345,6 +1352,74 @@ 'exact->inexact 'exact->inexact (list arg-ir) '())) (append errors operand-errors)))))) + (def (infer-to-float32 args env type-names expr) + ;; JVM/Android interop: explicitly narrow a numeric value to Kotlin Float. + (if (not (= (length args) 1)) + (values #f + (list (error-at expr 'bad-primitive-arity + "float32 needs exactly one operand" + expr))) + (let-values ([(arg-ir errors) (infer-expression (car args) env type-names)]) + (let* ([operand-errors + (operand-type-errors 'numeric (list (ir-type arg-ir)) + (list expr) expr)] + [ok? (and arg-ir (null? errors) (null? operand-errors))]) + (values + (and ok? + (make-typed-ir-call 'Float32 (expr-source expr) + 'jvm-to-float32 'float32 (list arg-ir) '())) + (append errors operand-errors)))))) + + (def (infer-to-int32 args env type-names expr) + ;; JVM/Android interop: explicitly narrow a numeric value to Kotlin Int. + (if (not (= (length args) 1)) + (values #f + (list (error-at expr 'bad-primitive-arity + "int32 needs exactly one operand" + expr))) + (let-values ([(arg-ir errors) (infer-expression (car args) env type-names)]) + (let* ([operand-errors + (operand-type-errors 'numeric (list (ir-type arg-ir)) + (list expr) expr)] + [ok? (and arg-ir (null? errors) (null? operand-errors))]) + (values + (and ok? + (make-typed-ir-call 'Int32 (expr-source expr) + 'jvm-to-int32 'int32 (list arg-ir) '())) + (append errors operand-errors)))))) + + (def (infer-float-array args env type-names expr) + (let-values ([(arg-irs errors) (infer-args args env type-names)]) + (let* ([types (ir-list-types arg-irs)] + [type-errors + (let loop ([rest types] [rest-exprs args] [out '()]) + (cond + [(null? rest) (reverse out)] + [(not (car rest)) + (loop (cdr rest) + (if (null? rest-exprs) '() (cdr rest-exprs)) + out)] + [(eq? (car rest) 'Float32) + (loop (cdr rest) + (if (null? rest-exprs) '() (cdr rest-exprs)) + out)] + [else + (loop (cdr rest) + (if (null? rest-exprs) '() (cdr rest-exprs)) + (cons (make-check-error 'argument-type-mismatch + "float-array values must be Float32" + expr + (and (not (null? rest-exprs)) + (expr-source (car rest-exprs)))) + out))]))] + [ok? (and (null? errors) (null? type-errors) + (all-irs-valid? arg-irs))]) + (values + (and ok? + (make-typed-ir-call 'FloatArray (expr-source expr) + 'jvm-float-array 'float-array arg-irs '())) + (append errors type-errors))))) + (def (infer-make-bytevector args env type-names expr) ;; (make-bytevector size) or (make-bytevector size fill). Size and fill are ;; numeric; the result is a fresh Bytes buffer. A missing fill defaults to a @@ -1752,6 +1827,12 @@ (infer-make-bytevector args env type-names expr)] [(exact->inexact) (infer-to-float args env type-names expr)] + [(float32) + (infer-to-float32 args env type-names expr)] + [(int32) + (infer-to-int32 args env type-names expr)] + [(float-array) + (infer-float-array args env type-names expr)] [(bytes-build) (infer-bytes-build args env type-names expr)] [(option-some) --- a/lib/jerboa/typed/kotlin/ast.ss +++ b/lib/jerboa/typed/kotlin/ast.ss @@ -66,6 +66,9 @@ kt-member-get? make-kt-member-get kt-member-get-target kt-member-get-name + kt-index-get? make-kt-index-get + kt-index-get-target kt-index-get-index + kt-binary? make-kt-binary kt-binary-op kt-binary-left kt-binary-right @@ -123,6 +126,7 @@ (defstruct kt-call (callee args)) (defstruct kt-member-call (target name args)) (defstruct kt-member-get (target name)) + (defstruct kt-index-get (target index)) (defstruct kt-binary (op left right)) (defstruct kt-unary (op expr)) (defstruct kt-if (test then else)) --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -127,7 +127,9 @@ [(eq? type 'Keyword) (make-kt-lit 'Keyword (symbol->string value))] [(eq? type 'Nat) (make-kt-lit 'Nat value)] [(or (eq? type 'Int) (eq? type 'Fixnum)) (make-kt-lit 'Int value)] + [(eq? type 'Int32) (make-kt-lit 'Int32 value)] [(eq? type 'Float) (make-kt-lit 'Float value)] + [(eq? type 'Float32) (make-kt-lit 'Float32 value)] [else (error 'lower-lit "unsupported literal type" type value)])) (def (chain-binary op args) @@ -206,6 +208,22 @@ '())] [(string-append) (chain-binary "+" args)] + [(exact->inexact) + (make-kt-member-call (car args) 'toDouble '())] + [(jvm-to-float32) + (if (and (kt-lit? (car args)) + (memq (kt-lit-type (car args)) '(Nat Int Int32 Float Float32))) + (make-kt-lit 'Float32 (kt-lit-value (car args))) + (make-kt-member-call (car args) 'toFloat '()))] + [(jvm-to-int32) + (if (and (kt-lit? (car args)) + (memq (kt-lit-type (car args)) '(Nat Int Int32))) + (make-kt-lit 'Int32 (kt-lit-value (car args))) + (make-kt-member-call (car args) 'toInt '()))] + [(jvm-float-array) + (make-kt-call (kt-name1 'floatArrayOf) args)] + [(jvm-float-array-ref) + (make-kt-index-get (car args) (cadr args))] [(bytevector-length) (make-kt-member-call (make-kt-member-get (car args) 'size) --- a/lib/jerboa/typed/kotlin/print.ss +++ b/lib/jerboa/typed/kotlin/print.ss @@ -191,7 +191,9 @@ [(String Symbol Keyword) (kotlin-string-literal value)] [(Nat) (string-append (number->string value) "uL")] [(Int Fixnum) (string-append (number->string value) "L")] + [(Int32) (number->string value)] [(Float) (number->string value)] + [(Float32) (string-append (number->string value) "f")] [(Null) "null"] [else (error 'kotlin-lit->string "unsupported literal type" type)]))) @@ -224,6 +226,12 @@ (kotlin-expr->string (kt-member-get-target expr)) "." (kotlin-symbol-name (kt-member-get-name expr)))] + [(kt-index-get? expr) + (string-append + (kotlin-expr->string (kt-index-get-target expr)) + "[" + (kotlin-expr->string (kt-index-get-index expr)) + "]")] [(kt-binary? expr) (parenthesize (string-append --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -160,5 +160,56 @@ (test-contains "Nullable lowers to Kotlin nullable type" jvm-kotlin "data class SsdSession(val sessionId: String, val ssdArea: FloatArray?)") +(define geometry-form + '(typed-library (sample typed geometry) + (export make-SsdCell SsdCell? SsdCell-x SsdCell-y SsdCell-w SsdCell-h + ssd-cell-cx ssd-cell-rect rect-overlap-area) + (type Float32) + (type FloatArray) + (type Int32) + (record SsdCell + ((x : Float32) + (y : Float32) + (w : Float32) + (h : Float32))) + (def (ssd-cell-cx (cell : SsdCell)) : Float32 + (+ (SsdCell-x cell) + (/ (SsdCell-w cell) (float32 2.0)))) + (def (ssd-cell-rect (cell : SsdCell)) : FloatArray + (float-array + (SsdCell-x cell) + (SsdCell-y cell) + (+ (SsdCell-x cell) (SsdCell-w cell)) + (+ (SsdCell-y cell) (SsdCell-h cell)))) + (def (rect-overlap-area (a : FloatArray) (b : FloatArray)) : Float32 + (let ((left (if (> (float-array-ref a (int32 0)) + (float-array-ref b (int32 0))) + (float-array-ref a (int32 0)) + (float-array-ref b (int32 0)))) + (top (if (> (float-array-ref a (int32 1)) + (float-array-ref b (int32 1))) + (float-array-ref a (int32 1)) + (float-array-ref b (int32 1)))) + (right (if (< (float-array-ref a (int32 2)) + (float-array-ref b (int32 2))) + (float-array-ref a (int32 2)) + (float-array-ref b (int32 2)))) + (bottom (if (< (float-array-ref a (int32 3)) + (float-array-ref b (int32 3))) + (float-array-ref a (int32 3)) + (float-array-ref b (int32 3))))) + (if (or (<= right left) (<= bottom top)) + (float32 0.0) + (* (- right left) (- bottom top))))))) + +(define geometry-kotlin (typed-library-form->kotlin-string geometry-form)) + +(test-contains "Float32 arithmetic stays Float" geometry-kotlin + "return (cell.x + (cell.w / 2.0f))") +(test-contains "FloatArray construction lowers to Kotlin helper" geometry-kotlin + "return floatArrayOf(cell.x, cell.y, (cell.x + cell.w), (cell.y + cell.h))") +(test-contains "FloatArray indexing lowers to brackets" geometry-kotlin + "val left: Float = if ((a[0] > b[0])) a[0] else b[0]") + (printf "typed-kotlin tests: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))