aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
authorEduardo Julian2017-09-05 18:36:09 -0400
committerEduardo Julian2017-09-05 18:36:09 -0400
commit50cc5fbe7cc8abde05085944393fcec4c791402f (patch)
treeda706b648b3bb5e0485475a81d5b4da242aa04f5 /new-luxc/source/luxc
parent3add4d6996591897020236b5581f6ca21d4c2af8 (diff)
- Updated new compiler's code to the recent changes in the language.
- WIP: Some other changes/additions to the new compiler.
Diffstat (limited to 'new-luxc/source/luxc')
-rw-r--r--new-luxc/source/luxc/analyser.lux2
-rw-r--r--new-luxc/source/luxc/analyser/case.lux20
-rw-r--r--new-luxc/source/luxc/analyser/case/coverage.lux26
-rw-r--r--new-luxc/source/luxc/analyser/primitive.lux2
-rw-r--r--new-luxc/source/luxc/analyser/procedure.lux6
-rw-r--r--new-luxc/source/luxc/analyser/procedure/common.lux90
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux56
-rw-r--r--new-luxc/source/luxc/generator/common.jvm.lux6
-rw-r--r--new-luxc/source/luxc/generator/expr.jvm.lux2
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/def.lux6
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux133
-rw-r--r--new-luxc/source/luxc/generator/primitive.jvm.lux8
-rw-r--r--new-luxc/source/luxc/generator/procedure.jvm.lux6
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux263
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux147
-rw-r--r--new-luxc/source/luxc/generator/structure.jvm.lux16
-rw-r--r--new-luxc/source/luxc/host.jvm.lux20
-rw-r--r--new-luxc/source/luxc/lang/analysis.lux4
-rw-r--r--new-luxc/source/luxc/lang/synthesis.lux4
-rw-r--r--new-luxc/source/luxc/module.lux20
-rw-r--r--new-luxc/source/luxc/module/descriptor/annotation.lux4
-rw-r--r--new-luxc/source/luxc/parser.lux6
-rw-r--r--new-luxc/source/luxc/synthesizer.lux2
-rw-r--r--new-luxc/source/luxc/synthesizer/case.lux4
24 files changed, 492 insertions, 361 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index 6f9eda064..a7e420eec 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -52,7 +52,7 @@
[#;Nat &&primitive;analyse-nat]
[#;Int &&primitive;analyse-int]
[#;Deg &&primitive;analyse-deg]
- [#;Real &&primitive;analyse-real]
+ [#;Frac &&primitive;analyse-frac]
[#;Text &&primitive;analyse-text])
(^ (#;Tuple (list)))
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux
index 30d0a2b7a..0f5b4da4e 100644
--- a/new-luxc/source/luxc/analyser/case.lux
+++ b/new-luxc/source/luxc/analyser/case.lux
@@ -1,6 +1,6 @@
(;module:
lux
- (lux (control monad
+ (lux (control [monad #+ do]
eq)
(data [bool "B/" Eq<Bool>]
[number]
@@ -102,7 +102,7 @@
[Nat #;Nat #la;NatP]
[Int #;Int #la;IntP]
[Deg #;Deg #la;DegP]
- [Real #;Real #la;RealP]
+ [Frac #;Frac #la;FracP]
[Text #;Text #la;TextP])
(^ [cursor (#;Tuple (list))])
@@ -225,14 +225,14 @@
[[inputT inputA] (&common;with-unknown-type
(analyse input))
outputH (analyse-pattern #;None inputT patternH (analyse bodyH))
- outputT (mapM @
- (function [[patternT bodyT]]
- (analyse-pattern #;None inputT patternT (analyse bodyT)))
- branchesT)
- _ (case (foldM R;Monad<Result>
- &&coverage;merge
- (|> outputH product;left &&coverage;determine)
- (L/map (|>. product;left &&coverage;determine) outputT))
+ outputT (monad;map @
+ (function [[patternT bodyT]]
+ (analyse-pattern #;None inputT patternT (analyse bodyT)))
+ branchesT)
+ _ (case (monad;fold R;Monad<Result>
+ &&coverage;merge
+ (|> outputH product;left &&coverage;determine)
+ (L/map (|>. product;left &&coverage;determine) outputT))
(#R;Success coverage)
(if (&&coverage;total? coverage)
(wrap [])
diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux
index 88e40ac0f..cb7341d7a 100644
--- a/new-luxc/source/luxc/analyser/case/coverage.lux
+++ b/new-luxc/source/luxc/analyser/case/coverage.lux
@@ -1,6 +1,6 @@
(;module:
lux
- (lux (control monad
+ (lux (control [monad #+ do]
eq)
(data [bool "B/" Eq<Bool>]
[number]
@@ -54,7 +54,7 @@
## Primitive patterns always have partial coverage because there
## are too many possibilities as far as values go.
(^or (#la;NatP _) (#la;IntP _) (#la;DegP _)
- (#la;RealP _) (#la;TextP _))
+ (#la;FracP _) (#la;TextP _))
#Partial
## Bools are the exception, since there is only "true" and
@@ -171,17 +171,17 @@
## else
(do R;Monad<Result>
- [casesM (foldM @
- (function [[tagA coverageA] casesSF']
- (case (D;get tagA casesSF')
- (#;Some coverageSF)
- (do @
- [coverageM (merge coverageA coverageSF)]
- (wrap (D;put tagA coverageM casesSF')))
-
- #;None
- (wrap (D;put tagA coverageA casesSF'))))
- casesSF (D;entries casesA))]
+ [casesM (monad;fold @
+ (function [[tagA coverageA] casesSF']
+ (case (D;get tagA casesSF')
+ (#;Some coverageSF)
+ (do @
+ [coverageM (merge coverageA coverageSF)]
+ (wrap (D;put tagA coverageM casesSF')))
+
+ #;None
+ (wrap (D;put tagA coverageA casesSF'))))
+ casesSF (D;entries casesA))]
(wrap (if (let [case-coverages (D;values casesM)]
(and (n.= allSF (list;size case-coverages))
(list;every? total? case-coverages)))
diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux
index 9102acda5..69e4f2b07 100644
--- a/new-luxc/source/luxc/analyser/primitive.lux
+++ b/new-luxc/source/luxc/analyser/primitive.lux
@@ -20,7 +20,7 @@
[analyse-nat Nat #la;Nat]
[analyse-int Int #la;Int]
[analyse-deg Deg #la;Deg]
- [analyse-real Real #la;Real]
+ [analyse-frac Frac #la;Frac]
[analyse-text Text #la;Text]
)
diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux
index d8778844f..06ea7c324 100644
--- a/new-luxc/source/luxc/analyser/procedure.lux
+++ b/new-luxc/source/luxc/analyser/procedure.lux
@@ -1,10 +1,10 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(data [text]
text/format
(coll ["D" dict])
- maybe))
+ [maybe]))
(luxc ["&" base]
(lang ["la" analysis #+ Analysis]))
(. ["&&;" common]))
@@ -12,6 +12,6 @@
(def: #export (analyse-procedure analyse proc-name proc-args)
(-> &;Analyser Text (List Code) (Lux Analysis))
(default (&;fail (format "Unknown procedure: " (%t proc-name)))
- (do Monad<Maybe>
+ (do maybe;Monad<Maybe>
[proc (D;get proc-name &&common;procedures)]
(wrap (proc analyse proc-args)))))
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
index 1976d266d..0ba35a82e 100644
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ b/new-luxc/source/luxc/analyser/procedure/common.lux
@@ -1,6 +1,6 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(concurrency ["A" atom])
(data [text]
text/format
@@ -39,11 +39,11 @@
(let [num-actual (list;size args)]
(if (n.= num-expected num-actual)
(do Monad<Lux>
- [argsA (mapM @
- (function [[argT argC]]
- (&;with-expected-type argT
- (analyse argC)))
- (list;zip2 input-types args))
+ [argsA (monad;map @
+ (function [[argT argC]]
+ (&;with-expected-type argT
+ (analyse argC)))
+ (list;zip2 input-types args))
expected macro;expected-type
_ (&;within-type-env
(TC;check expected output-type))]
@@ -156,7 +156,7 @@
(install "int min" (special-value Int))
(install "int max" (special-value Int))
(install "int to-nat" (converter Int Nat))
- (install "int to-real" (converter Int Real))))
+ (install "int to-frac" (converter Int Frac))))
(def: deg-procs
Bundle
@@ -172,28 +172,28 @@
(install "deg reciprocal" (binary-operation Deg Nat Deg))
(install "deg min" (special-value Deg))
(install "deg max" (special-value Deg))
- (install "deg to-real" (converter Deg Real))))
+ (install "deg to-frac" (converter Deg Frac))))
-(def: real-procs
+(def: frac-procs
Bundle
(|> (D;new text;Hash<Text>)
- (install "real +" (binary-operation Real Real Real))
- (install "real -" (binary-operation Real Real Real))
- (install "real *" (binary-operation Real Real Real))
- (install "real /" (binary-operation Real Real Real))
- (install "real %" (binary-operation Real Real Real))
- (install "real =" (binary-operation Real Real Bool))
- (install "real <" (binary-operation Real Real Bool))
- (install "real smallest" (special-value Real))
- (install "real min" (special-value Real))
- (install "real max" (special-value Real))
- (install "real not-a-number" (special-value Real))
- (install "real positive-infinity" (special-value Real))
- (install "real negative-infinity" (special-value Real))
- (install "real to-deg" (converter Real Deg))
- (install "real to-int" (converter Real Int))
- (install "real to-text" (converter Real Text))
- (install "real from-text" (converter Text (type (Maybe Real))))))
+ (install "frac +" (binary-operation Frac Frac Frac))
+ (install "frac -" (binary-operation Frac Frac Frac))
+ (install "frac *" (binary-operation Frac Frac Frac))
+ (install "frac /" (binary-operation Frac Frac Frac))
+ (install "frac %" (binary-operation Frac Frac Frac))
+ (install "frac =" (binary-operation Frac Frac Bool))
+ (install "frac <" (binary-operation Frac Frac Bool))
+ (install "frac smallest" (special-value Frac))
+ (install "frac min" (special-value Frac))
+ (install "frac max" (special-value Frac))
+ (install "frac not-a-number" (special-value Frac))
+ (install "frac positive-infinity" (special-value Frac))
+ (install "frac negative-infinity" (special-value Frac))
+ (install "frac to-deg" (converter Frac Deg))
+ (install "frac to-int" (converter Frac Int))
+ (install "frac encode" (converter Frac Text))
+ (install "frac decode" (converter Text (type (Maybe Frac))))))
(def: text-procs
Bundle
@@ -246,24 +246,24 @@
(def: math-procs
Bundle
(|> (D;new text;Hash<Text>)
- (install "math cos" (unary-operation Real Real))
- (install "math sin" (unary-operation Real Real))
- (install "math tan" (unary-operation Real Real))
- (install "math acos" (unary-operation Real Real))
- (install "math asin" (unary-operation Real Real))
- (install "math atan" (unary-operation Real Real))
- (install "math cosh" (unary-operation Real Real))
- (install "math sinh" (unary-operation Real Real))
- (install "math tanh" (unary-operation Real Real))
- (install "math exp" (unary-operation Real Real))
- (install "math log" (unary-operation Real Real))
- (install "math root2" (unary-operation Real Real))
- (install "math root3" (unary-operation Real Real))
- (install "math ceil" (unary-operation Real Real))
- (install "math floor" (unary-operation Real Real))
- (install "math round" (unary-operation Real Real))
- (install "math atan2" (binary-operation Real Real Real))
- (install "math pow" (binary-operation Real Real Real))
+ (install "math cos" (unary-operation Frac Frac))
+ (install "math sin" (unary-operation Frac Frac))
+ (install "math tan" (unary-operation Frac Frac))
+ (install "math acos" (unary-operation Frac Frac))
+ (install "math asin" (unary-operation Frac Frac))
+ (install "math atan" (unary-operation Frac Frac))
+ (install "math cosh" (unary-operation Frac Frac))
+ (install "math sinh" (unary-operation Frac Frac))
+ (install "math tanh" (unary-operation Frac Frac))
+ (install "math exp" (unary-operation Frac Frac))
+ (install "math log" (unary-operation Frac Frac))
+ (install "math root2" (unary-operation Frac Frac))
+ (install "math root3" (unary-operation Frac Frac))
+ (install "math ceil" (unary-operation Frac Frac))
+ (install "math floor" (unary-operation Frac Frac))
+ (install "math round" (unary-operation Frac Frac))
+ (install "math atan2" (binary-operation Frac Frac Frac))
+ (install "math pow" (binary-operation Frac Frac Frac))
))
(def: (analyse-atom-new proc)
@@ -326,7 +326,7 @@
(D;merge nat-procs)
(D;merge int-procs)
(D;merge deg-procs)
- (D;merge real-procs)
+ (D;merge frac-procs)
(D;merge text-procs)
(D;merge array-procs)
(D;merge math-procs)
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux
index 267dfec84..ad7ad2a7a 100644
--- a/new-luxc/source/luxc/analyser/structure.lux
+++ b/new-luxc/source/luxc/analyser/structure.lux
@@ -1,6 +1,6 @@
(;module:
lux
- (lux (control monad
+ (lux (control [monad #+ do]
pipe)
[io #- run]
[function]
@@ -154,8 +154,8 @@
(analyse-product analyse membersC)))
## Must do inference...
(do @
- [membersTA (mapM @ (|>. analyse &common;with-unknown-type)
- membersC)
+ [membersTA (monad;map @ (|>. analyse &common;with-unknown-type)
+ membersC)
_ (&;within-type-env
(TC;check expected
(type;tuple (L/map product;left membersTA))))]
@@ -198,17 +198,17 @@
## canonical form (with their corresponding module identified).
(def: #export (normalize record)
(-> (List [Code Code]) (Lux (List [Ident Code])))
- (mapM Monad<Lux>
- (function [[key val]]
- (case key
- [_ (#;Tag key)]
- (do Monad<Lux>
- [key (macro;normalize key)]
- (wrap [key val]))
+ (monad;map Monad<Lux>
+ (function [[key val]]
+ (case key
+ [_ (#;Tag key)]
+ (do Monad<Lux>
+ [key (macro;normalize key)]
+ (wrap [key val]))
- _
- (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key)))))
- record))
+ _
+ (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key)))))
+ record))
## Lux already possesses the means to analyse tuples, so
## re-implementing the same functionality for records makes no sense.
@@ -234,22 +234,22 @@
"For type: " (%type recordT))))
#let [tuple-range (list;n.range +0 (n.dec size-ts))
tag->idx (D;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))]
- idx->val (foldM @
- (function [[key val] idx->val]
- (do @
- [key (macro;normalize key)]
- (case (D;get key tag->idx)
- #;None
- (&;fail (format "Tag " (%code (code;tag key))
- " does not belong to tag-set for type " (%type recordT)))
+ idx->val (monad;fold @
+ (function [[key val] idx->val]
+ (do @
+ [key (macro;normalize key)]
+ (case (D;get key tag->idx)
+ #;None
+ (&;fail (format "Tag " (%code (code;tag key))
+ " does not belong to tag-set for type " (%type recordT)))
- (#;Some idx)
- (if (D;contains? idx idx->val)
- (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key))))
- (wrap (D;put idx val idx->val))))))
- (: (D;Dict Nat Code)
- (D;new number;Hash<Nat>))
- record)
+ (#;Some idx)
+ (if (D;contains? idx idx->val)
+ (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key))))
+ (wrap (D;put idx val idx->val))))))
+ (: (D;Dict Nat Code)
+ (D;new number;Hash<Nat>))
+ record)
#let [ordered-tuple (L/map (function [idx] (assume (D;get idx idx->val)))
tuple-range)]]
(wrap [ordered-tuple recordT]))
diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux
index 0dd19d032..c5fe8fc0a 100644
--- a/new-luxc/source/luxc/generator/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/common.jvm.lux
@@ -5,7 +5,11 @@
(data ["R" result]
(coll ["d" dict])
text/format)
- [host #+ jvm-import]))
+ [host #+ jvm-import])
+ (luxc (generator (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst])))))
## [Host]
(jvm-import org.objectweb.asm.Opcodes
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index 32f8bde31..0bdebe555 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -26,7 +26,7 @@
[#ls;Nat &primitive;generate-nat]
[#ls;Int &primitive;generate-int]
[#ls;Deg &primitive;generate-deg]
- [#ls;Real &primitive;generate-real]
+ [#ls;Frac &primitive;generate-frac]
[#ls;Text &primitive;generate-text])
(#ls;Variant tag tail? member)
diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux
index 8931db940..8b961b29a 100644
--- a/new-luxc/source/luxc/generator/host/jvm/def.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/def.lux
@@ -62,7 +62,7 @@
(-> (List Text) (a;Array Text))
(let [output (host;array String (list;size values))]
(exec (L/map (function [[idx value]]
- (host;array-store idx value output))
+ (host;array-write idx value output))
(list;enumerate values))
output)))
@@ -261,8 +261,8 @@
[short-field Int $t;short host;l2s]
[int-field Int $t;int host;l2i]
[long-field Int $t;long id]
- [float-field Real $t;float host;d2f]
- [double-field Real $t;double id]
+ [float-field Frac $t;float host;d2f]
+ [double-field Frac $t;double id]
[char-field Nat $t;char (|>. nat-to-int host;l2i host;i2c)]
[string-field Text ($t;class "java.lang.String" (list)) id]
)
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index 30148c4e5..af5f6f6d8 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -22,12 +22,18 @@
(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
+ <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2
POP POP2
SWAP)
<jump> (declare IF_ICMPEQ IF_ACMPEQ IFNULL
- IFLT IFLE IFGT IFGE
- GOTO)]
+ IFEQ IFLT IFLE IFGT IFGE
+ GOTO)
+ <var> (declare ILOAD LLOAD DLOAD ALOAD
+ ISTORE LSTORE)
+ <arithmethic> (declare IADD ISUB
+ LADD LSUB LMUL LDIV LREM LCMP
+ DADD DSUB DMUL DDIV DREM DCMPG)
+ <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)]
(jvm-import org.objectweb.asm.Opcodes
<primitive>
@@ -41,11 +47,7 @@
(#static ACONST_NULL int)
- (#static ILOAD int)
- (#static LLOAD int)
- (#static ALOAD int)
-
- (#static IADD int)
+ <var>
(#static LAND int)
(#static LOR int)
@@ -54,19 +56,7 @@
(#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)
+ <arithmethic>
(#static I2L int)
(#static L2I int)
@@ -89,10 +79,7 @@
(#static ATHROW int)
- (#static RETURN int)
- (#static IRETURN int)
- (#static LRETURN int)
- (#static ARETURN int)
+ <return>
))
(jvm-import org.objectweb.asm.FieldVisitor
@@ -113,7 +100,8 @@
(visitIntInsn [int int] void)
(visitMethodInsn [int String String String boolean] void)
(visitLabel [Label] void)
- (visitJumpInsn [int Label] void))
+ (visitJumpInsn [int Label] void)
+ (visitTryCatchBlock [Label Label Label String] void))
## [Insts]
(def: #export (with-label action)
@@ -130,7 +118,7 @@
[boolean Bool id]
[int Int host;l2i]
[long Int id]
- [double Real id]
+ [double Frac id]
[char Nat (|>. nat-to-int host;l2i host;i2c)]
[string Text id]
)
@@ -152,14 +140,14 @@
(MethodVisitor.visitInsn [(prefix <name>)]))))]
## Stack
- [DUP] [DUP2_X1] [POP] [POP2] [SWAP]
-
- ## Integer arithmetic
- [IADD]
+ [DUP] [DUP2] [DUP2_X1] [DUP2_X2] [POP] [POP2] [SWAP]
## Long bitwise
[LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
+ ## Integer arithmetic
+ [IADD] [ISUB]
+
## Long arithmethic
[LADD] [LSUB] [LMUL] [LDIV] [LREM] [LCMP]
@@ -176,19 +164,18 @@
[ATHROW]
## Return
- [RETURN] [IRETURN] [LRETURN] [ARETURN]
+ [RETURN] [IRETURN] [LRETURN] [DRETURN] [ARETURN]
)
-(do-template [<name> <inst>]
+(do-template [<name>]
[(def: #export (<name> register)
(-> Nat $;Inst)
(function [visitor]
(do-to visitor
- (MethodVisitor.visitVarInsn [<inst> (nat-to-int register)]))))]
+ (MethodVisitor.visitVarInsn [(prefix <name>) (nat-to-int register)]))))]
- [ILOAD Opcodes.ILOAD]
- [LLOAD Opcodes.LLOAD]
- [ALOAD Opcodes.ALOAD]
+ [ILOAD] [LLOAD] [DLOAD] [ALOAD]
+ [ISTORE] [LSTORE]
)
(do-template [<name> <inst>]
@@ -251,10 +238,16 @@
(MethodVisitor.visitJumpInsn [(prefix <name>) @where]))))]
[IF_ICMPEQ] [IF_ACMPEQ] [IFNULL]
- [IFLT] [IFLE] [IFGT] [IFGE]
+ [IFEQ] [IFLT] [IFLE] [IFGT] [IFGE]
[GOTO]
)
+(def: #export (try @from @to @handler exception)
+ (-> $;Label $;Label $;Label Text $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitTryCatchBlock [@from @to @handler ($t;binary-name exception)]))))
+
(def: #export (label @label)
(-> $;Label $;Inst)
(function [visitor]
@@ -282,30 +275,46 @@
(|>. (int (nat-to-int size))
(ANEWARRAY ($t;descriptor type)))))
-(do-template [<wrap> <unwrap> <class> <unwrap-method> <prim>]
- [(def: #export <wrap>
- $;Inst
- (|>. (INVOKESTATIC <class> "valueOf"
- ($t;method (list <prim>)
- (#;Some ($t;class <class> (list)))
- (list))
- false)))
- (def: #export <unwrap>
- $;Inst
- (|>. (CHECKCAST <class>)
- (INVOKEVIRTUAL <class> <unwrap-method>
- ($t;method (list) (#;Some <prim>) (list))
- false)))]
-
- [wrap-boolean unwrap-boolean "java.lang.Boolean" "booleanValue" $t;boolean]
- [wrap-byte unwrap-byte "java.lang.Byte" "byteValue" $t;byte]
- [wrap-short unwrap-short "java.lang.Short" "shortValue" $t;short]
- [wrap-int unwrap-int "java.lang.Integer" "intValue" $t;int]
- [wrap-long unwrap-long "java.lang.Long" "longValue" $t;long]
- [wrap-float unwrap-float "java.lang.Float" "floatValue" $t;float]
- [wrap-double unwrap-double "java.lang.Double" "doubleValue" $t;double]
- [wrap-char unwrap-char "java.lang.Character" "charValue" $t;char]
- )
+(def: (primitive-wrapper type)
+ (-> $;Primitive Text)
+ (case type
+ #$;Boolean "java.lang.Boolean"
+ #$;Byte "java.lang.Byte"
+ #$;Short "java.lang.Short"
+ #$;Int "java.lang.Integer"
+ #$;Long "java.lang.Long"
+ #$;Float "java.lang.Float"
+ #$;Double "java.lang.Double"
+ #$;Char "java.lang.Character"))
+
+(def: (primitive-unwrap type)
+ (-> $;Primitive Text)
+ (case type
+ #$;Boolean "booleanValue"
+ #$;Byte "byteValue"
+ #$;Short "shortValue"
+ #$;Int "intValue"
+ #$;Long "longValue"
+ #$;Float "floatValue"
+ #$;Double "doubleValue"
+ #$;Char "charValue"))
+
+(def: #export (wrap type)
+ (-> $;Primitive $;Inst)
+ (let [class (primitive-wrapper type)]
+ (|>. (INVOKESTATIC class "valueOf"
+ ($t;method (list (#$;Primitive type))
+ (#;Some ($t;class class (list)))
+ (list))
+ false))))
+
+(def: #export (unwrap type)
+ (-> $;Primitive $;Inst)
+ (let [class (primitive-wrapper type)]
+ (|>. (CHECKCAST class)
+ (INVOKEVIRTUAL class (primitive-unwrap type)
+ ($t;method (list) (#;Some (#$;Primitive type)) (list))
+ false))))
(def: #export (fuse insts)
(-> (List $;Inst) $;Inst)
diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux
index 2cb01a6aa..a63aa8596 100644
--- a/new-luxc/source/luxc/generator/primitive.jvm.lux
+++ b/new-luxc/source/luxc/generator/primitive.jvm.lux
@@ -29,9 +29,9 @@
(-> <type> (Lux $;Inst))
(Lux/wrap (|>. (<load> value) <wrap>)))]
- [generate-nat Nat (|>. (:! Int) $i;long) $i;wrap-long]
- [generate-int Int $i;long $i;wrap-long]
- [generate-deg Deg (|>. (:! Int) $i;long) $i;wrap-long]
- [generate-real Real $i;double $i;wrap-double]
+ [generate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)]
+ [generate-int Int $i;long ($i;wrap #$;Long)]
+ [generate-deg Deg (|>. (:! Int) $i;long) ($i;wrap #$;Long)]
+ [generate-frac Frac $i;double ($i;wrap #$;Double)]
[generate-text Text $i;string id]
)
diff --git a/new-luxc/source/luxc/generator/procedure.jvm.lux b/new-luxc/source/luxc/generator/procedure.jvm.lux
index 258d90689..77828c952 100644
--- a/new-luxc/source/luxc/generator/procedure.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure.jvm.lux
@@ -1,9 +1,9 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(data text/format
- maybe
+ [maybe]
(coll ["d" dict])))
(luxc ["&" base]
(lang ["ls" synthesis])
@@ -14,6 +14,6 @@
(-> (-> ls;Synthesis (Lux $;Inst)) Text (List ls;Synthesis)
(Lux $;Inst))
(default (&;fail (format "Unknown procedure: " (%t name)))
- (do Monad<Maybe>
+ (do maybe;Monad<Maybe>
[proc (d;get name &&common;procedures)]
(wrap (proc generate args)))))
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index fcfba7682..106b6a0f5 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -1,6 +1,6 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(data [text]
text/format
(coll [list "L/" Functor<List> Monoid<List>]
@@ -72,7 +72,7 @@
(syntax: (arity: [name s;local-symbol] [arity s;nat])
(with-gensyms [g!proc g!name g!generate g!inputs]
(do @
- [g!input+ (seqM @ (list;repeat arity (macro;gensym "input")))]
+ [g!input+ (monad;seq @ (list;repeat arity (macro;gensym "input")))]
(wrap (list (` (def: ((~ (code;local-symbol name)) (~ g!proc))
(-> (-> (Vector (~ (code;nat arity)) $;Inst) $;Inst)
(-> Text Proc))
@@ -96,27 +96,8 @@
(arity: trinary +3)
## [Instructions]
-(def: some-method
- $;Method
- ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list)))
-
-(def: make-someI
- $;Inst
- (|>. ($i;int 1)
- ($i;string "")
- $i;DUP2_X1
- $i;POP2
- ($i;INVOKESTATIC &runtime;runtime-name "sum_make" some-method false)))
-
-(def: make-noneI
- $;Inst
- (|>. ($i;int 9)
- $i;NULL
- ($i;string &runtime;unit)
- ($i;INVOKESTATIC &runtime;runtime-name "sum_make" some-method false)))
-
-(def: lux-intI $;Inst (|>. $i;I2L $i;wrap-long))
-(def: jvm-intI $;Inst (|>. $i;unwrap-long $i;L2I))
+(def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long)))
+(def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I))
(def: (array-writeI arrayI idxI elemI)
(-> $;Inst $;Inst $;Inst
@@ -161,9 +142,9 @@
(do-template [<name> <op>]
[(def: (<name> [inputI maskI])
Binary
- (|>. inputI $i;unwrap-long
- maskI $i;unwrap-long
- <op> $i;wrap-long))]
+ (|>. inputI ($i;unwrap #$;Long)
+ maskI ($i;unwrap #$;Long)
+ <op> ($i;wrap #$;Long)))]
[bit//and $i;LAND]
[bit//or $i;LOR]
@@ -172,17 +153,17 @@
(def: (bit//count inputI)
Unary
- (|>. inputI $i;unwrap-long
+ (|>. inputI ($i;unwrap #$;Long)
($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false)
lux-intI))
(do-template [<name> <op>]
[(def: (<name> [inputI shiftI])
Binary
- (|>. inputI $i;unwrap-long
+ (|>. inputI ($i;unwrap #$;Long)
shiftI jvm-intI
<op>
- $i;wrap-long))]
+ ($i;wrap #$;Long)))]
[bit//shift-left $i;LSHL]
[bit//shift-right $i;LSHR]
@@ -203,11 +184,11 @@
$i;AALOAD
$i;DUP
($i;IFNULL @is-null)
- make-someI
+ &runtime;someI
($i;GOTO @end)
($i;label @is-null)
$i;POP
- make-noneI
+ &runtime;noneI
($i;label @end))))
(def: (array//put [arrayI idxI elemI])
@@ -240,21 +221,21 @@
Nullary
(|>. <const> <wrapper>))]
- [nat//min ($i;long 0) $i;wrap-long]
- [nat//max ($i;long -1) $i;wrap-long]
+ [nat//min ($i;long 0) ($i;wrap #$;Long)]
+ [nat//max ($i;long -1) ($i;wrap #$;Long)]
- [int//min ($i;long Long.MIN_VALUE) $i;wrap-long]
- [int//max ($i;long Long.MAX_VALUE) $i;wrap-long]
+ [int//min ($i;long Long.MIN_VALUE) ($i;wrap #$;Long)]
+ [int//max ($i;long Long.MAX_VALUE) ($i;wrap #$;Long)]
- [real//smallest ($i;double Double.MIN_VALUE) $i;wrap-double]
- [real//min ($i;double (r.* -1.0 Double.MAX_VALUE)) $i;wrap-double]
- [real//max ($i;double Double.MAX_VALUE) $i;wrap-double]
- [real//not-a-number ($i;double Double.NaN) $i;wrap-double]
- [real//positive-infinity ($i;double Double.POSITIVE_INFINITY) $i;wrap-double]
- [real//negative-infinity ($i;double Double.NEGATIVE_INFINITY) $i;wrap-double]
-
- [deg//min ($i;long 0) $i;wrap-long]
- [deg//max ($i;long -1) $i;wrap-long]
+ [frac//smallest ($i;double Double.MIN_VALUE) ($i;wrap #$;Double)]
+ [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) ($i;wrap #$;Double)]
+ [frac//max ($i;double Double.MAX_VALUE) ($i;wrap #$;Double)]
+ [frac//not-a-number ($i;double Double.NaN) ($i;wrap #$;Double)]
+ [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) ($i;wrap #$;Double)]
+ [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) ($i;wrap #$;Double)]
+
+ [deg//min ($i;long 0) ($i;wrap #$;Long)]
+ [deg//max ($i;long -1) ($i;wrap #$;Long)]
)
(do-template [<name> <unwrap> <wrap> <op>]
@@ -265,57 +246,53 @@
<op>
<wrap>))]
- [int//add $i;unwrap-long $i;wrap-long $i;LADD]
- [int//sub $i;unwrap-long $i;wrap-long $i;LSUB]
- [int//mul $i;unwrap-long $i;wrap-long $i;LMUL]
- [int//div $i;unwrap-long $i;wrap-long $i;LDIV]
- [int//rem $i;unwrap-long $i;wrap-long $i;LREM]
+ [int//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
+ [int//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
+ [int//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
+ [int//div ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV]
+ [int//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LREM]
- [nat//add $i;unwrap-long $i;wrap-long $i;LADD]
- [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
+ [nat//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
+ [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-name "div_nat" nat-method false)]
- [nat//rem $i;unwrap-long $i;wrap-long
+ [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long)
($i;INVOKESTATIC &runtime;runtime-name "rem_nat" nat-method false)]
- [real//add $i;unwrap-double $i;wrap-double $i;DADD]
- [real//sub $i;unwrap-double $i;wrap-double $i;DSUB]
- [real//mul $i;unwrap-double $i;wrap-double $i;DMUL]
- [real//div $i;unwrap-double $i;wrap-double $i;DDIV]
- [real//rem $i;unwrap-double $i;wrap-double $i;DREM]
+ [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD]
+ [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB]
+ [frac//mul ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DMUL]
+ [frac//div ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DDIV]
+ [frac//rem ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DREM]
- [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
+ [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-name "mul_deg" deg-method false)]
- [deg//div $i;unwrap-long $i;wrap-long
+ [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
($i;INVOKESTATIC &runtime;runtime-name "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]
+ [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]
)
-(do-template [<name> <reference> <unwrap> <cmp>]
- [(def: (<name> [subjectI paramI])
- Binary
- (|>. subjectI <unwrap>
- paramI <unwrap>
- <cmp>
- ($i;int <reference>)
- (predicateI $i;IF_ICMPEQ)))]
-
- [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]
-
- [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 "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 [<eq> <lt> <unwrap> <cmp>]
+ [(do-template [<name> <reference>]
+ [(def: (<name> [subjectI paramI])
+ Binary
+ (|>. subjectI <unwrap>
+ paramI <unwrap>
+ <cmp>
+ ($i;int <reference>)
+ (predicateI $i;IF_ICMPEQ)))]
+ [<eq> 0]
+ [<lt> -1])]
+
+ [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "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-name "compare_nat" compare-nat-method false)]
)
(do-template [<name> <prepare> <transform>]
@@ -324,25 +301,25 @@
(|>. inputI <prepare> <transform>))]
[nat//to-int id id]
- [nat//to-char $i;unwrap-long
+ [nat//to-char ($i;unwrap #$;Long)
(<| ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false)
$i;I2C $i;L2I)]
[int//to-nat id id]
- [int//to-real $i;unwrap-long (<| $i;wrap-double $i;L2D)]
+ [int//to-frac ($i;unwrap #$;Long) (<| ($i;wrap #$;Double) $i;L2D)]
- [real//to-int $i;unwrap-double (<| $i;wrap-long $i;D2L)]
- [real//to-deg $i;unwrap-double
- (<| $i;wrap-long ($i;INVOKESTATIC &runtime;runtime-name "real-to-deg"
- ($t;method (list $t;double) (#;Some $t;long) (list)) false))]
- [real//encode $i;unwrap-double
+ [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)]
+ [frac//to-deg ($i;unwrap #$;Double)
+ (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "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)]
- [real//decode ($i;CHECKCAST "java.lang.String")
- ($i;INVOKESTATIC &runtime;runtime-name "decode_real" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
+ [frac//decode ($i;CHECKCAST "java.lang.String")
+ ($i;INVOKESTATIC &runtime;runtime-name "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
- [deg//to-real $i;unwrap-long
- (<| $i;wrap-double ($i;INVOKESTATIC &runtime;runtime-name "deg-to-real"
- ($t;method (list $t;long) (#;Some $t;double) (list)) false))]
+ [deg//to-frac ($i;unwrap #$;Long)
+ (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-name "deg_to_frac"
+ ($t;method (list $t;long) (#;Some $t;double) (list)) false))]
)
## [[Text]]
@@ -370,7 +347,7 @@
[text//eq id id
($i;INVOKEVIRTUAL "java.lang.Object" "equals" ($t;method (list $Object) (#;Some $t;boolean) (list)) false)
- $i;wrap-boolean]
+ ($i;wrap #$;Boolean)]
[text//lt ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
($i;INVOKEVIRTUAL "java.lang.String" "compareTo" ($t;method (list $String) (#;Some $t;int) (list)) false)
(predicateI $i;IF_ICMPEQ)]
@@ -379,7 +356,7 @@
id]
[text//contains? ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false)
- $i;wrap-boolean]
+ ($i;wrap #$;Boolean)]
[text//char ($i;CHECKCAST "java.lang.String") jvm-intI
($i;INVOKESTATIC &runtime;runtime-name "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
lux-intI]
@@ -414,11 +391,11 @@
($i;int -1)
($i;IF_ICMPEQ @not-found)
lux-intI
- make-someI
+ &runtime;someI
($i;GOTO @end)
($i;label @not-found)
$i;POP
- make-noneI
+ &runtime;noneI
($i;label @end))))]
[text//index "indexOf"]
@@ -433,9 +410,9 @@
[(def: (<name> inputI)
Unary
(|>. inputI
- $i;unwrap-double
+ ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Math" <method> math-unary-method false)
- $i;wrap-double))]
+ ($i;wrap #$;Double)))]
[math//cos "cos"]
[math//sin "sin"]
@@ -457,10 +434,10 @@
(do-template [<name> <method>]
[(def: (<name> [inputI paramI])
Binary
- (|>. inputI $i;unwrap-double
- paramI $i;unwrap-double
+ (|>. inputI ($i;unwrap #$;Double)
+ paramI ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Math" <method> math-binary-method false)
- $i;wrap-double))]
+ ($i;wrap #$;Double)))]
[math//atan2 "atan2"]
[math//pow "pow"]
@@ -469,10 +446,10 @@
(def: (math//round inputI)
Unary
(|>. inputI
- $i;unwrap-double
+ ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Math" "round" ($t;method (list $t;double) (#;Some $t;long) (list)) false)
$i;L2D
- $i;wrap-double))
+ ($i;wrap #$;Double)))
## [[IO]]
(def: string-method $;Method ($t;method (list $String) #;None (list)))
@@ -502,7 +479,7 @@
(def: (io//current-time [])
Nullary
(|>. ($i;INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t;method (list) (#;Some $t;long) (list)) false)
- $i;wrap-long))
+ ($i;wrap #$;Long)))
## [[Atoms]]
(def: atom-class Text "java.util.concurrent.atomic.AtomicReference")
@@ -526,7 +503,7 @@
oldI
newI
($i;INVOKEVIRTUAL atom-class "compareAndSet" ($t;method (list $Object $Object) (#;Some $t;boolean) (list)) false)
- $i;wrap-boolean))
+ ($i;wrap #$;Boolean)))
## [[Processes]]
(def: (process//concurrency-level [])
@@ -542,7 +519,7 @@
(def: (process//schedule [millisecondsI procedureI])
Binary
- (|>. millisecondsI $i;unwrap-long
+ (|>. millisecondsI ($i;unwrap #$;Long)
procedureI ($i;CHECKCAST &runtime;function-name)
($i;INVOKESTATIC &runtime;runtime-name "schedule"
($t;method (list $t;long $Function) (#;Some $Object) (list)) false)))
@@ -594,28 +571,7 @@
(install "int min" (nullary int//min))
(install "int max" (nullary int//max))
(install "int to-nat" (unary int//to-nat))
- (install "int to-real" (unary int//to-real))))
-
-(def: real-procs
- Bundle
- (|> (D;new text;Hash<Text>)
- (install "real +" (binary real//add))
- (install "real -" (binary real//sub))
- (install "real *" (binary real//mul))
- (install "real /" (binary real//div))
- (install "real %" (binary real//rem))
- (install "real =" (binary real//eq))
- (install "real <" (binary real//lt))
- (install "real smallest" (nullary real//smallest))
- (install "real min" (nullary real//min))
- (install "real max" (nullary real//max))
- (install "real not-a-number" (nullary real//not-a-number))
- (install "real positive-infinity" (nullary real//positive-infinity))
- (install "real negative-infinity" (nullary real//negative-infinity))
- (install "real to-deg" (unary real//to-deg))
- (install "real to-int" (unary real//to-int))
- (install "real encode" (unary real//encode))
- (install "real decode" (unary real//decode))))
+ (install "int to-frac" (unary int//to-frac))))
(def: deg-procs
Bundle
@@ -631,17 +587,28 @@
(install "deg reciprocal" (binary deg//reciprocal))
(install "deg min" (nullary deg//min))
(install "deg max" (nullary deg//max))
- (install "deg to-real" (unary deg//to-real))))
+ (install "deg to-frac" (unary deg//to-frac))))
-(def: array-procs
+(def: frac-procs
Bundle
(|> (D;new text;Hash<Text>)
- (install "array new" (unary array//new))
- (install "array get" (binary array//get))
- (install "array put" (trinary array//put))
- (install "array remove" (binary array//remove))
- (install "array size" (unary array//size))
- ))
+ (install "frac +" (binary frac//add))
+ (install "frac -" (binary frac//sub))
+ (install "frac *" (binary frac//mul))
+ (install "frac /" (binary frac//div))
+ (install "frac %" (binary frac//rem))
+ (install "frac =" (binary frac//eq))
+ (install "frac <" (binary frac//lt))
+ (install "frac smallest" (nullary frac//smallest))
+ (install "frac min" (nullary frac//min))
+ (install "frac max" (nullary frac//max))
+ (install "frac not-a-number" (nullary frac//not-a-number))
+ (install "frac positive-infinity" (nullary frac//positive-infinity))
+ (install "frac negative-infinity" (nullary frac//negative-infinity))
+ (install "frac to-deg" (unary frac//to-deg))
+ (install "frac to-int" (unary frac//to-int))
+ (install "frac encode" (unary frac//encode))
+ (install "frac decode" (unary frac//decode))))
(def: text-procs
Bundle
@@ -657,6 +624,16 @@
(install "text clip" (trinary text//clip))
))
+(def: array-procs
+ Bundle
+ (|> (D;new text;Hash<Text>)
+ (install "array new" (unary array//new))
+ (install "array get" (binary array//get))
+ (install "array put" (trinary array//put))
+ (install "array remove" (binary array//remove))
+ (install "array size" (unary array//size))
+ ))
+
(def: math-procs
Bundle
(|> (D;new text;Hash<Text>)
@@ -711,7 +688,7 @@
(D;merge nat-procs)
(D;merge int-procs)
(D;merge deg-procs)
- (D;merge real-procs)
+ (D;merge frac-procs)
(D;merge text-procs)
(D;merge array-procs)
(D;merge math-procs)
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index e6a12d6fa..fe7a4b2cb 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -3,6 +3,7 @@
(lux (control monad)
(data ["R" result]
text/format)
+ [math]
[macro #+ Monad<Lux> "Lux/" Monad<Lux>]
[host #+ jvm-import do-to])
(luxc ["&" base]
@@ -44,6 +45,8 @@
(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: logI
$;Inst
@@ -52,9 +55,28 @@
(|>. outI ($i;string "LOG: ") (printI "print")
outI $i;SWAP (printI "println"))))
+(def: sum-method
+ $;Method
+ ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list)))
+
+(def: #export someI
+ $;Inst
+ (|>. ($i;int 1)
+ ($i;string "")
+ $i;DUP2_X1
+ $i;POP2
+ ($i;INVOKESTATIC runtime-name "sum_make" sum-method false)))
+
+(def: #export noneI
+ $;Inst
+ (|>. ($i;int 0)
+ $i;NULL
+ ($i;string unit)
+ ($i;INVOKESTATIC runtime-name "sum_make" sum-method false)))
+
(def: add-adt-methods
$;Def
- (let [store-tag (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) $i;wrap-int $i;AASTORE)
+ (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 "sum_make"
@@ -159,7 +181,125 @@
$i;LRETURN))))
)))
-(def: init-method $;Method ($t;method (list) #;None (list)))
+(def: frac-shiftI $;Inst ($i;double (math;pow 32.0 2.0)))
+
+(def: add-frac-methods
+ $;Def
+ (|>. ($d;method #$;Public $;staticM "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list))
+ (<| $i;with-label (function [@from])
+ $i;with-label (function [@to])
+ $i;with-label (function [@handler])
+ (|>. ($i;try @from @to @handler "java.lang.Exception")
+ ($i;label @from)
+ ($i;ALOAD +0)
+ ($i;INVOKESTATIC "java.lang.Double" "parseDouble" ($t;method (list $String) (#;Some $t;double) (list)) false)
+ ($i;wrap #$;Double)
+ someI
+ $i;ARETURN
+ ($i;label @to)
+ ($i;label @handler)
+ noneI
+ $i;ARETURN)))
+ ($d;method #$;Public $;staticM "frac_to_deg" ($t;method (list $t;double) (#;Some $t;long) (list))
+ (let [swap2 (|>. $i;DUP2_X2 $i;POP2)
+ drop-excessI (|>. ($i;double 1.0) $i;DREM)
+ shiftI (|>. frac-shiftI $i;DMUL)]
+ (|>. ($i;DLOAD +0)
+ ## Get upper half
+ drop-excessI
+ shiftI
+ ## Make a copy, so the lower half can be extracted
+ $i;DUP2
+ ## Get lower half
+ drop-excessI
+ shiftI
+ ## Turn it into a deg
+ $i;D2L
+ ## Turn the upper half into deg too
+ swap2
+ $i;D2L
+ ## Combine both pieces
+ $i;LADD
+ ## FINISH
+ $i;LRETURN
+ )))
+ ))
+
+(def: deg-bits Nat +64)
+(def: deg-method $;Method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)))
+(def: clz-method $;Method ($t;method (list $t;long) (#;Some $t;int) (list)))
+
+(def: add-deg-methods
+ $;Def
+ (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits.
+ low-half (|>. ($i;int -1) $i;I2L $i;LAND)
+ high-half (|>. ($i;int 32) $i;LUSHR)]
+ (|>. ($d;method #$;Public $;staticM "mul_deg" deg-method
+ ## Based on: http://stackoverflow.com/a/31629280/6823464
+ (let [shift-downI (|>. ($i;int 32) $i;LUSHR)
+ low-leftI (|>. ($i;LLOAD +0) low-half)
+ high-leftI (|>. ($i;LLOAD +0) high-half)
+ low-rightI (|>. ($i;LLOAD +2) low-half)
+ high-rightI (|>. ($i;LLOAD +2) high-half)
+ bottomI (|>. low-leftI low-rightI $i;LMUL)
+ middleLI (|>. high-leftI low-rightI $i;LMUL)
+ middleRI (|>. low-leftI high-rightI $i;LMUL)
+ middleI (|>. middleLI middleRI $i;LADD)
+ topI (|>. high-leftI high-rightI $i;LMUL)]
+ (|>. bottomI shift-downI
+ middleI $i;LADD shift-downI
+ topI $i;LADD
+ $i;LRETURN)))
+ ($d;method #$;Public $;staticM "count_leading_zeros" clz-method
+ (let [when-zeroI (function [@where] (|>. ($i;long 0) $i;LCMP ($i;IFEQ @where)))
+ shift-rightI (function [amount] (|>. ($i;int amount) $i;LUSHR))
+ decI (|>. ($i;int 1) $i;ISUB)]
+ (<| $i;with-label (function [@start])
+ $i;with-label (function [@done])
+ (|>. ($i;int 64)
+ ($i;label @start)
+ ($i;LLOAD +0) (when-zeroI @done)
+ ($i;LLOAD +0) (shift-rightI 1) ($i;LSTORE +0)
+ decI
+ ($i;GOTO @start)
+ ($i;label @done)
+ $i;IRETURN))))
+ ($d;method #$;Public $;staticM "div_deg" deg-method
+ (<| $i;with-label (function [@same])
+ (let [subjectI ($i;LLOAD +0)
+ paramI ($i;LLOAD +2)
+ equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where)))
+ count-leading-zerosI ($i;INVOKESTATIC runtime-name "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)
+ ($i;ISTORE +4))
+ shiftI (|>. ($i;ILOAD +4) $i;LSHL)
+ imprecise-divisionI (|>. subjectI shiftI
+ paramI shiftI high-half
+ $i;LDIV)
+ scale-downI (|>. ($i;int 32) $i;LSHL)]
+ (|>. subjectI paramI
+ (equal?I @same)
+ ## Based on: http://stackoverflow.com/a/8510587/6823464
+ ## Shifting the operands as much as possible can help
+ ## avoid some loss of precision later.
+ calc-max-shiftI
+ imprecise-divisionI
+ scale-downI
+ $i;LRETURN
+ ($i;label @same)
+ ($i;long -1) ## ~= 1.0 Degrees
+ $i;LRETURN))))
+ ($d;method #$;Public $;staticM "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list))
+ (let [highI (|>. ($i;LLOAD +0) high-half $i;L2D)
+ lowI (|>. ($i;LLOAD +0) low-half $i;L2D)
+ scaleI (|>. frac-shiftI $i;DDIV)]
+ (|>. highI scaleI
+ lowI scaleI scaleI
+ $i;DADD
+ $i;DRETURN)))
+ )))
(def: #export generate
(Lux &common;Bytecode)
@@ -168,6 +308,7 @@
#let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list)
(|>. add-adt-methods
add-nat-methods
- ))]
+ add-frac-methods
+ add-deg-methods))]
_ (&common;store-class runtime-name bytecode)]
(wrap bytecode)))
diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux
index e3a4bed75..8662aaa8d 100644
--- a/new-luxc/source/luxc/generator/structure.jvm.lux
+++ b/new-luxc/source/luxc/generator/structure.jvm.lux
@@ -1,7 +1,7 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(data text/format
(coll [list]))
[macro #+ Monad<Lux> "Lux/" Monad<Lux>]
@@ -28,13 +28,13 @@
(n.>= +2 size))
membersI (|> members
list;enumerate
- (mapM @ (function [[idx member]]
- (do @
- [memberI (generate member)]
- (wrap (|>. $i;DUP
- ($i;int (nat-to-int idx))
- memberI
- $i;AASTORE)))))
+ (monad;map @ (function [[idx member]]
+ (do @
+ [memberI (generate member)]
+ (wrap (|>. $i;DUP
+ ($i;int (nat-to-int idx))
+ memberI
+ $i;AASTORE)))))
(:: @ map $i;fuse))]
(wrap (|>. ($i;array $Object size) membersI))))
diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux
index d5b4e89b0..00957f3d4 100644
--- a/new-luxc/source/luxc/host.jvm.lux
+++ b/new-luxc/source/luxc/host.jvm.lux
@@ -1,6 +1,6 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(concurrency ["A" atom])
(data ["R" result]
[text]
@@ -8,7 +8,7 @@
(coll ["d" dict]
[array #+ Array]))
[macro #+ Monad<Lux>]
- host
+ [host #+ jvm-import do-to object]
[io])
(luxc ["&" base]
(generator ["&&;" common])
@@ -34,12 +34,12 @@
(def: ClassLoader::defineClass
Method
(case (Class.getDeclaredMethod ["defineClass"
- (|> (array (Class Object) +4)
- (array-store +0 (:! (Class Object) (class-for String)))
- (array-store +1 (Object.getClass [] (array byte +0)))
- (array-store +2 (:! (Class Object) Integer.TYPE))
- (array-store +3 (:! (Class Object) Integer.TYPE)))]
- (class-for java.lang.ClassLoader))
+ (|> (host;array (Class Object) +4)
+ (host;array-write +0 (:! (Class Object) (host;class-for String)))
+ (host;array-write +1 (Object.getClass [] (host;array byte +0)))
+ (host;array-write +2 (:! (Class Object) Integer.TYPE))
+ (host;array-write +3 (:! (Class Object) Integer.TYPE)))]
+ (host;class-for java.lang.ClassLoader))
(#R;Success method)
(do-to method
(AccessibleObject.setAccessible [true]))
@@ -52,8 +52,8 @@
(Method.invoke [loader
(array;from-list (list (:! Object class-name)
(:! Object byte-code)
- (:! Object (l2i 0))
- (:! Object (l2i (nat-to-int (array-length byte-code))))))]
+ (:! Object (host;l2i 0))
+ (:! Object (host;l2i (nat-to-int (host;array-length byte-code))))))]
ClassLoader::defineClass))
(def: (fetch-byte-code class-name store)
diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux
index 9b7c000f3..7a4ae37ac 100644
--- a/new-luxc/source/luxc/lang/analysis.lux
+++ b/new-luxc/source/luxc/lang/analysis.lux
@@ -8,7 +8,7 @@
(#NatP Nat)
(#IntP Int)
(#DegP Deg)
- (#RealP Real)
+ (#FracP Frac)
(#TextP Text)
(#TupleP (List Pattern))
(#VariantP Nat Nat Pattern)
@@ -20,7 +20,7 @@
(#Nat Nat)
(#Int Int)
(#Deg Deg)
- (#Real Real)
+ (#Frac Frac)
(#Text Text)
(#Sum (Either Analysis Analysis))
(#Product Analysis Analysis)
diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux
index ad31d0138..e8f186944 100644
--- a/new-luxc/source/luxc/lang/synthesis.lux
+++ b/new-luxc/source/luxc/lang/synthesis.lux
@@ -11,7 +11,7 @@
(#NatP Nat)
(#IntP Int)
(#DegP Deg)
- (#RealP Real)
+ (#FracP Frac)
(#TextP Text)
(#VariantP (Either Nat Nat) (Path' s))
(#TupleP (Either Nat Nat) (Path' s))
@@ -26,7 +26,7 @@
(#Nat Nat)
(#Int Int)
(#Deg Deg)
- (#Real Real)
+ (#Frac Frac)
(#Text Text)
(#Variant Nat Bool Synthesis)
(#Tuple (List Synthesis))
diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux
index b53ceefed..68c43c0c1 100644
--- a/new-luxc/source/luxc/module.lux
+++ b/new-luxc/source/luxc/module.lux
@@ -1,6 +1,6 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(data [text "T/" Eq<Text>]
text/format
["R" result]
@@ -118,15 +118,15 @@
(-> Text (List Text) (Lux Unit))
(do Monad<Lux>
[bindings (tags-by-module module-name)
- _ (mapM @
- (function [tag]
- (case (&;pl-get tag bindings)
- #;None
- (wrap [])
-
- (#;Some _)
- (&;fail (format "Cannot re-declare tag: " tag))))
- tags)]
+ _ (monad;map @
+ (function [tag]
+ (case (&;pl-get tag bindings)
+ #;None
+ (wrap [])
+
+ (#;Some _)
+ (&;fail (format "Cannot re-declare tag: " tag))))
+ tags)]
(wrap [])))
(def: #export (declare-tags tags exported? type)
diff --git a/new-luxc/source/luxc/module/descriptor/annotation.lux b/new-luxc/source/luxc/module/descriptor/annotation.lux
index ed5419974..299616e6b 100644
--- a/new-luxc/source/luxc/module/descriptor/annotation.lux
+++ b/new-luxc/source/luxc/module/descriptor/annotation.lux
@@ -21,7 +21,7 @@
[nat-signal "N"]
[int-signal "I"]
[deg-signal "D"]
- [real-signal "R"]
+ [frac-signal "R"]
[text-signal "T"]
[list-signal "%"]
[dict-signal "#"]
@@ -51,7 +51,7 @@
[#;NatA nat-signal %n]
[#;IntA int-signal %i]
[#;DegA deg-signal %d]
- [#;RealA real-signal %r]
+ [#;FracA frac-signal %r]
[#;TextA text-signal %t]
[#;IdentA ident-signal %ident]
[#;ListA list-signal (&;encode-list encode-ann-value)]
diff --git a/new-luxc/source/luxc/parser.lux b/new-luxc/source/luxc/parser.lux
index 9778eb465..d061fdda5 100644
--- a/new-luxc/source/luxc/parser.lux
+++ b/new-luxc/source/luxc/parser.lux
@@ -232,7 +232,7 @@
rich-digits^)
number;Codec<Text,Int>]
- [parse-real #;Real
+ [parse-frac #;Frac
($_ l;seq
(p;default "" (l;one-of "-"))
rich-digits^
@@ -243,7 +243,7 @@
(l;one-of "eE")
(p;default "" (l;one-of "+-"))
(l;many l;decimal))))
- number;Codec<Text,Real>]
+ number;Codec<Text,Frac>]
[parse-deg #;Deg
(l;seq (l;one-of ".")
@@ -512,7 +512,7 @@
(parse-record where parse-ast)
(parse-bool where)
(parse-nat where)
- (parse-real where)
+ (parse-frac where)
(parse-int where)
(parse-deg where)
(parse-symbol where)
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
index bd6220337..9cfcc020e 100644
--- a/new-luxc/source/luxc/synthesizer.lux
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -38,7 +38,7 @@
[#la;Nat #ls;Nat]
[#la;Int #ls;Int]
[#la;Deg #ls;Deg]
- [#la;Real #ls;Real]
+ [#la;Frac #ls;Frac]
[#la;Text #ls;Text]
[#la;Definition #ls;Definition])
diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux
index ee2ef84b0..8221b4f8d 100644
--- a/new-luxc/source/luxc/synthesizer/case.lux
+++ b/new-luxc/source/luxc/synthesizer/case.lux
@@ -20,7 +20,7 @@
[#la;NatP #ls;NatP]
[#la;IntP #ls;IntP]
[#la;DegP #ls;DegP]
- [#la;RealP #ls;RealP]
+ [#la;FracP #ls;FracP]
[#la;TextP #ls;TextP])
(#la;TupleP membersP)
@@ -66,7 +66,7 @@
[#ls;NatP n.=]
[#ls;IntP i.=]
[#ls;DegP d.=]
- [#ls;RealP r.=]
+ [#ls;FracP f.=]
[#ls;TextP T/=])
(^template [<tag> <side>]