From 7b870a7bd124f35939d9089a2e21f0806a4c6e85 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sun, 29 Oct 2017 22:21:14 -0400
Subject: - Fixed some bugs. - Improved error reporting. - Implemented
macro-expansion (for JVM). - Implemented "let" compilation.
---
new-luxc/source/luxc/generator/case.jvm.lux | 63 ++++++----
new-luxc/source/luxc/generator/expr.jvm.lux | 34 ++----
new-luxc/source/luxc/generator/function.jvm.lux | 19 +--
new-luxc/source/luxc/generator/host/jvm/inst.lux | 132 +++++++++++----------
new-luxc/source/luxc/generator/primitive.jvm.lux | 9 +-
.../source/luxc/generator/procedure/common.jvm.lux | 41 +++----
.../source/luxc/generator/procedure/host.jvm.lux | 7 +-
new-luxc/source/luxc/generator/runtime.jvm.lux | 104 ++++++++++++----
new-luxc/source/luxc/generator/structure.jvm.lux | 9 +-
9 files changed, 244 insertions(+), 174 deletions(-)
(limited to 'new-luxc/source/luxc/generator')
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux
index 53912f5d0..f20c83f6e 100644
--- a/new-luxc/source/luxc/generator/case.jvm.lux
+++ b/new-luxc/source/luxc/generator/case.jvm.lux
@@ -2,9 +2,9 @@
lux
(lux (control [monad #+ do])
[meta "meta/" Monad])
- (luxc (lang ["ls" synthesis])
- (generator [expr]
- (host ["$" jvm]
+ (luxc [";L" host]
+ (lang ["ls" synthesis])
+ (generator (host ["$" jvm]
(jvm ["$t" type]
["$i" inst]))))
[../runtime])
@@ -24,7 +24,7 @@
(def: peekI
$;Inst
(|>. $i;DUP
- ($i;INVOKESTATIC ../runtime;runtime-class
+ ($i;INVOKESTATIC hostL;runtime-class
"pm_peek"
($t;method (list ../runtime;$Stack)
(#;Some $Object)
@@ -33,7 +33,7 @@
(def: popI
$;Inst
- (|>. ($i;INVOKESTATIC ../runtime;runtime-class
+ (|>. ($i;INVOKESTATIC hostL;runtime-class
"pm_pop"
($t;method (list ../runtime;$Stack)
(#;Some ../runtime;$Stack)
@@ -42,19 +42,20 @@
(def: pushI
$;Inst
- (|>. ($i;INVOKESTATIC ../runtime;runtime-class
+ (|>. ($i;INVOKESTATIC hostL;runtime-class
"pm_push"
($t;method (list ../runtime;$Stack $Object)
(#;Some ../runtime;$Stack)
(list))
false)))
-(def: (generate-pattern' stack-depth @else @end path)
- (-> Nat $;Label $;Label ls;Path (Meta $;Inst))
+(def: (generate-pattern' generate stack-depth @else @end path)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ Nat $;Label $;Label ls;Path (Meta $;Inst))
(case path
(#ls;ExecP bodyS)
(do meta;Monad
- [bodyI (expr;generate bodyS)]
+ [bodyI (generate bodyS)]
(wrap (|>. (pop-altI stack-depth)
bodyI
($i;GOTO @end))))
@@ -104,7 +105,7 @@
(#ls;TupleP idx subP)
(do meta;Monad
- [subI (generate-pattern' stack-depth @else @end subP)
+ [subI (generate-pattern' generate stack-depth @else @end subP)
#let [[idx tail?] (case idx
(#;Left idx)
[idx false]
@@ -124,7 +125,7 @@
(|>. peekI
($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
($i;int (nat-to-int idx))
- ($i;INVOKESTATIC ../runtime;runtime-class
+ ($i;INVOKESTATIC hostL;runtime-class
(if tail? "pm_right" "pm_left")
($t;method (list ../runtime;$Tuple $t;int)
(#;Some $Object)
@@ -135,7 +136,7 @@
(#ls;VariantP idx subP)
(do meta;Monad
- [subI (generate-pattern' stack-depth @else @end subP)
+ [subI (generate-pattern' generate stack-depth @else @end subP)
#let [[idx last?] (case idx
(#;Left idx)
[idx false]
@@ -151,7 +152,7 @@
($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
($i;int (nat-to-int idx))
flagI
- ($i;INVOKESTATIC ../runtime;runtime-class "pm_variant"
+ ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
(#;Some ../runtime;$Datum)
(list))
@@ -168,16 +169,16 @@
(#ls;SeqP leftP rightP)
(do meta;Monad
- [leftI (generate-pattern' stack-depth @else @end leftP)
- rightI (generate-pattern' stack-depth @else @end rightP)]
+ [leftI (generate-pattern' generate stack-depth @else @end leftP)
+ rightI (generate-pattern' generate stack-depth @else @end rightP)]
(wrap (|>. leftI
rightI)))
(#ls;AltP leftP rightP)
(do meta;Monad
[@alt-else $i;make-label
- leftI (generate-pattern' (n.inc stack-depth) @alt-else @end leftP)
- rightI (generate-pattern' stack-depth @else @end rightP)]
+ leftI (generate-pattern' generate (n.inc stack-depth) @alt-else @end leftP)
+ rightI (generate-pattern' generate stack-depth @else @end rightP)]
(wrap (|>. $i;DUP
leftI
($i;label @alt-else)
@@ -185,30 +186,42 @@
rightI)))
))
-(def: (generate-pattern path @end)
- (-> ls;Path $;Label (Meta $;Inst))
+(def: (generate-pattern generate path @end)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ ls;Path $;Label (Meta $;Inst))
(do meta;Monad
[@else $i;make-label
- pathI (generate-pattern' +1 @else @end path)]
+ pathI (generate-pattern' generate +1 @else @end path)]
(wrap (|>. pathI
($i;label @else)
$i;POP
- ($i;INVOKESTATIC ../runtime;runtime-class
+ ($i;INVOKESTATIC hostL;runtime-class
"pm_fail"
($t;method (list) #;None (list))
false)
$i;NULL
($i;GOTO @end)))))
-(def: #export (generate valueS path)
- (-> ls;Synthesis ls;Path (Meta $;Inst))
+(def: #export (generate-case generate valueS path)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ ls;Synthesis ls;Path (Meta $;Inst))
(do meta;Monad
[@end $i;make-label
- valueI (expr;generate valueS)
- pathI (generate-pattern path @end)]
+ valueI (generate valueS)
+ pathI (generate-pattern generate path @end)]
(wrap (|>. valueI
$i;NULL
$i;SWAP
pushI
pathI
($i;label @end)))))
+
+(def: #export (generate-let generate register inputS exprS)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ Nat ls;Synthesis ls;Synthesis (Meta $;Inst))
+ (do meta;Monad
+ [inputI (generate inputS)
+ exprI (generate exprS)]
+ (wrap (|>. inputI
+ ($i;ASTORE register)
+ exprI))))
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index 116c29fb5..685bf2335 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -1,6 +1,7 @@
(;module:
lux
- (lux (control monad)
+ (lux (control monad
+ ["ex" exception #+ exception:])
(data text/format)
[meta #+ Monad "Meta/" Monad])
(luxc ["&" base]
@@ -15,8 +16,11 @@
["&;" procedure]
["&;" function]
["&;" reference]
+ [";G" case]
(host ["$" jvm]))))
+(exception: #export Unrecognized-Synthesis)
+
(def: #export (generate synthesis)
(-> ls;Synthesis (Meta $;Inst))
(case synthesis
@@ -47,6 +51,12 @@
(#ls;Definition definition)
(&reference;generate-definition definition)
+ (#ls;Let register inputS exprS)
+ (caseG;generate-let generate register inputS exprS)
+
+ (#ls;Case inputS pathPS)
+ (caseG;generate-case generate inputS pathPS)
+
(#ls;Function arity env body)
(&function;generate-function generate env arity body)
@@ -57,25 +67,5 @@
(&procedure;generate-procedure generate name args)
_
- (meta;fail "Unrecognized synthesis.")
+ (&;throw Unrecognized-Synthesis "")
))
-
-## (def: #export (eval type code)
-## (-> Type Code (Meta Top))
-## (do Monad
-## [analysis (&;with-expected-type leftT
-## (&analyser;analyser eval code))
-## #let [synthesis (&synthesizer;synthesize analysis)]
-## inst (generate synthesis)]
-## (&eval;eval inst)))
-
-## (def: analyse
-## &;Analyser
-## (&analyser;analyser eval))
-
-## (def: #export (generate input)
-## (-> Code (Meta Unit))
-## (do Monad
-## [analysis (analyse input)
-## #let [synthesis (&synthesizer;synthesize analysis)]]
-## (generate-synthesis synthesis)))
diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux
index 97d3a7c91..ce92b9010 100644
--- a/new-luxc/source/luxc/generator/function.jvm.lux
+++ b/new-luxc/source/luxc/generator/function.jvm.lux
@@ -5,6 +5,7 @@
(coll [list "list/" Functor Monoid]))
[meta])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -58,7 +59,7 @@
(def: get-amount-of-partialsI
$;Inst
(|>. ($i;ALOAD +0)
- ($i;GETFIELD &runtime;function-class &runtime;partials-field $t;int)))
+ ($i;GETFIELD hostL;function-class &runtime;partials-field $t;int)))
(def: (load-fieldI class field)
(-> Text Text $;Inst)
@@ -77,9 +78,9 @@
later-applysI (if (n.> &runtime;num-apply-variants amount)
(applysI (n.+ &runtime;num-apply-variants start) (n.- &runtime;num-apply-variants amount))
id)]
- (|>. ($i;CHECKCAST &runtime;function-class)
+ (|>. ($i;CHECKCAST hostL;function-class)
(inputsI start max-args)
- ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature max-args) false)
+ ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature max-args) false)
later-applysI)))
(def: (inc-intI by)
@@ -167,9 +168,9 @@
(-> ls;Arity Nat $;Inst)
(if (n.= +1 arity)
(|>. ($i;int 0)
- ($i;INVOKESPECIAL &runtime;function-class "" function-init-method false))
+ ($i;INVOKESPECIAL hostL;function-class "" function-init-method false))
(|>. ($i;ILOAD (n.inc env-size))
- ($i;INVOKESPECIAL &runtime;function-class "" function-init-method false))))
+ ($i;INVOKESPECIAL hostL;function-class "" function-init-method false))))
(def: (with-init class env arity)
(-> Text (List ls;Variable) ls;Arity $;Def)
@@ -262,7 +263,7 @@
($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int)
@default @labels)
casesI
- ($i;INVOKESTATIC &runtime;runtime-class "apply_fail" ($t;method (list) #;None (list)) false)
+ ($i;INVOKESTATIC hostL;runtime-class "apply_fail" ($t;method (list) #;None (list)) false)
$i;NULL
$i;ARETURN
))))
@@ -306,7 +307,7 @@
_ (&common;store-class function-class
($d;class #$;V1.6 #$;Public $;finalC
function-class (list)
- ($;simple-class &runtime;function-class) (list)
+ ($;simple-class hostL;function-class) (list)
functionD))]
(wrap instanceI)))
@@ -326,9 +327,9 @@
argsI (monad;map @ generate argsS)
#let [applyI (|> (segment &runtime;num-apply-variants argsI)
(list/map (function [chunkI+]
- (|>. ($i;CHECKCAST &runtime;function-class)
+ (|>. ($i;CHECKCAST hostL;function-class)
($i;fuse chunkI+)
- ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false))))
+ ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false))))
$i;fuse)]]
(wrap (|>. functionI
applyI))))
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index f515e86ac..37ab75020 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -22,68 +22,72 @@
(L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int)))))
wrap))
-(with-expansions [ (declare D2F D2I D2L
- F2D F2I F2L
- I2B I2C I2D I2F I2L I2S
- L2D L2F L2I)
- (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
- T_BYTE T_SHORT T_INT T_LONG)
- (declare CHECKCAST NEW INSTANCEOF)
- (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD
- INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE)
- (declare DUP DUP2 DUP2_X1 DUP2_X2
- POP POP2
- SWAP)
- (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL
- IFEQ IFNE IFLT IFLE IFGT IFGE
- GOTO)
- (declare ILOAD LLOAD DLOAD ALOAD
- ISTORE LSTORE ASTORE)
- (declare IADD ISUB IMUL IDIV IREM
- LADD LSUB LMUL LDIV LREM LCMP
- FADD FSUB FMUL FDIV FREM FCMPG FCMPL
- DADD DSUB DMUL DDIV DREM DCMPG DCMPL)
- (declare IAND IOR IXOR ISHL ISHR IUSHR
- LAND LOR LXOR LSHL LSHR LUSHR)
- (declare ARRAYLENGTH NEWARRAY ANEWARRAY
- AALOAD AASTORE
- BALOAD BASTORE
- SALOAD SASTORE
- IALOAD IASTORE
- LALOAD LASTORE
- FALOAD FASTORE
- DALOAD DASTORE
- CALOAD CASTORE)
- (declare MONITORENTER MONITOREXIT)
- (declare RETURN IRETURN LRETURN DRETURN ARETURN)]
- (host;import org.objectweb.asm.Opcodes
- (#static NOP int)
-
-
-
-
-
-
-
-
-
- (#static ACONST_NULL int)
-
-
-
-
-
-
-
-
-
-
- (#static ATHROW int)
-
-
-
-
- ))
+(`` (host;import org.objectweb.asm.Opcodes
+ (#static NOP int)
+
+ ## Conversion
+ (~~ (declare D2F D2I D2L
+ F2D F2I F2L
+ I2B I2C I2D I2F I2L I2S
+ L2D L2F L2I))
+
+ ## Primitive
+ (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
+ T_BYTE T_SHORT T_INT T_LONG))
+
+ ## Class
+ (~~ (declare CHECKCAST NEW INSTANCEOF))
+
+ ## Stack
+ (~~ (declare DUP DUP_X1 DUP_X2
+ DUP2 DUP2_X1 DUP2_X2
+ POP POP2
+ SWAP))
+
+ ## Jump
+ (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL
+ IFEQ IFNE IFLT IFLE IFGT IFGE
+ GOTO))
+
+ (#static ACONST_NULL int)
+
+ ## Var
+ (~~ (declare ILOAD LLOAD DLOAD ALOAD
+ ISTORE LSTORE ASTORE))
+
+ ## Arithmetic
+ (~~ (declare IADD ISUB IMUL IDIV IREM
+ LADD LSUB LMUL LDIV LREM LCMP
+ FADD FSUB FMUL FDIV FREM FCMPG FCMPL
+ 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))
+
+ ## Member
+ (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD
+ INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE))
+
+ (#static ATHROW int)
+
+ ## Concurrency
+ (~~ (declare MONITORENTER MONITOREXIT))
+
+ ## Return
+ (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN))
+ ))
(host;import org.objectweb.asm.FieldVisitor
(visitEnd [] void))
@@ -152,7 +156,9 @@
[NOP]
## Stack
- [DUP] [DUP2] [DUP2_X1] [DUP2_X2] [POP] [POP2] [SWAP]
+ [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2]
+ [POP] [POP2]
+ [SWAP]
## Conversions
[D2F] [D2I] [D2L]
diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux
index fc6ffae1f..571ba4835 100644
--- a/new-luxc/source/luxc/generator/primitive.jvm.lux
+++ b/new-luxc/source/luxc/generator/primitive.jvm.lux
@@ -2,8 +2,9 @@
lux
(lux (control monad)
(data text/format)
- [meta #+ Monad "Meta/" Monad])
+ [meta "meta/" Monad])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -16,18 +17,18 @@
(def: #export generate-unit
(Meta $;Inst)
- (Meta/wrap ($i;string ../runtime;unit)))
+ (meta/wrap ($i;string hostL;unit)))
(def: #export (generate-bool value)
(-> Bool (Meta $;Inst))
- (Meta/wrap ($i;GETSTATIC "java.lang.Boolean"
+ (meta/wrap ($i;GETSTATIC "java.lang.Boolean"
(if value "TRUE" "FALSE")
($t;class "java.lang.Boolean" (list)))))
(do-template [ ]
[(def: #export ( value)
(-> (Meta $;Inst))
- (Meta/wrap (|>. ( value) )))]
+ (meta/wrap (|>. ( value) )))]
[generate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)]
[generate-int Int $i;long ($i;wrap #$;Long)]
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index 48a820663..fd76082a6 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -10,6 +10,7 @@
["s" syntax #+ syntax:])
[host])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -56,7 +57,7 @@
(def: $Object-Array $;Type ($t;array +1 $Object))
(def: $String $;Type ($t;class "java.lang.String" (list)))
(def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list)))
-(def: $Function $;Type ($t;class &runtime;function-class (list)))
+(def: $Function $;Type ($t;class hostL;function-class (list)))
(def: #export (install name unnamed)
(-> Text (-> Text Proc)
@@ -142,8 +143,8 @@
(def: (lux//try riskyI)
Unary
(|>. riskyI
- ($i;CHECKCAST &runtime;function-class)
- ($i;INVOKESTATIC &runtime;runtime-class "try" try-method false)))
+ ($i;CHECKCAST hostL;function-class)
+ ($i;INVOKESTATIC hostL;runtime-class "try" try-method false)))
## [[Bits]]
(do-template [ ]
@@ -263,9 +264,9 @@
[nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
[nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
[nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-class "div_nat" nat-method false)]
+ ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)]
[nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-class "rem_nat" nat-method false)]
+ ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)]
[frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD]
[frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB]
@@ -276,9 +277,9 @@
[deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
[deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
[deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-class "mul_deg" deg-method false)]
+ ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)]
[deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-class "div_deg" deg-method false)]
+ ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)]
[deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
[deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
[deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV]
@@ -296,10 +297,10 @@
[ 0]
[ -1])]
- [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)]
+ [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)]
[int//eq int//lt ($i;unwrap #$;Long) $i;LCMP]
[frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG]
- [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)]
+ [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)]
)
(do-template [ ]
@@ -317,15 +318,15 @@
[frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)]
[frac//to-deg ($i;unwrap #$;Double)
- (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "frac_to_deg"
+ (<| ($i;wrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "frac_to_deg"
($t;method (list $t;double) (#;Some $t;long) (list)) false))]
[frac//encode ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)]
[frac//decode ($i;CHECKCAST "java.lang.String")
- ($i;INVOKESTATIC &runtime;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
+ ($i;INVOKESTATIC hostL;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
[deg//to-frac ($i;unwrap #$;Long)
- (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-class "deg_to_frac"
+ (<| ($i;wrap #$;Double) ($i;INVOKESTATIC hostL;runtime-class "deg_to_frac"
($t;method (list $t;long) (#;Some $t;double) (list)) false))]
)
@@ -365,7 +366,7 @@
($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false)
($i;wrap #$;Boolean)]
[text//char ($i;CHECKCAST "java.lang.String") jvm-intI
- ($i;INVOKESTATIC &runtime;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
+ ($i;INVOKESTATIC hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
lux-intI]
)
@@ -378,7 +379,7 @@
))]
[text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI
- ($i;INVOKESTATIC &runtime;runtime-class "text_clip"
+ ($i;INVOKESTATIC hostL;runtime-class "text_clip"
($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)]
[text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)]
@@ -466,7 +467,7 @@
messageI
($i;CHECKCAST "java.lang.String")
($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false)
- ($i;string &runtime;unit)))
+ ($i;string hostL;unit)))
(def: (io//error messageI)
Unary
@@ -515,20 +516,20 @@
## [[Processes]]
(def: (process//concurrency-level [])
Nullary
- (|>. ($i;GETSTATIC &runtime;runtime-class "concurrency_level" $t;int)
+ (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int)
lux-intI))
(def: (process//future procedureI)
Unary
- (|>. procedureI ($i;CHECKCAST &runtime;function-class)
- ($i;INVOKESTATIC &runtime;runtime-class "future"
+ (|>. procedureI ($i;CHECKCAST hostL;function-class)
+ ($i;INVOKESTATIC hostL;runtime-class "future"
($t;method (list $Function) (#;Some $Object) (list)) false)))
(def: (process//schedule [millisecondsI procedureI])
Binary
(|>. millisecondsI ($i;unwrap #$;Long)
- procedureI ($i;CHECKCAST &runtime;function-class)
- ($i;INVOKESTATIC &runtime;runtime-class "schedule"
+ procedureI ($i;CHECKCAST hostL;function-class)
+ ($i;INVOKESTATIC hostL;runtime-class "schedule"
($t;method (list $t;long $Function) (#;Some $Object) (list)) false)))
## [Bundles]
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index f908c6c6e..fc6bdd01b 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -15,6 +15,7 @@
["s" syntax #+ syntax:])
[host])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -494,13 +495,13 @@
(wrap (|>. valueI
($i;unwrap primitive)
($i;PUTSTATIC class field (#$;Primitive primitive))
- ($i;string &runtime;unit))))
+ ($i;string hostL;unit))))
#;None
(wrap (|>. valueI
($i;CHECKCAST class)
($i;PUTSTATIC class field ($t;class class (list)))
- ($i;string &runtime;unit)))))
+ ($i;string hostL;unit)))))
_
(&;fail (format "Wrong syntax for '" proc "'."))))
@@ -655,7 +656,7 @@
(case returnT
#;None
(|>. returnI
- ($i;string &runtime;unit))
+ ($i;string hostL;unit))
(#;Some type)
(case type
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index d2ad42a2c..d3f99ae6a 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -7,6 +7,7 @@
[meta]
[host])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -40,20 +41,16 @@
(visitEnd [] void)
(toByteArray [] (Array byte)))
-(def: #export runtime-class Text "LuxRuntime")
-(def: #export function-class Text "LuxFunction")
-(def: #export unit Text "\u0000")
-
(def: $Object $;Type ($t;class "java.lang.Object" (list)))
(def: $Object-Array $;Type ($t;array +1 $Object))
(def: $String $;Type ($t;class "java.lang.String" (list)))
(def: #export $Stack $;Type ($t;array +1 $Object))
-(def: #export $Tuple $;Type ($t;array +1 $Object))
-(def: #export $Variant $;Type ($t;array +1 $Object))
+(def: #export $Tuple $;Type $Object-Array)
+(def: #export $Variant $;Type $Object-Array)
(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 $Function $;Type ($t;class hostL;function-class (list)))
(def: $Throwable $;Type ($t;class "java.lang.Throwable" (list)))
(def: #export logI
@@ -69,7 +66,7 @@
(def: variantI
$;Inst
- ($i;INVOKESTATIC runtime-class "variant_make" variant-method false))
+ ($i;INVOKESTATIC hostL;runtime-class "variant_make" variant-method false))
(def: #export leftI
$;Inst
@@ -93,9 +90,13 @@
$;Inst
(|>. ($i;int 0)
$i;NULL
- ($i;string unit)
+ ($i;string hostL;unit)
variantI))
+(def: #export string-concatI
+ $;Inst
+ ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false))
+
(def: #export partials-field Text "partials")
(def: #export apply-method Text "apply")
(def: #export num-apply-variants Nat +8)
@@ -108,8 +109,59 @@
$;Def
(let [store-tagI (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE)
store-flagI (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE)
- store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)]
- (|>. ($d;method #$;Public $;staticM "variant_make"
+ store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)
+ force-textMT ($t;method (list $Object) (#;Some $String) (list))]
+ (|>. ($d;method #$;Public $;staticM "force_text" force-textMT
+ (<| $i;with-label (function [@is-null])
+ $i;with-label (function [@normal-object])
+ $i;with-label (function [@array-loop])
+ $i;with-label (function [@within-bounds])
+ $i;with-label (function [@is-first])
+ $i;with-label (function [@elem-end])
+ $i;with-label (function [@fold-end])
+ (let [on-normal-objectI (|>. ($i;ALOAD +0)
+ ($i;INVOKEVIRTUAL "java.lang.Object" "toString" ($t;method (list) (#;Some $String) (list)) false))
+ on-null-objectI ($i;string "NULL")
+ arrayI (|>. ($i;ALOAD +0)
+ ($i;CHECKCAST ($t;descriptor $Object-Array)))
+ recurseI ($i;INVOKESTATIC hostL;runtime-class "force_text" force-textMT false)
+ force-elemI (|>. $i;DUP arrayI $i;SWAP $i;AALOAD recurseI)
+ swap2 (|>. $i;DUP2_X2 ## X,Y => Y,X,Y
+ $i;POP2 ## Y,X,Y => Y,X
+ )
+ add-spacingI (|>. ($i;string ", ") $i;SWAP string-concatI)
+ merge-with-totalI (|>. $i;DUP_X2 $i;POP ## TSIP => TPSI
+ swap2 ## TPSI => SITP
+ string-concatI ## SITP => SIT
+ $i;DUP_X2 $i;POP ## SIT => TSI
+ )
+ foldI (|>. $i;DUP ## TSI => TSII
+ ($i;IFEQ @is-first) ## TSI
+ force-elemI add-spacingI merge-with-totalI ($i;GOTO @elem-end)
+ ($i;label @is-first) ## TSI
+ force-elemI merge-with-totalI
+ ($i;label @elem-end) ## TSI
+ )
+ inc-idxI (|>. ($i;int 1) $i;IADD)
+ on-array-objectI (|>. ($i;string "[") ## T
+ arrayI $i;ARRAYLENGTH ## TS
+ ($i;int 0) ## TSI
+ ($i;label @array-loop) ## TSI
+ $i;DUP2
+ ($i;IF_ICMPGT @within-bounds) ## TSI
+ $i;POP2 ($i;string "]") string-concatI ($i;GOTO @fold-end)
+ ($i;label @within-bounds)
+ foldI inc-idxI ($i;GOTO @array-loop)
+ ($i;label @fold-end))])
+ (|>. ($i;ALOAD +0)
+ ($i;IFNULL @is-null)
+ ($i;ALOAD +0)
+ ($i;INSTANCEOF ($t;descriptor $Object-Array))
+ ($i;IFEQ @normal-object)
+ on-array-objectI $i;ARETURN
+ ($i;label @normal-object) on-normal-objectI $i;ARETURN
+ ($i;label @is-null) on-null-objectI $i;ARETURN)))
+ ($d;method #$;Public $;staticM "variant_make"
($t;method (list $t;int $Object $Object)
(#;Some $Variant)
(list))
@@ -120,14 +172,18 @@
store-valueI
$i;ARETURN)))))
+(def: #export force-textI
+ $;Inst
+ ($i;INVOKESTATIC hostL;runtime-class "force_text" ($t;method (list $Object) (#;Some $String) (list)) false))
+
(def: 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-class "compare_nat" compare-nat-method false) ($i;IFLT @where)))
+ less-thanI (function [@where] (|>. ($i;INVOKESTATIC hostL;runtime-class "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-class "_toUnsignedBigInteger" upcast-method false)
+ upcastI ($i;INVOKESTATIC hostL;runtime-class "_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
@@ -300,7 +356,7 @@
(let [subjectI ($i;LLOAD +0)
paramI ($i;LLOAD +2)
equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where)))
- count-leading-zerosI ($i;INVOKESTATIC runtime-class "count_leading_zeros" clz-method false)
+ count-leading-zerosI ($i;INVOKESTATIC hostL;runtime-class "count_leading_zeros" clz-method false)
calc-max-shiftI (|>. subjectI count-leading-zerosI
paramI count-leading-zerosI
($i;INVOKESTATIC "java.lang.Math" "min" ($t;method (list $t;int $t;int) (#;Some $t;int) (list)) false)
@@ -373,7 +429,7 @@
($i;int 1)
$i;AALOAD
$i;ARETURN))
- ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Stack $t;int $Object) (#;Some $Object) (list))
+ ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Variant $Tag $Flag) (#;Some $Object) (list))
(<| $i;with-label (function [@begin])
$i;with-label (function [@just-return])
$i;with-label (function [@then])
@@ -487,7 +543,7 @@
($i;label @from)
($i;ALOAD +0)
$i;NULL
- ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+ ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false)
rightI
$i;ARETURN
($i;label @to)
@@ -505,14 +561,14 @@
(Meta &common;Bytecode)
(do meta;Monad
[_ (wrap [])
- #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list)
+ #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC hostL;runtime-class (list) ["java.lang.Object" (list)] (list)
(|>. adt-methods
nat-methods
frac-methods
deg-methods
pm-methods
io-methods))]
- _ (&common;store-class runtime-class bytecode)]
+ _ (&common;store-class hostL;runtime-class bytecode)]
(wrap bytecode)))
(def: generate-function
@@ -526,24 +582,24 @@
(list/map $i;ALOAD)
$i;fuse)]
(|>. preI
- ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false)
- ($i;CHECKCAST function-class)
+ ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature (n.dec arity)) false)
+ ($i;CHECKCAST hostL;function-class)
($i;ALOAD arity)
- ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+ ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false)
$i;ARETURN)))))
(list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1)))
$d;fuse)
- bytecode ($d;abstract #$;V1.6 #$;Public $;noneC function-class (list) ["java.lang.Object" (list)] (list)
+ bytecode ($d;abstract #$;V1.6 #$;Public $;noneC hostL;function-class (list) ["java.lang.Object" (list)] (list)
(|>. ($d;field #$;Public $;finalF partials-field $t;int)
($d;method #$;Public $;noneM "" ($t;method (list $t;int) #;None (list))
(|>. ($i;ALOAD +0)
($i;INVOKESPECIAL "java.lang.Object" "" ($t;method (list) #;None (list)) false)
($i;ALOAD +0)
($i;ILOAD +1)
- ($i;PUTFIELD function-class partials-field $t;int)
+ ($i;PUTFIELD hostL;function-class partials-field $t;int)
$i;RETURN))
applyI))]
- _ (&common;store-class function-class bytecode)]
+ _ (&common;store-class hostL;function-class bytecode)]
(wrap bytecode)))
(def: #export generate
diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux
index cee5800cd..28196b914 100644
--- a/new-luxc/source/luxc/generator/structure.jvm.lux
+++ b/new-luxc/source/luxc/generator/structure.jvm.lux
@@ -3,9 +3,10 @@
(lux (control [monad #+ do])
(data text/format
(coll [list]))
- [meta #+ Monad "Meta/" Monad]
+ [meta]
[host #+ do-to])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -21,7 +22,7 @@
(def: #export (generate-tuple generate members)
(-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst))
- (do Monad
+ (do meta;Monad
[#let [size (list;size members)]
_ (&;assert "Cannot generate tuples with less than 2 elements."
(n.>= +2 size))
@@ -47,12 +48,12 @@
(def: #export (generate-variant generate tag tail? member)
(-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst))
- (do Monad
+ (do meta;Monad
[memberI (generate member)]
(wrap (|>. ($i;int (nat-to-int tag))
(flagI tail?)
memberI
- ($i;INVOKESTATIC ../runtime;runtime-class
+ ($i;INVOKESTATIC hostL;runtime-class
"variant_make"
($t;method (list $t;int $Object $Object)
(#;Some ($t;array +1 $Object))
--
cgit v1.2.3