diff options
Diffstat (limited to '')
6 files changed, 159 insertions, 60 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index e45e7d807..84592d4ee 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -866,7 +866,7 @@ [valueT unboxed valueA] (analyse-input analyse fieldT valueC) _ (&;with-type-env (tc;check fieldT valueT)) - _ (&;infer Unit)] + _ (&;infer objectT)] (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA)))) _ diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index a25c67feb..f908c6c6e 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -531,7 +531,7 @@ #;None (wrap (|>. objectI ($i;CHECKCAST class) - ($i;GETFIELD class field ($t;class class (list))))))) + ($i;GETFIELD class field ($t;class unboxed (list))))))) _ (&;fail (format "Wrong syntax for '" proc "'.")))) @@ -557,18 +557,18 @@ _ (undefined))] (wrap (|>. objectI ($i;CHECKCAST class) + $i;DUP valueI ($i;unwrap primitive) - ($i;PUTFIELD class field (#$;Primitive primitive)) - ($i;string &runtime;unit)))) + ($i;PUTFIELD class field (#$;Primitive primitive))))) #;None (wrap (|>. objectI ($i;CHECKCAST class) + $i;DUP valueI - ($i;CHECKCAST class) - ($i;PUTFIELD class field ($t;class class (list))) - ($i;string &runtime;unit))))) + ($i;CHECKCAST unboxed) + ($i;PUTFIELD class field ($t;class unboxed (list))))))) _ (&;fail (format "Wrong syntax for '" proc "'.")))) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index 66dd43019..ce138ca48 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -54,6 +54,7 @@ (def: #export $Tag $;Type $t;int) (def: #export $Flag $;Type $Object) (def: #export $Datum $;Type $Object) +(def: #export $Function $;Type ($t;class function-class (list))) (def: #export logI $;Inst @@ -66,24 +67,42 @@ $;Method ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list))) -(def: variant-makeI +(def: variantI $;Inst ($i;INVOKESTATIC runtime-class "variant_make" variant-method false)) -(def: #export someI +(def: #export leftI + $;Inst + (|>. ($i;int 0) + $i;NULL + $i;DUP2_X1 + $i;POP2 + variantI)) + +(def: #export rightI $;Inst (|>. ($i;int 1) ($i;string "") $i;DUP2_X1 $i;POP2 - variant-makeI)) + variantI)) + +(def: #export someI $;Inst rightI) (def: #export noneI $;Inst (|>. ($i;int 0) $i;NULL ($i;string unit) - variant-makeI)) + variantI)) + +(def: #export partials-field Text "partials") +(def: #export apply-method Text "apply") +(def: #export num-apply-variants Nat +8) + +(def: #export (apply-signature arity) + (-> ls;Arity $;Method) + ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) (def: adt-methods $;Def @@ -372,7 +391,7 @@ ($i;ILOAD +1) $i;ISUB ## Shorten tag ($i;ALOAD +0) flagI ## Get flag ($i;ALOAD +0) datumI ## Get value - variant-makeI ## Build sum + variantI ## Build sum $i;ARETURN) update-tagI (|>. $i;ISUB ($i;ISTORE +1)) update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0)) @@ -447,6 +466,26 @@ $i;ARETURN))) ))) +(def: io-methods + $;Def + (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list)) + (<| $i;with-label (function [@from]) + $i;with-label (function [@to]) + $i;with-label (function [@handler]) + (|>. ($i;try @from @to @handler "java.lang.Throwable") + ($i;label @from) + ($i;ALOAD +0) + $i;NULL + ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false) + rightI + $i;ARETURN + ($i;label @to) + ($i;label @handler) + ($i;INVOKEVIRTUAL "java.lang.Throwable" "getMessage" ($t;method (list) (#;Some $String) (list)) false) + leftI + $i;ARETURN))) + )) + (def: generate-runtime (Meta &common;Bytecode) (do Monad<Meta> @@ -456,18 +495,11 @@ nat-methods frac-methods deg-methods - pm-methods))] + pm-methods + io-methods))] _ (&common;store-class runtime-class bytecode)] (wrap bytecode))) -(def: #export partials-field Text "partials") -(def: #export apply-method Text "apply") -(def: #export num-apply-variants Nat +8) - -(def: #export (apply-signature arity) - (-> ls;Arity $;Method) - ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) - (def: generate-function (Meta &common;Bytecode) (do Monad<Meta> diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux index baef5c42c..6fbafd1eb 100644 --- a/new-luxc/test/test/luxc/analyser/function.lux +++ b/new-luxc/test/test/luxc/analyser/function.lux @@ -100,11 +100,6 @@ (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) (meta;run (init-compiler [])) succeeds?)) - (test "Can infer recursive types for functions." - (|> (@common;with-unknown-type - (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) - (meta;run (init-compiler [])) - (check-type (type (Rec self (All [a] (-> a self))))))) )))) (context: "Function application." diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux index ad5670cbe..d1520e5b7 100644 --- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux @@ -434,7 +434,7 @@ ("jvm object null"))) (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) ("jvm object null")))) - Unit)) + (primitive org.omg.CORBA.ValueMember))) (test "jvm member virtual put (final)" (failure "jvm member virtual put" (list (code;text "javax.swing.text.html.parser.DTD") @@ -443,7 +443,7 @@ ("jvm object null"))) (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) ("jvm object null")))) - Unit)) + (primitive javax.swing.text.html.parser.DTD))) (test "jvm member virtual put (inheritance in)" (success "jvm member virtual put" (list (code;text "java.awt.GridBagConstraints") @@ -452,7 +452,7 @@ ("jvm object null"))) (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) ("jvm object null")))) - Unit)) + (primitive java.awt.GridBagConstraints))) )) (context: "Boxing/Unboxing." @@ -477,7 +477,7 @@ ("jvm object null"))) (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) ("jvm object null")))) - Unit)) + (primitive javax.accessibility.AccessibleAttributeSequence))) )) (context: "Member [Method]." diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux index 5b22bc2a1..c5aad2cae 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -389,8 +389,11 @@ #let [num-instances (list;size instances)] class-idx (|> r;nat (:: @ map (n.% num-classes))) instance-idx (|> r;nat (:: @ map (n.% num-instances))) + exception-message (r;text +5) #let [class (maybe;assume (list;nth class-idx classes)) - [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))] + [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances)) + exception-message$ (|> (#ls;Text exception-message) + (list (#ls;Text "java.lang.String")) #ls;Tuple)] sample r;int monitor r;int instance instance-gen] @@ -430,7 +433,25 @@ (#e;Error error) false))) (test "jvm object throw" - false) + (|> (do meta;Monad<Meta> + [_ @runtime;generate + sampleI (@;generate (|> (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "java.lang.Throwable") + exception-message$)) + (list) (#ls;Procedure "jvm object throw") + (#ls;Function +1 (list)) + (list) (#ls;Procedure "lux try")))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (case (:! (e;Error Top) outputG) + (#e;Error error) + (text/= exception-message error) + + (#e;Success outputG) + false) + + (#e;Error error) + false))) (test "jvm object class" (|> (do meta;Monad<Meta> [sampleI (@;generate (#ls;Procedure "jvm object class" (list (#ls;Text class))))] @@ -458,34 +479,85 @@ (#static AD int)) (context: "Member [Field]" - ($_ seq - (test "jvm member static get" - (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (#ls;Procedure "jvm member static get" (list (#ls;Text "java.util.GregorianCalendar") (#ls;Text "AD") (#ls;Text "int"))) - (list) (#ls;Procedure "jvm convert int-to-long")))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success outputG) - (i.= GregorianCalendar.AD (:! Int outputG)) - - (#e;Error error) - false))) - (test "jvm member static put" - (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure "jvm member static put" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor") - (#ls;Procedure "jvm member static get" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor"))))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success outputG) - (is @runtime;unit (:! Text outputG)) - - (#e;Error error) - false))) - (test "jvm member virtual get" - false) - (test "jvm member virtual put" - false) - )) + (<| (times +100) + (do @ + [sample-short (|> r;int (:: @ map (|>. int/abs (i.% 100)))) + sample-string (r;text +5) + other-sample-string (r;text +5) + #let [shortS (|> (#ls;Int sample-short) + (list) (#ls;Procedure "jvm convert long-to-short") + (list (#ls;Text "short")) #ls;Tuple) + stringS (|> (#ls;Text sample-string) + (list (#ls;Text "java.lang.String")) #ls;Tuple) + type-codeS (|> (#ls;Procedure "jvm object null" (list)) + (list (#ls;Text "org.omg.CORBA.TypeCode")) #ls;Tuple) + idl-typeS (|> (#ls;Procedure "jvm object null" (list)) + (list (#ls;Text "org.omg.CORBA.IDLType")) #ls;Tuple) + value-member$ (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "org.omg.CORBA.ValueMember") + stringS + stringS + stringS + stringS + type-codeS + idl-typeS + shortS))]] + ($_ seq + (test "jvm member static get" + (|> (do meta;Monad<Meta> + [sampleI (@;generate (|> (#ls;Procedure "jvm member static get" (list (#ls;Text "java.util.GregorianCalendar") (#ls;Text "AD") (#ls;Text "int"))) + (list) (#ls;Procedure "jvm convert int-to-long")))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (i.= GregorianCalendar.AD (:! Int outputG)) + + (#e;Error error) + false))) + (test "jvm member static put" + (|> (do meta;Monad<Meta> + [sampleI (@;generate (#ls;Procedure "jvm member static put" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor") + (#ls;Procedure "jvm member static get" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor"))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (is @runtime;unit (:! Text outputG)) + + (#e;Error error) + false))) + (test "jvm member virtual get" + (|> (do meta;Monad<Meta> + [sampleI (@;generate (|> value-member$ + (list (#ls;Text "org.omg.CORBA.ValueMember") + (#ls;Text "name") + (#ls;Text "java.lang.String")) + (#ls;Procedure "jvm member virtual get")))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (text/= sample-string (:! Text outputG)) + + (#e;Error error) + false))) + (test "jvm member virtual put" + (|> (do meta;Monad<Meta> + [sampleI (@;generate (|> value-member$ + (list (#ls;Text "org.omg.CORBA.ValueMember") + (#ls;Text "name") + (#ls;Text "java.lang.String") + (#ls;Text other-sample-string)) + (#ls;Procedure "jvm member virtual put") + (list (#ls;Text "org.omg.CORBA.ValueMember") + (#ls;Text "name") + (#ls;Text "java.lang.String")) + (#ls;Procedure "jvm member virtual get")))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (text/= other-sample-string (:! Text outputG)) + + (#e;Error error) + false))) + )))) (host;import java.lang.Object) |