aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--new-luxc/source/luxc/analyser/procedure/common.lux64
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/def.lux26
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux256
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux12
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux118
-rw-r--r--new-luxc/source/luxc/host.jvm.lux27
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/common.jvm.lux127
-rw-r--r--new-luxc/test/tests.lux7
8 files changed, 436 insertions, 201 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
index e96874960..1976d266d 100644
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ b/new-luxc/source/luxc/analyser/procedure/common.lux
@@ -15,15 +15,15 @@
(analyser ["&;" common])))
## [Utils]
-(type: Proc-Analyser
+(type: Proc
(-> &;Analyser (List Code) (Lux Analysis)))
-(type: Proc-Set
- (D;Dict Text Proc-Analyser))
+(type: Bundle
+ (D;Dict Text Proc))
(def: (install name unnamed)
- (-> Text (-> Text Proc-Analyser)
- (-> Proc-Set Proc-Set))
+ (-> Text (-> Text Proc)
+ (-> Bundle Bundle))
(D;put name (unnamed name)))
(def: (wrong-amount-error proc expected actual)
@@ -33,7 +33,7 @@
" Actual: " (|> actual nat-to-int %i)))
(def: (simple-proc proc input-types output-type)
- (-> Text (List Type) Type Proc-Analyser)
+ (-> Text (List Type) Type Proc)
(let [num-expected (list;size input-types)]
(function [analyse args]
(let [num-actual (list;size args)]
@@ -51,29 +51,29 @@
(&;fail (wrong-amount-error proc num-expected num-actual)))))))
(def: (binary-operation subjectT paramT outputT proc)
- (-> Type Type Type Text Proc-Analyser)
+ (-> Type Type Type Text Proc)
(simple-proc proc (list subjectT paramT) outputT))
(def: (trinary-operation subjectT param0T param1T outputT proc)
- (-> Type Type Type Type Text Proc-Analyser)
+ (-> Type Type Type Type Text Proc)
(simple-proc proc (list subjectT param0T param1T) outputT))
(def: (unary-operation inputT outputT proc)
- (-> Type Type Text Proc-Analyser)
+ (-> Type Type Text Proc)
(simple-proc proc (list inputT) outputT))
(def: (special-value valueT proc)
- (-> Type Text Proc-Analyser)
+ (-> Type Text Proc)
(simple-proc proc (list) valueT))
(def: (converter fromT toT proc)
- (-> Type Type Text Proc-Analyser)
+ (-> Type Type Text Proc)
(simple-proc proc (list fromT) toT))
## [Analysers]
## "lux is" represents reference/pointer equality.
(def: (analyse-lux-is proc)
- (-> Text Proc-Analyser)
+ (-> Text Proc)
(function [analyse args]
(&common;with-var
(function [[var-id varT]]
@@ -83,7 +83,7 @@
## "lux try" provides a simple way to interact with the host platform's
## error-handling facilities.
(def: (analyse-lux-try proc)
- (-> Text Proc-Analyser)
+ (-> Text Proc)
(function [analyse args]
(&common;with-var
(function [[var-id varT]]
@@ -103,13 +103,13 @@
(&;fail (wrong-amount-error proc +1 (list;size args))))))))
(def: lux-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "lux is" analyse-lux-is)
(install "lux try" analyse-lux-try)))
(def: io-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "io log" (converter Text Unit))
(install "io error" (converter Text Bottom))
@@ -117,7 +117,7 @@
(install "io current-time" (special-value Int))))
(def: bit-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "bit count" (unary-operation Nat Nat))
(install "bit and" (binary-operation Nat Nat Nat))
@@ -129,7 +129,7 @@
))
(def: nat-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "nat +" (binary-operation Nat Nat Nat))
(install "nat -" (binary-operation Nat Nat Nat))
@@ -144,7 +144,7 @@
(install "nat to-text" (converter Nat Text))))
(def: int-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "int +" (binary-operation Int Int Int))
(install "int -" (binary-operation Int Int Int))
@@ -159,7 +159,7 @@
(install "int to-real" (converter Int Real))))
(def: deg-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "deg +" (binary-operation Deg Deg Deg))
(install "deg -" (binary-operation Deg Deg Deg))
@@ -175,7 +175,7 @@
(install "deg to-real" (converter Deg Real))))
(def: real-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "real +" (binary-operation Real Real Real))
(install "real -" (binary-operation Real Real Real))
@@ -196,7 +196,7 @@
(install "real from-text" (converter Text (type (Maybe Real))))))
(def: text-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "text =" (binary-operation Text Text Bool))
(install "text <" (binary-operation Text Text Bool))
@@ -210,7 +210,7 @@
))
(def: (analyse-array-get proc)
- (-> Text Proc-Analyser)
+ (-> Text Proc)
(function [analyse args]
(&common;with-var
(function [[var-id varT]]
@@ -218,7 +218,7 @@
analyse args)))))
(def: (analyse-array-put proc)
- (-> Text Proc-Analyser)
+ (-> Text Proc)
(function [analyse args]
(&common;with-var
(function [[var-id varT]]
@@ -226,7 +226,7 @@
analyse args)))))
(def: (analyse-array-remove proc)
- (-> Text Proc-Analyser)
+ (-> Text Proc)
(function [analyse args]
(&common;with-var
(function [[var-id varT]]
@@ -234,7 +234,7 @@
analyse args)))))
(def: array-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "array new" (unary-operation Nat Array))
(install "array get" analyse-array-get)
@@ -244,7 +244,7 @@
))
(def: math-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "math cos" (unary-operation Real Real))
(install "math sin" (unary-operation Real Real))
@@ -267,7 +267,7 @@
))
(def: (analyse-atom-new proc)
- (-> Text Proc-Analyser)
+ (-> Text Proc)
(function [analyse args]
(&common;with-var
(function [[var-id varT]]
@@ -287,7 +287,7 @@
(&;fail (wrong-amount-error proc +1 (list;size args))))))))
(def: (analyse-atom-read proc)
- (-> Text Proc-Analyser)
+ (-> Text Proc)
(function [analyse args]
(&common;with-var
(function [[var-id varT]]
@@ -295,7 +295,7 @@
analyse args)))))
(def: (analyse-atom-compare-and-swap proc)
- (-> Text Proc-Analyser)
+ (-> Text Proc)
(function [analyse args]
(&common;with-var
(function [[var-id varT]]
@@ -303,7 +303,7 @@
analyse args)))))
(def: atom-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "atom new" analyse-atom-new)
(install "atom read" analyse-atom-read)
@@ -311,7 +311,7 @@
))
(def: process-procs
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(install "process concurrency-level" (special-value Nat))
(install "process future" (unary-operation (type (io;IO Top)) Unit))
@@ -319,7 +319,7 @@
))
(def: #export procedures
- Proc-Set
+ Bundle
(|> (D;new text;Hash<Text>)
(D;merge lux-procs)
(D;merge bit-procs)
diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux
index 6f0f97d9b..42cfa2d68 100644
--- a/new-luxc/source/luxc/generator/host/jvm/def.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/def.lux
@@ -2,6 +2,7 @@
lux
(lux (data [text]
text/format
+ [product]
(coll ["a" array]
[list "L/" Functor<List>]))
[host #+ jvm-import do-to])
@@ -154,11 +155,11 @@
<flag>
(visibility-flag visibility)
(class-flag config))
- name
+ ($t;binary-name name)
(parameters-signature parameters super interfaces)
- (|> super class-to-type $t;descriptor)
+ (|> super product;left $t;binary-name)
(|> interfaces
- (L/map (|>. class-to-type $t;descriptor))
+ (L/map (|>. product;left $t;binary-name))
string-array)]))
definitions)
_ (ClassWriter.visitEnd [] writer)]
@@ -181,11 +182,11 @@
Opcodes.ACC_INTERFACE
(visibility-flag visibility)
(class-flag config))
- name
+ ($t;binary-name name)
(parameters-signature parameters $Object interfaces)
- (|> $Object class-to-type $t;descriptor)
+ (|> $Object product;left $t;binary-name)
(|> interfaces
- (L/map (|>. class-to-type $t;descriptor))
+ (L/map (|>. product;left $t;binary-name))
string-array)]))
definitions)
_ (ClassWriter.visitEnd [] writer)]
@@ -198,7 +199,7 @@
(let [=method (ClassWriter.visitMethod [($_ i.+
(visibility-flag visibility)
(method-flag config))
- name
+ ($t;binary-name name)
($t;method-descriptor type)
($t;method-signature type)
(exceptions-array type)]
@@ -217,7 +218,7 @@
(visibility-flag visibility)
(method-flag config)
Opcodes.ACC_ABSTRACT)
- name
+ ($t;binary-name name)
($t;method-descriptor type)
($t;method-signature type)
(exceptions-array type)]
@@ -231,7 +232,10 @@
(let [=field (do-to (ClassWriter.visitField [($_ i.+
(visibility-flag visibility)
(field-flag config))
- name ($t;descriptor type) ($t;signature type) (host;null)] writer)
+ ($t;binary-name name)
+ ($t;descriptor type)
+ ($t;signature type)
+ (host;null)] writer)
(FieldVisitor.visitEnd []))]
writer)))
@@ -242,7 +246,9 @@
(let [=field (do-to (ClassWriter.visitField [($_ i.+
(visibility-flag visibility)
(field-flag config))
- name ($t;descriptor <jvm-type>) ($t;signature <jvm-type>)
+ ($t;binary-name name)
+ ($t;descriptor <jvm-type>)
+ ($t;signature <jvm-type>)
(<prepare> value)]
writer)
(FieldVisitor.visitEnd []))]
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index 824598ab8..30148c4e5 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -1,6 +1,13 @@
(;module:
[lux #- char]
- (lux [host #+ jvm-import do-to])
+ (lux (control monad
+ ["p" parser])
+ (data text/format
+ (coll [list "L/" Functor<List>]))
+ [host #+ jvm-import do-to]
+ [macro]
+ (macro [code]
+ ["s" syntax #+ syntax:]))
["$" ..]
(.. ["$t" type]))
@@ -8,83 +15,85 @@
(jvm-import #long java.lang.Object)
(jvm-import #long java.lang.String)
-(jvm-import org.objectweb.asm.Opcodes
- (#static T_BOOLEAN int)
- (#static T_CHAR int)
- (#static T_FLOAT int)
- (#static T_DOUBLE int)
- (#static T_BYTE int)
- (#static T_SHORT int)
- (#static T_INT int)
- (#static T_LONG int)
-
- (#static CHECKCAST int)
- (#static NEW int)
- (#static NEWARRAY int)
- (#static ANEWARRAY int)
-
- (#static DUP int)
- (#static DUP2_X1 int)
- (#static POP int)
- (#static POP2 int)
-
- (#static IF_ICMPEQ int)
- (#static IF_ACMPEQ int)
- (#static IFNULL int)
- (#static GOTO int)
-
- (#static ACONST_NULL int)
-
- (#static ILOAD int)
- (#static ALOAD int)
-
- (#static IADD int)
-
- (#static LAND int)
- (#static LOR int)
- (#static LXOR int)
- (#static LSHL int)
- (#static LSHR int)
- (#static LUSHR int)
-
- (#static LADD int)
- (#static LSUB int)
- (#static LMUL int)
- (#static LDIV int)
- (#static LREM int)
- (#static LCMP int)
-
- (#static DADD int)
- (#static DSUB int)
- (#static DMUL int)
- (#static DDIV int)
- (#static DREM int)
- (#static DCMPG int)
-
- (#static I2L int)
- (#static L2I int)
- (#static L2D int)
- (#static D2L int)
- (#static I2C int)
-
- (#static AALOAD int)
- (#static AASTORE int)
- (#static ARRAYLENGTH int)
-
- (#static GETSTATIC int)
- (#static PUTSTATIC int)
- (#static GETFIELD int)
- (#static PUTFIELD int)
-
- (#static INVOKESTATIC int)
- (#static INVOKESPECIAL int)
- (#static INVOKEVIRTUAL int)
-
- (#static ATHROW int)
-
- (#static RETURN int)
- (#static ARETURN int)
- )
+(syntax: (declare [codes (p;many s;local-symbol)])
+ (|> codes
+ (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int)))))
+ wrap))
+
+(with-expansions [<primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
+ T_BYTE T_SHORT T_INT T_LONG)
+ <stack> (declare DUP DUP2_X1
+ POP POP2
+ SWAP)
+ <jump> (declare IF_ICMPEQ IF_ACMPEQ IFNULL
+ IFLT IFLE IFGT IFGE
+ GOTO)]
+ (jvm-import org.objectweb.asm.Opcodes
+ <primitive>
+
+ (#static CHECKCAST int)
+ (#static NEW int)
+ (#static NEWARRAY int)
+ (#static ANEWARRAY int)
+
+ <stack>
+ <jump>
+
+ (#static ACONST_NULL int)
+
+ (#static ILOAD int)
+ (#static LLOAD int)
+ (#static ALOAD int)
+
+ (#static IADD int)
+
+ (#static LAND int)
+ (#static LOR int)
+ (#static LXOR int)
+ (#static LSHL int)
+ (#static LSHR int)
+ (#static LUSHR int)
+
+ (#static LADD int)
+ (#static LSUB int)
+ (#static LMUL int)
+ (#static LDIV int)
+ (#static LREM int)
+ (#static LCMP int)
+
+ (#static DADD int)
+ (#static DSUB int)
+ (#static DMUL int)
+ (#static DDIV int)
+ (#static DREM int)
+ (#static DCMPG int)
+
+ (#static I2L int)
+ (#static L2I int)
+ (#static L2D int)
+ (#static D2L int)
+ (#static I2C int)
+
+ (#static AALOAD int)
+ (#static AASTORE int)
+ (#static ARRAYLENGTH int)
+
+ (#static GETSTATIC int)
+ (#static PUTSTATIC int)
+ (#static GETFIELD int)
+ (#static PUTFIELD int)
+
+ (#static INVOKESTATIC int)
+ (#static INVOKESPECIAL int)
+ (#static INVOKEVIRTUAL int)
+
+ (#static ATHROW int)
+
+ (#static RETURN int)
+ (#static IRETURN int)
+ (#static LRETURN int)
+ (#static ARETURN int)
+ ))
(jvm-import org.objectweb.asm.FieldVisitor
(visitEnd [] void))
@@ -126,57 +135,48 @@
[string Text id]
)
-(do-template [<name> <inst>]
+(syntax: (prefix [base s;local-symbol])
+ (wrap (list (code;local-symbol (format "Opcodes." base)))))
+
+(def: #export NULL
+ $;Inst
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitInsn [(prefix ACONST_NULL)]))))
+
+(do-template [<name>]
[(def: #export <name>
$;Inst
(function [visitor]
(do-to visitor
- (MethodVisitor.visitInsn [<inst>]))))]
+ (MethodVisitor.visitInsn [(prefix <name>)]))))]
- [DUP Opcodes.DUP]
- [DUP2_X1 Opcodes.DUP2_X1]
- [POP Opcodes.POP]
- [POP2 Opcodes.POP2]
+ ## Stack
+ [DUP] [DUP2_X1] [POP] [POP2] [SWAP]
- [NULL Opcodes.ACONST_NULL]
-
- [IADD Opcodes.IADD]
-
- [LAND Opcodes.LAND]
- [LOR Opcodes.LOR]
- [LXOR Opcodes.LXOR]
- [LSHL Opcodes.LSHL]
- [LSHR Opcodes.LSHR]
- [LUSHR Opcodes.LUSHR]
-
- [LADD Opcodes.LADD]
- [LSUB Opcodes.LSUB]
- [LMUL Opcodes.LMUL]
- [LDIV Opcodes.LDIV]
- [LREM Opcodes.LREM]
- [LCMP Opcodes.LCMP]
-
- [DADD Opcodes.DADD]
- [DSUB Opcodes.DSUB]
- [DMUL Opcodes.DMUL]
- [DDIV Opcodes.DDIV]
- [DREM Opcodes.DREM]
- [DCMPG Opcodes.DCMPG]
-
- [I2L Opcodes.I2L]
- [L2I Opcodes.L2I]
- [L2D Opcodes.L2D]
- [D2L Opcodes.D2L]
- [I2C Opcodes.I2C]
-
- [AALOAD Opcodes.AALOAD]
- [AASTORE Opcodes.AASTORE]
- [ARRAYLENGTH Opcodes.ARRAYLENGTH]
+ ## Integer arithmetic
+ [IADD]
+
+ ## Long bitwise
+ [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
- [ATHROW Opcodes.ATHROW]
+ ## Long arithmethic
+ [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LCMP]
- [RETURN Opcodes.RETURN]
- [ARETURN Opcodes.ARETURN]
+ ## Double arithmetic
+ [DADD] [DSUB] [DMUL] [DDIV] [DREM] [DCMPG]
+
+ ## Conversions
+ [I2L] [L2I] [L2D] [D2L] [I2C]
+
+ ## Array
+ [AALOAD] [AASTORE] [ARRAYLENGTH]
+
+ ## Exceptions
+ [ATHROW]
+
+ ## Return
+ [RETURN] [IRETURN] [LRETURN] [ARETURN]
)
(do-template [<name> <inst>]
@@ -186,8 +186,9 @@
(do-to visitor
(MethodVisitor.visitVarInsn [<inst> (nat-to-int register)]))))]
- [ALOAD Opcodes.ALOAD]
[ILOAD Opcodes.ILOAD]
+ [LLOAD Opcodes.LLOAD]
+ [ALOAD Opcodes.ALOAD]
)
(do-template [<name> <inst>]
@@ -242,17 +243,16 @@
[INVOKESPECIAL Opcodes.INVOKESPECIAL]
)
-(do-template [<name> <inst>]
+(do-template [<name>]
[(def: #export (<name> @where)
(-> $;Label $;Inst)
(function [visitor]
(do-to visitor
- (MethodVisitor.visitJumpInsn [<inst> @where]))))]
+ (MethodVisitor.visitJumpInsn [(prefix <name>) @where]))))]
- [IF_ICMPEQ Opcodes.IF_ICMPEQ]
- [IF_ACMPEQ Opcodes.IF_ACMPEQ]
- [IFNULL Opcodes.IFNULL]
- [GOTO Opcodes.GOTO]
+ [IF_ICMPEQ] [IF_ACMPEQ] [IFNULL]
+ [IFLT] [IFLE] [IFGT] [IFGE]
+ [GOTO]
)
(def: #export (label @label)
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index 957a2efa4..fcfba7682 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -172,7 +172,7 @@
(def: (bit//count inputI)
Unary
- (|>. inputI
+ (|>. inputI $i;unwrap-long
($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false)
lux-intI))
@@ -231,7 +231,7 @@
(def: deg-method $;Method nat-method)
-(def: compare-unsigned-method
+(def: compare-nat-method
$;Method
($t;method (list $t;long $t;long) (#;Some $t;int) (list)))
@@ -305,8 +305,8 @@
($i;int <reference>)
(predicateI $i;IF_ICMPEQ)))]
- [nat//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)]
- [nat//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)]
+ [nat//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
+ [nat//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
[int//eq 0 $i;unwrap-long $i;LCMP]
[int//lt -1 $i;unwrap-long $i;LCMP]
@@ -314,8 +314,8 @@
[real//eq 0 $i;unwrap-double $i;DCMPG]
[real//lt -1 $i;unwrap-double $i;DCMPG]
- [deg//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)]
- [deg//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)]
+ [deg//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
+ [deg//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
)
(do-template [<name> <prepare> <transform>]
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index 8c0b294c1..e6a12d6fa 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -39,20 +39,25 @@
(visitEnd [] void)
(toByteArray [] Byte-Array))
-(def: #export runtime-name Text "LuxRT")
+(def: #export runtime-name Text "LuxRuntime")
(def: #export function-name Text "LuxFunction")
(def: #export unit Text "\u0000")
(def: $Object $;Type ($t;class "java.lang.Object" (list)))
+(def: logI
+ $;Inst
+ (let [outI ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list)))
+ printI (function [method] ($i;INVOKEVIRTUAL "java.io.PrintStream" method ($t;method (list $Object) #;None (list)) false))]
+ (|>. outI ($i;string "LOG: ") (printI "print")
+ outI $i;SWAP (printI "println"))))
+
(def: add-adt-methods
$;Def
(let [store-tag (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) $i;wrap-int $i;AASTORE)
store-flag (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE)
store-value (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)]
- (|>. ($d;method #$;Public
- {#$;staticM true #$;finalM false #$;synchronizedM false}
- "sum_make"
+ (|>. ($d;method #$;Public $;staticM "sum_make"
($t;method (list $t;int $Object $Object)
(#;Some ($t;array +1 $Object))
(list))
@@ -62,16 +67,107 @@
store-value
$i;ARETURN)))))
+(def: add-nat-methods
+ $;Def
+ (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list))
+ less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-name "compare_nat" compare-nat-method false) ($i;IFLT @where)))
+ $BigInteger ($t;class "java.math.BigInteger" (list))
+ upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list))
+ div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))
+ upcastI ($i;INVOKESTATIC runtime-name "_toUnsignedBigInteger" upcast-method false)
+ downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)]
+ ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215
+ (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method
+ (let [upcastI ($i;INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false)
+ discernI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGE @where)))
+ prepare-upperI (|>. ($i;LLOAD +0) ($i;int 32) $i;LUSHR
+ upcastI
+ ($i;int 32) ($i;INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t;method (list $t;int) (#;Some $BigInteger) (list)) false))
+ prepare-lowerI (|>. ($i;LLOAD +0) ($i;int 32) $i;LSHL
+ ($i;int 32) $i;LUSHR
+ upcastI)]
+ (<| $i;with-label (function [@simple])
+ (|>. (discernI @simple)
+ ## else
+ prepare-upperI
+ prepare-lowerI
+ ($i;INVOKEVIRTUAL "java.math.BigInteger" "add" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)
+ $i;ARETURN
+ ## then
+ ($i;label @simple)
+ ($i;LLOAD +0)
+ upcastI
+ $i;ARETURN))))
+ ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267
+ ($d;method #$;Public $;staticM "compare_nat" compare-nat-method
+ (let [shiftI (|>. ($i;GETSTATIC "java.lang.Long" "MIN_VALUE" $t;long) $i;LADD)]
+ (|>. ($i;LLOAD +0) shiftI
+ ($i;LLOAD +2) shiftI
+ $i;LCMP
+ $i;IRETURN)))
+ ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290
+ ($d;method #$;Public $;staticM "div_nat" div-method
+ (let [is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLT @where)))
+ is-subject-smallI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGT @where)))
+ small-division (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LDIV $i;LRETURN)
+ big-divisionI ($i;INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)]
+ (<| $i;with-label (function [@is-zero])
+ $i;with-label (function [@param-is-large])
+ $i;with-label (function [@subject-is-small])
+ (|>. (is-param-largeI @param-is-large)
+ ## Param is not too large
+ (is-subject-smallI @subject-is-small)
+ ## Param is small, but subject is large
+ ($i;LLOAD +0) upcastI
+ ($i;LLOAD +2) upcastI
+ big-divisionI downcastI $i;LRETURN
+ ## Both param and subject are small,
+ ## and can thus be divided normally.
+ ($i;label @subject-is-small)
+ small-division
+ ## Param is too large. Cannot simply divide.
+ ## Depending on the result of the
+ ## comparison, a result will be determined.
+ ($i;label @param-is-large)
+ ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @is-zero)
+ ## Greater-than or equals
+ ($i;long 1) $i;LRETURN
+ ## Less than
+ ($i;label @is-zero)
+ ($i;long 0) $i;LRETURN))))
+ ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323
+ ($d;method #$;Public $;staticM "rem_nat" div-method
+ (let [is-subject-largeI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFLE @where)))
+ is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLE @where)))
+ small-remainderI (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LREM $i;LRETURN)
+ big-remainderI ($i;INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)]
+ (<| $i;with-label (function [@large-number])
+ $i;with-label (function [@subject-is-smaller-than-param])
+ (|>. (is-subject-largeI @large-number)
+ (is-param-largeI @large-number)
+ small-remainderI
+
+ ($i;label @large-number)
+ ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @subject-is-smaller-than-param)
+
+ ($i;LLOAD +0) upcastI
+ ($i;LLOAD +2) upcastI
+ big-remainderI downcastI $i;LRETURN
+
+ ($i;label @subject-is-smaller-than-param)
+ ($i;LLOAD +0)
+ $i;LRETURN))))
+ )))
+
+(def: init-method $;Method ($t;method (list) #;None (list)))
+
(def: #export generate
(Lux &common;Bytecode)
(do Monad<Lux>
[_ (wrap [])
- #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
- (ClassWriter.visit [&common;bytecode-version
- ($_ i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_FINAL Opcodes.ACC_SUPER)
- runtime-name (host;null)
- "java/lang/Object" (host;null)]))
- add-adt-methods)
- bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
+ #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list)
+ (|>. add-adt-methods
+ add-nat-methods
+ ))]
_ (&common;store-class runtime-name bytecode)]
(wrap bytecode)))
diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux
index 37b62b30d..d5b4e89b0 100644
--- a/new-luxc/source/luxc/host.jvm.lux
+++ b/new-luxc/source/luxc/host.jvm.lux
@@ -57,25 +57,26 @@
ClassLoader::defineClass))
(def: (fetch-byte-code class-name store)
- (-> Text &&common;Class-Store &&common;Bytecode)
- (|> store A;get io;run (d;get class-name) assume))
-
-(def: (assume!! input)
- (All [a] (-> (R;Result a) a))
- (case input
- (#R;Success output)
- output
-
- (#R;Error error)
- (error! error)))
+ (-> Text &&common;Class-Store (Maybe &&common;Bytecode))
+ (|> store A;get io;run (d;get class-name)))
(def: (memory-class-loader store)
(-> &&common;Class-Store ClassLoader)
(object ClassLoader []
[]
(ClassLoader (findClass [class-name String]) Class
- (:!! (assume!! (define-class class-name (fetch-byte-code class-name store) (:! ClassLoader _jvm_this))))
- )))
+ (case (fetch-byte-code class-name store)
+ (#;Some bytecode)
+ (case (define-class class-name bytecode (:! ClassLoader _jvm_this))
+ (#R;Success class)
+ (:!! class)
+
+ (#R;Error error)
+ (error! (format "Class definiton error: " class-name "\n"
+ error)))
+
+ #;None
+ (error! (format "Class not found: " class-name))))))
(def: #export (init-host _)
(-> Top &&common;Host)
diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
new file mode 100644
index 000000000..96cf8ae97
--- /dev/null
+++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
@@ -0,0 +1,127 @@
+(;module:
+ lux
+ (lux [io]
+ (control monad
+ pipe)
+ (data text/format
+ [bit]
+ ["R" result]
+ [bool "B/" Eq<Bool>]
+ [text "T/" Eq<Text>]
+ [number "n/" Interval<Nat>]
+ (coll ["a" array]
+ [list]))
+ ["r" math/random "r/" Monad<Random>]
+ [macro #+ Monad<Lux>]
+ [host #+ jvm-import]
+ test)
+ (luxc (lang ["ls" synthesis])
+ [analyser]
+ [synthesizer]
+ (generator ["@" expr]
+ ["@;" eval]
+ ["@;" runtime]
+ ["@;" common]))
+ (test/luxc common))
+
+(context: "Bit procedures"
+ [param r;nat
+ subject r;nat]
+ (with-expansions [<binary> (do-template [<name> <reference>]
+ [(test <name>
+ (|> (@eval;eval (@;generate (#ls;Procedure <name>
+ (list (#ls;Nat subject)
+ (#ls;Nat param)))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success valueG)
+ (n.= (<reference> param subject) (:! Nat valueG))
+
+ _
+ false)))]
+
+ ["bit and" bit;and]
+ ["bit or" bit;or]
+ ["bit xor" bit;xor]
+ ["bit shift-left" bit;shift-left]
+ ["bit unsigned-shift-right" bit;unsigned-shift-right]
+ )]
+ ($_ seq
+ (test "bit count"
+ (|> (@eval;eval (@;generate (#ls;Procedure "bit count" (list (#ls;Nat subject)))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success valueG)
+ (n.= (bit;count subject) (:! Nat valueG))
+
+ _
+ false)))
+
+ <binary>
+ (test "bit shift-right"
+ (|> (@eval;eval (@;generate (#ls;Procedure "bit shift-right"
+ (list (#ls;Int (nat-to-int subject))
+ (#ls;Nat param)))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success valueG)
+ (i.= (bit;shift-right param (nat-to-int subject))
+ (:! Int valueG))
+
+ _
+ false)))
+ )))
+
+(context: "Nat procedures"
+ [param (|> r;nat (r;filter (|>. (n.= +0) not)))
+ subject r;nat]
+ (with-expansions [<nullary> (do-template [<name> <reference>]
+ [(test <name>
+ (|> (@eval;eval (@;generate (#ls;Procedure <name> (list))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success valueG)
+ (n.= <reference> (:! Nat valueG))
+
+ _
+ false)))]
+
+ ["nat min" n/bottom]
+ ["nat max" n/top]
+ )
+ <unary> (do-template [<name> <type> <prepare> <comp>]
+ [(test <name>
+ (|> (@eval;eval (@;generate (#ls;Procedure <name> (list (#ls;Nat subject)))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success valueG)
+ (<comp> (<prepare> subject) (:! <type> valueG))
+
+ _
+ false)))]
+
+ ["nat to-int" Int nat-to-int i.=]
+ ["nat to-char" Text text;from-code T/=]
+ )
+ <binary> (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Lux>
+ [runtime-bytecode @runtime;generate]
+ (@eval;eval (@;generate (#ls;Procedure <name>
+ (list (#ls;Nat subject)
+ (#ls;Nat param))))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success valueG)
+ (<comp> (<reference> param subject) (:! <outputT> valueG))
+
+ _
+ false)))]
+
+ ["nat +" n.+ Nat n.=]
+ ["nat -" n.- Nat n.=]
+ ["nat *" n.* Nat n.=]
+ ["nat /" n./ Nat n.=]
+ ["nat %" n.% Nat n.=]
+ ["nat =" n.= Bool B/=]
+ ["nat <" n.< Bool B/=]
+ )]
+ ($_ seq
+ <nullary>
+ <unary>
+ <binary>
+ )))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index 92644ff48..695c72174 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -20,7 +20,12 @@
["_;S" procedure]
["_;S" loop])
(generator ["_;G" primitive]
- ["_;G" structure]))))
+ ["_;G" structure]
+ (procedure ["_;G" common]))
+ ))
+ ## (luxc (generator ["_;G" function])
+ ## )
+ )
## [Program]
(program: args
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 23:57:44 +0000