diff options
Diffstat (limited to 'new-luxc')
7 files changed, 240 insertions, 22 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index e21281984..a4cc20400 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -193,7 +193,7 @@ (&;fail (invalid-array-type expectedT))))) _ (&;assert "Must have at least 1 level of nesting in array type." (n.> +0 level))] - (wrap (#la;Procedure proc (list (#la;Nat level) (#la;Text elem-class) lengthA)))) + (wrap (#la;Procedure proc (list (#la;Nat (n.dec level)) (#la;Text elem-class) lengthA)))) _ (&;fail (@;wrong-arity proc +1 (list;size args)))))) @@ -271,7 +271,7 @@ idxA (&;with-expected-type Nat (analyse idxC)) _ (&;infer elemT)] - (wrap (#la;Procedure proc (list (#la;Text elem-class) arrayA idxA)))) + (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA arrayA)))) _ (&;fail (@;wrong-arity proc +2 (list;size args)))))))) @@ -294,7 +294,7 @@ valueA (&;with-expected-type valueT (analyse valueC)) _ (&;infer (type (Array elemT)))] - (wrap (#la;Procedure proc (list (#la;Text elem-class) arrayA idxA valueA)))) + (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA valueA arrayA)))) _ (&;fail (@;wrong-arity proc +3 (list;size args)))))))) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index 7a6215804..efc66f130 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -42,6 +42,15 @@ DADD DSUB DMUL DDIV DREM DCMPG DCMPL) <bit-wise> (declare IAND IOR IXOR ISHL ISHR IUSHR LAND LOR LXOR LSHL LSHR LUSHR) + <array> (declare ARRAYLENGTH NEWARRAY ANEWARRAY + AALOAD AASTORE + BALOAD BASTORE + SALOAD SASTORE + IALOAD IASTORE + LALOAD LASTORE + FALOAD FASTORE + DALOAD DASTORE + CALOAD CASTORE) <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)] (host;import org.objectweb.asm.Opcodes (#static NOP int) @@ -51,8 +60,6 @@ (#static CHECKCAST int) (#static NEW int) - (#static NEWARRAY int) - (#static ANEWARRAY int) <stack> <jump> @@ -64,9 +71,7 @@ <arithmethic> <bit-wise> - (#static AALOAD int) - (#static AASTORE int) - (#static ARRAYLENGTH int) + <array> (#static GETSTATIC int) (#static PUTSTATIC int) @@ -178,7 +183,15 @@ [DCMPG] [DCMPL] ## Array - [AALOAD] [AASTORE] [ARRAYLENGTH] + [ARRAYLENGTH] + [AALOAD] [AASTORE] + [BALOAD] [BASTORE] + [SALOAD] [SASTORE] + [IALOAD] [IASTORE] + [LALOAD] [LASTORE] + [FALOAD] [FASTORE] + [DALOAD] [DASTORE] + [CALOAD] [CASTORE] ## Exceptions [ATHROW] @@ -230,7 +243,7 @@ (do-to visitor (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type #$;Boolean Opcodes.T_BOOLEAN - #$;Byte Opcodes.T_SHORT + #$;Byte Opcodes.T_BYTE #$;Short Opcodes.T_SHORT #$;Int Opcodes.T_INT #$;Long Opcodes.T_LONG @@ -289,12 +302,11 @@ (do-to visitor (MethodVisitor.visitLabel [@label])))) -(def: #export (array type size) - (-> $;Type Nat $;Inst) +(def: #export (array type) + (-> $;Type $;Inst) (case type (#$;Primitive prim) - (|>. (int (nat-to-int size)) - (NEWARRAY prim)) + (NEWARRAY prim) (#$;Generic generic) (let [elem-class (case generic @@ -303,12 +315,10 @@ _ ($t;binary-name "java.lang.Object"))] - (|>. (int (nat-to-int size)) - (ANEWARRAY elem-class))) + (ANEWARRAY elem-class)) _ - (|>. (int (nat-to-int size)) - (ANEWARRAY ($t;descriptor type))))) + (ANEWARRAY ($t;descriptor type)))) (def: (primitive-wrapper type) (-> $;Primitive Text) diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index 70f38f962..e3a46a9ea 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -81,8 +81,8 @@ (do @ [g!input+ (monad;seq @ (list;repeat arity (macro;gensym "input")))] (wrap (list (` (def: #export ((~ (code;local-symbol name)) (~ g!proc)) - (-> (-> (Vector (~ (code;nat arity)) $;Inst) $;Inst) - (-> Text Proc)) + (-> (-> (;;Vector (~ (code;nat arity)) $;Inst) $;Inst) + (-> Text ;;Proc)) (function [(~ g!name)] (function [(~ g!generate) (~ g!inputs)] (case (~ g!inputs) diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index c99c23385..128e8b517 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -261,6 +261,102 @@ (@;install "<" (@;binary char//<)) ))) +(def: (array//length arrayI) + @;Unary + (|>. arrayI + $i;ARRAYLENGTH + $i;I2L + ($i;wrap #$;Long))) + +(def: (array//new proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list (#ls;Nat level) (#ls;Text class) lengthS)) + (do macro;Monad<Lux> + [lengthI (generate lengthS) + #let [arrayJT ($t;array level (case class + "boolean" $t;boolean + "byte" $t;byte + "short" $t;short + "int" $t;int + "long" $t;long + "float" $t;float + "double" $t;double + "char" $t;char + _ ($t;class class (list))))]] + (wrap (|>. lengthI + ($i;unwrap #$;Long) + $i;L2I + ($i;array arrayJT)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (array//read proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list (#ls;Text class) idxS arrayS)) + (do macro;Monad<Lux> + [arrayI (generate arrayS) + idxI (generate idxS) + #let [loadI (case class + "boolean" (|>. $i;BALOAD ($i;wrap #$;Boolean)) + "byte" (|>. $i;BALOAD ($i;wrap #$;Byte)) + "short" (|>. $i;SALOAD ($i;wrap #$;Short)) + "int" (|>. $i;IALOAD ($i;wrap #$;Int)) + "long" (|>. $i;LALOAD ($i;wrap #$;Long)) + "float" (|>. $i;FALOAD ($i;wrap #$;Float)) + "double" (|>. $i;DALOAD ($i;wrap #$;Double)) + "char" (|>. $i;CALOAD ($i;wrap #$;Char)) + _ $i;AALOAD)]] + (wrap (|>. arrayI + idxI + ($i;unwrap #$;Long) + $i;L2I + loadI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (array//write proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list (#ls;Text class) idxS valueS arrayS)) + (do macro;Monad<Lux> + [arrayI (generate arrayS) + idxI (generate idxS) + valueI (generate valueS) + #let [storeI (case class + "boolean" (|>. ($i;unwrap #$;Boolean) $i;BASTORE) + "byte" (|>. ($i;unwrap #$;Byte) $i;BASTORE) + "short" (|>. ($i;unwrap #$;Short) $i;SASTORE) + "int" (|>. ($i;unwrap #$;Int) $i;IASTORE) + "long" (|>. ($i;unwrap #$;Long) $i;LASTORE) + "float" (|>. ($i;unwrap #$;Float) $i;FASTORE) + "double" (|>. ($i;unwrap #$;Double) $i;DASTORE) + "char" (|>. ($i;unwrap #$;Char) $i;CASTORE) + _ $i;AASTORE)]] + (wrap (|>. arrayI + $i;DUP + idxI + ($i;unwrap #$;Long) + $i;L2I + valueI + storeI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: array-procs + @;Bundle + (<| (@;prefix "array") + (|> (dict;new text;Hash<Text>) + (@;install "length" (@;unary array//length)) + (@;install "new" array//new) + (@;install "read" array//read) + (@;install "write" array//write) + ))) + (def: #export procedures @;Bundle (<| (@;prefix "jvm") @@ -271,4 +367,5 @@ (dict;merge float-procs) (dict;merge double-procs) (dict;merge char-procs) + (dict;merge array-procs) ))) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index c073e7da0..4c8784364 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -94,7 +94,8 @@ ($t;method (list $t;int $Object $Object) (#;Some $Variant) (list)) - (|>. ($i;array $Object +3) + (|>. ($i;int 3) + ($i;array $Object) store-tagI store-flagI store-valueI diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux index a89f3083f..6aca0dca1 100644 --- a/new-luxc/source/luxc/generator/structure.jvm.lux +++ b/new-luxc/source/luxc/generator/structure.jvm.lux @@ -36,7 +36,9 @@ memberI $i;AASTORE))))) (:: @ map $i;fuse))] - (wrap (|>. ($i;array $Object size) membersI)))) + (wrap (|>. ($i;int (nat-to-int size)) + ($i;array $Object) + membersI)))) (def: (flagI tail?) (-> Bool $;Inst) 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 67fbbceda..6371286a6 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -233,3 +233,111 @@ ["char" gen-int #ls;Int i.= i.< (|>. (list) (#ls;Procedure "jvm convert long-to-int") (list) (#ls;Procedure "jvm convert int-to-char"))] ) + +(context: "Array [Part 1]" + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1)))) + idx (|> r;nat (:: @ map (n.% size))) + valueZ r;bool + valueB gen-int + valueS gen-int + valueI gen-int + valueL r;int + valueF gen-frac + valueD r;frac + valueC gen-int] + (with-expansions [<array> (do-template [<class> <type> <value> <test> <input> <post>] + [(test <class> + (|> (do macro;Monad<Lux> + [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text <class>) (#ls;Nat size))) + (list (#ls;Text <class>) (#ls;Nat idx) <input>) (#ls;Procedure "jvm array write") + (list (#ls;Text <class>) (#ls;Nat idx)) (#ls;Procedure "jvm array read") + <post>))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputZ) + (<test> <value> (:! <type> outputZ)) + + (#R;Error error) + false)))] + + ["boolean" Bool valueZ bool/= (#ls;Bool valueZ) id] + ["byte" Int valueB i.= (|> (#ls;Int valueB) + (list) (#ls;Procedure "jvm convert long-to-byte")) + (<| (#ls;Procedure "jvm convert byte-to-long") (list))] + ["short" Int valueS i.= (|> (#ls;Int valueS) + (list) (#ls;Procedure "jvm convert long-to-short")) + (<| (#ls;Procedure "jvm convert short-to-long") (list))] + ["int" Int valueI i.= (|> (#ls;Int valueI) + (list) (#ls;Procedure "jvm convert long-to-int")) + (<| (#ls;Procedure "jvm convert int-to-long") (list))] + ["long" Int valueL i.= (#ls;Int valueL) id] + ["float" Frac valueF f.= (|> (#ls;Frac valueF) + (list) (#ls;Procedure "jvm convert double-to-float")) + (<| (#ls;Procedure "jvm convert float-to-double") (list))] + ["double" Frac valueD f.= (#ls;Frac valueD) id] + )] + ($_ seq + <array> + ))) + +(context: "Array [Part 2]" + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1)))) + idx (|> r;nat (:: @ map (n.% size))) + valueZ r;bool + valueB gen-int + valueS gen-int + valueI gen-int + valueL r;int + valueF gen-frac + valueD r;frac + valueC gen-int] + (with-expansions [<array> (do-template [<class> <type> <value> <test> <input> <post>] + [(test <class> + (|> (do macro;Monad<Lux> + [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text <class>) (#ls;Nat size))) + (list (#ls;Text <class>) (#ls;Nat idx) <input>) (#ls;Procedure "jvm array write") + (list (#ls;Text <class>) (#ls;Nat idx)) (#ls;Procedure "jvm array read") + <post>))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (<test> <value> (:! <type> outputG)) + + (#R;Error error) + false)))] + + ["char" Int valueC i.= (|> (#ls;Int valueC) + (list) (#ls;Procedure "jvm convert long-to-int") + (list) (#ls;Procedure "jvm convert int-to-char")) + (<| (#ls;Procedure "jvm convert char-to-long") (list))] + ["java.lang.Long" Int valueL i.= (#ls;Int valueL) id] + )] + ($_ seq + <array> + (test "java.lang.Double (level 1)" + (|> (do macro;Monad<Lux> + [#let [inner (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text "java.lang.Double") (#ls;Nat size))) + (list (#ls;Text "java.lang.Double") (#ls;Nat idx) (#ls;Frac valueD)) (#ls;Procedure "jvm array write"))] + sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +1) (#ls;Text "java.lang.Double") (#ls;Nat size))) + (list (#ls;Text "#Array") (#ls;Nat idx) inner) (#ls;Procedure "jvm array write") + (list (#ls;Text "#Array") (#ls;Nat idx)) (#ls;Procedure "jvm array read") + (list (#ls;Text "java.lang.Double") (#ls;Nat idx)) (#ls;Procedure "jvm array read")))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (f.= valueD (:! Frac outputG)) + + (#R;Error error) + false))) + (test "jvm array length" + (|> (do macro;Monad<Lux> + [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text "java.lang.Object") (#ls;Nat size))) + (list) (#ls;Procedure "jvm array length")))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (n.= size (:! Nat outputG)) + + (#R;Error error) + false))) + ))) |