aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator
diff options
context:
space:
mode:
authorEduardo Julian2017-11-01 00:51:45 -0400
committerEduardo Julian2017-11-01 00:51:45 -0400
commit012f6bd41e527479dddbccbdab10daa78fd9a0fd (patch)
tree621f344a09acd52736f343d94582b3f1a2f0c5f9 /new-luxc/source/luxc/generator
parent71d7a4c7206155e09f3e1e1d8699561ea6967382 (diff)
- Re-organized code-generation, and re-named it "translation".
Diffstat (limited to 'new-luxc/source/luxc/generator')
-rw-r--r--new-luxc/source/luxc/generator/case.jvm.lux225
-rw-r--r--new-luxc/source/luxc/generator/common.jvm.lux131
-rw-r--r--new-luxc/source/luxc/generator/eval.jvm.lux81
-rw-r--r--new-luxc/source/luxc/generator/expression.jvm.lux76
-rw-r--r--new-luxc/source/luxc/generator/function.jvm.lux333
-rw-r--r--new-luxc/source/luxc/generator/primitive.jvm.lux36
-rw-r--r--new-luxc/source/luxc/generator/procedure.jvm.lux24
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux708
-rw-r--r--new-luxc/source/luxc/generator/procedure/host.jvm.lux763
-rw-r--r--new-luxc/source/luxc/generator/reference.jvm.lux31
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux608
-rw-r--r--new-luxc/source/luxc/generator/statement.jvm.lux82
-rw-r--r--new-luxc/source/luxc/generator/structure.jvm.lux59
13 files changed, 0 insertions, 3157 deletions
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux
deleted file mode 100644
index a9ea4482a..000000000
--- a/new-luxc/source/luxc/generator/case.jvm.lux
+++ /dev/null
@@ -1,225 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data text/format)
- [meta "meta/" Monad<Meta>])
- (luxc ["_" base]
- [";L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$i" inst]))
- (lang ["ls" synthesis]))
- [../runtime])
-
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-
-(def: (pop-altI stack-depth)
- (-> Nat $;Inst)
- (case stack-depth
- +0 id
- +1 $i;POP
- +2 $i;POP2
- _ ## (n.> +2)
- (|>. $i;POP2
- (pop-altI (n.- +2 stack-depth)))))
-
-(def: peekI
- $;Inst
- (|>. $i;DUP
- ($i;INVOKESTATIC hostL;runtime-class
- "pm_peek"
- ($t;method (list ../runtime;$Stack)
- (#;Some $Object)
- (list))
- false)))
-
-(def: popI
- $;Inst
- (|>. ($i;INVOKESTATIC hostL;runtime-class
- "pm_pop"
- ($t;method (list ../runtime;$Stack)
- (#;Some ../runtime;$Stack)
- (list))
- false)))
-
-(def: pushI
- $;Inst
- (|>. ($i;INVOKESTATIC hostL;runtime-class
- "pm_push"
- ($t;method (list ../runtime;$Stack $Object)
- (#;Some ../runtime;$Stack)
- (list))
- false)))
-
-(exception: #export Unrecognized-Path)
-
-(def: (generate-path' generate stack-depth @else @end path)
- (-> (-> ls;Synthesis (Meta $;Inst))
- Nat $;Label $;Label ls;Path (Meta $;Inst))
- (case path
- (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))])
- (do meta;Monad<Meta>
- [bodyI (generate bodyS)]
- (wrap (|>. (pop-altI stack-depth)
- bodyI
- ($i;GOTO @end))))
-
- (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))])
- (meta/wrap popI)
-
- (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))])
- (meta/wrap (|>. peekI
- ($i;ASTORE register)
- popI))
-
- [_ (#;Bool value)]
- (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)]
- (|>. peekI
- ($i;unwrap #$;Boolean)
- (jumpI @else))))
-
- (^template [<tag> <prep>]
- [_ (<tag> value)]
- (meta/wrap (|>. peekI
- ($i;unwrap #$;Long)
- ($i;long (|> value <prep>))
- $i;LCMP
- ($i;IFNE @else))))
- ([#;Nat (:! Int)]
- [#;Int (: Int)]
- [#;Deg (:! Int)])
-
- [_ (#;Frac value)]
- (meta/wrap (|>. peekI
- ($i;unwrap #$;Double)
- ($i;double value)
- $i;DCMPL
- ($i;IFNE @else)))
-
- [_ (#;Text value)]
- (meta/wrap (|>. peekI
- ($i;string value)
- ($i;INVOKEVIRTUAL "java.lang.Object"
- "equals"
- ($t;method (list $Object)
- (#;Some $t;boolean)
- (list))
- false)
- ($i;IFEQ @else)))
-
- (^template [<special> <method>]
- (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))])
- (do meta;Monad<Meta>
- [subI (generate-path' generate stack-depth @else @end subP)]
- (wrap (case idx
- +0
- (|>. peekI
- ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
- ($i;int 0)
- $i;AALOAD
- pushI
- subI)
-
- _
- (|>. peekI
- ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
- ($i;int (nat-to-int idx))
- ($i;INVOKESTATIC hostL;runtime-class
- <method>
- ($t;method (list ../runtime;$Tuple $t;int)
- (#;Some $Object)
- (list))
- false)
- pushI
- subI)))))
- (["lux case tuple left" "pm_left"]
- ["lux case tuple right" "pm_right"])
-
- (^template [<special> <flag>]
- (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))])
- (do meta;Monad<Meta>
- [subI (generate-path' generate stack-depth @else @end subP)]
- (wrap (<| $i;with-label (function [@success])
- $i;with-label (function [@fail])
- (|>. peekI
- ($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
- ($i;int (nat-to-int idx))
- <flag>
- ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
- ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
- (#;Some ../runtime;$Datum)
- (list))
- false)
- $i;DUP
- ($i;IFNULL @fail)
- ($i;GOTO @success)
- ($i;label @fail)
- $i;POP
- ($i;GOTO @else)
- ($i;label @success)
- pushI
- subI)))))
- (["lux case variant left" $i;NULL]
- ["lux case variant right" ($i;string "")])
-
- (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))])
- (do meta;Monad<Meta>
- [leftI (generate-path' generate stack-depth @else @end leftP)
- rightI (generate-path' generate stack-depth @else @end rightP)]
- (wrap (|>. leftI
- rightI)))
-
- (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))])
- (do meta;Monad<Meta>
- [@alt-else $i;make-label
- leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP)
- rightI (generate-path' generate stack-depth @else @end rightP)]
- (wrap (|>. $i;DUP
- leftI
- ($i;label @alt-else)
- $i;POP
- rightI)))
-
- _
- (_;throw Unrecognized-Path (%code path))))
-
-(def: (generate-path generate path @end)
- (-> (-> ls;Synthesis (Meta $;Inst))
- ls;Path $;Label (Meta $;Inst))
- (do meta;Monad<Meta>
- [@else $i;make-label
- pathI (generate-path' generate +1 @else @end path)]
- (wrap (|>. pathI
- ($i;label @else)
- $i;POP
- ($i;INVOKESTATIC hostL;runtime-class
- "pm_fail"
- ($t;method (list) #;None (list))
- false)
- $i;NULL
- ($i;GOTO @end)))))
-
-(def: #export (generate-case generate valueS path)
- (-> (-> ls;Synthesis (Meta $;Inst))
- ls;Synthesis ls;Path (Meta $;Inst))
- (do meta;Monad<Meta>
- [@end $i;make-label
- valueI (generate valueS)
- pathI (generate-path 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<Meta>
- [inputI (generate inputS)
- exprI (generate exprS)]
- (wrap (|>. inputI
- ($i;ASTORE register)
- exprI))))
diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux
deleted file mode 100644
index 1870530c2..000000000
--- a/new-luxc/source/luxc/generator/common.jvm.lux
+++ /dev/null
@@ -1,131 +0,0 @@
-(;module:
- [lux #- function]
- (lux (control ["ex" exception #+ exception:])
- [io]
- (concurrency ["A" atom])
- (data ["e" error]
- [text]
- text/format
- (coll [dict #+ Dict]))
- [host]
- (world [blob #+ Blob]))
- (luxc (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))))
-
-(host;import org.objectweb.asm.Opcodes
- (#static V1_6 int))
-
-(host;import java.lang.Object)
-
-(host;import (java.lang.Class a))
-
-(host;import java.lang.ClassLoader
- (loadClass [String] (Class Object)))
-
-(type: #export Bytecode (host;type (Array byte)))
-
-(type: #export Class-Store (A;Atom (Dict Text Bytecode)))
-
-(type: #export Artifacts (Dict Text Blob))
-
-(type: #export Host
- {#loader ClassLoader
- #store Class-Store
- #function-class (Maybe Text)
- #artifacts Artifacts})
-
-(exception: Unknown-Class)
-(exception: Class-Already-Stored)
-(exception: No-Function-Being-Compiled)
-(exception: Cannot-Overwrite-Artifact)
-
-(def: #export (with-artifacts action)
- (All [a] (-> (Meta a) (Meta [Artifacts a])))
- (;function [compiler]
- (case (action (update@ #;host
- (|>. (:! Host)
- (set@ #artifacts (dict;new text;Hash<Text>))
- (:! Void))
- compiler))
- (#e;Success [compiler' output])
- (#e;Success [(update@ #;host
- (|>. (:! Host)
- (set@ #artifacts (|> (get@ #;host compiler) (:! Host) (get@ #artifacts)))
- (:! Void))
- compiler')
- [(|> compiler' (get@ #;host) (:! Host) (get@ #artifacts))
- output]])
-
- (#e;Error error)
- (#e;Error error))))
-
-(def: #export (record-artifact name content)
- (-> Text Blob (Meta Unit))
- (;function [compiler]
- (if (|> compiler (get@ #;host) (:! Host) (get@ #artifacts) (dict;contains? name))
- (ex;throw Cannot-Overwrite-Artifact name)
- (#e;Success [(update@ #;host
- (|>. (:! Host)
- (update@ #artifacts (dict;put name content))
- (:! Void))
- compiler)
- []]))))
-
-(def: #export (store-class name byte-code)
- (-> Text Bytecode (Meta Unit))
- (;function [compiler]
- (let [store (|> (get@ #;host compiler)
- (:! Host)
- (get@ #store))]
- (if (dict;contains? name (|> store A;get io;run))
- (ex;throw Class-Already-Stored name)
- (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))])
- ))))
-
-(def: #export (load-class name)
- (-> Text (Meta (Class Object)))
- (;function [compiler]
- (let [host (:! Host (get@ #;host compiler))
- store (|> host (get@ #store) A;get io;run)]
- (if (dict;contains? name store)
- (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
- (ex;throw Unknown-Class name)))))
-
-(def: #export (with-function class expr)
- (All [a] (-> Text (Meta a) (Meta a)))
- (;function [compiler]
- (let [host (:! Host (get@ #;host compiler))
- old-function-class (get@ #function-class host)]
- (case (expr (set@ #;host
- (:! Void (set@ #function-class
- (#;Some class)
- host))
- compiler))
- (#e;Success [compiler' output])
- (#e;Success [(update@ #;host
- (|>. (:! Host)
- (set@ #function-class old-function-class)
- (:! Void))
- compiler')
- output])
-
- (#e;Error error)
- (#e;Error error)))))
-
-(def: #export function
- (Meta Text)
- (;function [compiler]
- (let [host (:! Host (get@ #;host compiler))]
- (case (get@ #function-class host)
- #;None
- (ex;throw No-Function-Being-Compiled "")
-
- (#;Some function-class)
- (#e;Success [compiler function-class])))))
-
-(def: #export bytecode-version Int Opcodes.V1_6)
-
-(def: #export value-field Text "_value")
-(def: #export $Object $;Type ($t;class "java.lang.Object" (list)))
diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux
deleted file mode 100644
index 2f0ce1c24..000000000
--- a/new-luxc/source/luxc/generator/eval.jvm.lux
+++ /dev/null
@@ -1,81 +0,0 @@
-(;module:
- lux
- (lux (control monad)
- (data ["R" error]
- text/format)
- [meta #+ Monad<Meta> "Meta/" Monad<Meta>]
- [host #+ do-to])
- (luxc ["&" base]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- (lang ["la" analysis]
- ["ls" synthesis])
- (generator ["&;" common])
- ))
-
-(host;import java.lang.Object)
-(host;import java.lang.String)
-
-(host;import java.lang.reflect.Field
- (get [Object] Object))
-
-(host;import (java.lang.Class a)
- (getField [String] Field))
-
-(host;import org.objectweb.asm.Opcodes
- (#static ACC_PUBLIC int)
- (#static ACC_SUPER int)
- (#static ACC_FINAL int)
- (#static ACC_STATIC int)
- (#static PUTSTATIC int)
- (#static RETURN int)
- (#static V1_6 int)
- )
-
-(host;import org.objectweb.asm.MethodVisitor
- (visitCode [] void)
- (visitEnd [] void)
- (visitLdcInsn [Object] void)
- (visitFieldInsn [int String String String] void)
- (visitInsn [int] void)
- (visitMaxs [int int] void))
-
-(host;import org.objectweb.asm.FieldVisitor
- (visitEnd [] void))
-
-(host;import org.objectweb.asm.ClassWriter
- (#static COMPUTE_MAXS int)
- (new [int])
- (visit [int int String String String (Array String)] void)
- (visitEnd [] void)
- (visitField [int String String String Object] FieldVisitor)
- (visitMethod [int String String String (Array String)] MethodVisitor)
- (toByteArray [] (Array byte)))
-
-(def: #export (eval valueI)
- (-> $;Inst (Meta Top))
- (do Monad<Meta>
- [class-name (:: @ map %code (meta;gensym "eval"))
- #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
- (ClassWriter.visit [&common;bytecode-version
- (i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_SUPER)
- class-name
- (host;null)
- "java/lang/Object"
- (host;null)]))
- ($d;field #$;Public ($_ $;++F $;finalF $;staticF)
- &common;value-field &common;$Object)
- ($d;method #$;Public ($_ $;++M $;staticM $;strictM)
- "<clinit>"
- ($t;method (list) #;None (list))
- (|>. valueI
- ($i;PUTSTATIC class-name &common;value-field &common;$Object)
- $i;RETURN)))
- bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
- _ (&common;store-class class-name bytecode)
- class (&common;load-class class-name)]
- (wrap (|> class
- (Class.getField [&common;value-field])
- (Field.get (host;null))))))
diff --git a/new-luxc/source/luxc/generator/expression.jvm.lux b/new-luxc/source/luxc/generator/expression.jvm.lux
deleted file mode 100644
index 798998510..000000000
--- a/new-luxc/source/luxc/generator/expression.jvm.lux
+++ /dev/null
@@ -1,76 +0,0 @@
-(;module:
- lux
- (lux (control monad
- ["ex" exception #+ exception:]
- ["p" parser])
- (data ["e" error]
- text/format)
- [meta]
- (meta ["s" syntax]))
- (luxc ["&" base]
- (host ["$" jvm])
- (lang ["ls" synthesis]
- [";L" variable #+ Variable Register])
- (generator ["&;" common]
- ["&;" primitive]
- ["&;" structure]
- ["&;" eval]
- ["&;" procedure]
- ["&;" function]
- ["&;" reference]
- [";G" case])))
-
-(exception: #export Unrecognized-Synthesis)
-
-(def: #export (generate synthesis)
- (-> ls;Synthesis (Meta $;Inst))
- (case synthesis
- (^code [])
- &primitive;generate-unit
-
- (^code [(~ singleton)])
- (generate singleton)
-
- (^template [<tag> <generator>]
- [_ (<tag> value)]
- (<generator> value))
- ([#;Bool &primitive;generate-bool]
- [#;Nat &primitive;generate-nat]
- [#;Int &primitive;generate-int]
- [#;Deg &primitive;generate-deg]
- [#;Frac &primitive;generate-frac]
- [#;Text &primitive;generate-text])
-
- (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Bool last?)]) (~ valueS)))
- (&structure;generate-variant generate tag last? valueS)
-
- (^code [(~@ members)])
- (&structure;generate-tuple generate members)
-
- (^ [_ (#;Form (list [_ (#;Int var)]))])
- (if (variableL;captured? var)
- (&reference;generate-captured var)
- (&reference;generate-variable var))
-
- [_ (#;Symbol definition)]
- (&reference;generate-definition definition)
-
- (^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ exprS)))
- (caseG;generate-let generate register inputS exprS)
-
- (^code ("lux case" (~ inputS) (~ pathPS)))
- (caseG;generate-case generate inputS pathPS)
-
- (^multi (^code ("lux function" (~ [_ (#;Nat arity)]) [(~@ environment)] (~ bodyS)))
- [(s;run environment (p;some s;int)) (#e;Success environment)])
- (&function;generate-function generate environment arity bodyS)
-
- (^code ("lux call" (~ functionS) (~@ argsS)))
- (&function;generate-call generate functionS argsS)
-
- (^code ((~ [_ (#;Text procedure)]) (~@ argsS)))
- (&procedure;generate-procedure generate procedure argsS)
-
- _
- (&;throw Unrecognized-Synthesis (%code synthesis))
- ))
diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux
deleted file mode 100644
index 310f4d7a0..000000000
--- a/new-luxc/source/luxc/generator/function.jvm.lux
+++ /dev/null
@@ -1,333 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do])
- (data text/format
- (coll [list "list/" Functor<List> Monoid<List>]))
- [meta])
- (luxc ["&" base]
- [";L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- (lang ["la" analysis]
- ["ls" synthesis]
- [";L" variable #+ Variable])
- (generator ["&;" common]
- ["&;" runtime])))
-
-
-(def: arity-field Text "arity")
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-
-(do-template [<name> <prefix>]
- [(def: #export (<name> idx)
- (-> Nat Text)
- (|> idx nat-to-int %i (format <prefix>)))]
-
- [captured "c"]
- [partial "p"]
- )
-
-(def: (poly-arg? arity)
- (-> ls;Arity Bool)
- (n.> +1 arity))
-
-(def: (reset-method class)
- (-> Text $;Method)
- ($t;method (list) (#;Some ($t;class class (list))) (list)))
-
-(def: (captured-args env)
- (-> (List Variable) (List $;Type))
- (list;repeat (list;size env) $Object))
-
-(def: (init-method env arity)
- (-> (List Variable) ls;Arity $;Method)
- (if (poly-arg? arity)
- ($t;method (list;concat (list (captured-args env)
- (list $t;int)
- (list;repeat (n.dec arity) $Object)))
- #;None
- (list))
- ($t;method (captured-args env) #;None (list))))
-
-(def: (implementation-method arity)
- ($t;method (list;repeat arity $Object) (#;Some $Object) (list)))
-
-(def: get-amount-of-partialsI
- $;Inst
- (|>. ($i;ALOAD +0)
- ($i;GETFIELD hostL;function-class &runtime;partials-field $t;int)))
-
-(def: (load-fieldI class field)
- (-> Text Text $;Inst)
- (|>. ($i;ALOAD +0)
- ($i;GETFIELD class field $Object)))
-
-(def: (inputsI start amount)
- (-> $;Register Nat $;Inst)
- (|> (list;n.range start (n.+ start (n.dec amount)))
- (list/map $i;ALOAD)
- $i;fuse))
-
-(def: (applysI start amount)
- (-> $;Register Nat $;Inst)
- (let [max-args (n.min amount &runtime;num-apply-variants)
- 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 hostL;function-class)
- (inputsI start max-args)
- ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature max-args) false)
- later-applysI)))
-
-(def: (inc-intI by)
- (-> Nat $;Inst)
- (|>. ($i;int (nat-to-int by))
- $i;IADD))
-
-(def: (nullsI amount)
- (-> Nat $;Inst)
- (|> $i;NULL
- (list;repeat amount)
- $i;fuse))
-
-(def: (with-captured env)
- (-> (List Variable) $;Def)
- (|> (list;enumerate env)
- (list/map (function [[env-idx env-source]]
- ($d;field #$;Private $;finalF (captured env-idx) $Object)))
- $d;fuse))
-
-(def: (with-partial arity)
- (-> ls;Arity $;Def)
- (if (poly-arg? arity)
- (|> (list;n.range +0 (n.- +2 arity))
- (list/map (function [idx]
- ($d;field #$;Private $;finalF (partial idx) $Object)))
- $d;fuse)
- id))
-
-(def: (instance class arity env)
- (-> Text ls;Arity (List Variable) $;Inst)
- (let [captureI (|> env
- (list/map (function [source]
- (if (variableL;captured? source)
- ($i;GETFIELD class (captured (variableL;captured-register source)) $Object)
- ($i;ALOAD (int-to-nat source)))))
- $i;fuse)
- argsI (if (poly-arg? arity)
- (|> (nullsI (n.dec arity))
- (list ($i;int 0))
- $i;fuse)
- id)]
- (|>. ($i;NEW class)
- $i;DUP
- captureI
- argsI
- ($i;INVOKESPECIAL class "<init>" (init-method env arity) false))))
-
-(def: (with-reset class arity env)
- (-> Text ls;Arity (List Variable) $;Def)
- ($d;method #$;Public $;noneM "reset" (reset-method class)
- (if (poly-arg? arity)
- (let [env-size (list;size env)
- captureI (|> (case env-size
- +0 (list)
- _ (list;n.range +0 (n.dec env-size)))
- (list/map (function [source]
- (|>. ($i;ALOAD +0)
- ($i;GETFIELD class (captured source) $Object))))
- $i;fuse)
- argsI (|> (nullsI (n.dec arity))
- (list ($i;int 0))
- $i;fuse)]
- (|>. ($i;NEW class)
- $i;DUP
- captureI
- argsI
- ($i;INVOKESPECIAL class "<init>" (init-method env arity) false)
- $i;ARETURN))
- (|>. ($i;ALOAD +0)
- $i;ARETURN))))
-
-(def: (with-implementation arity @begin bodyI)
- (-> Nat $;Label $;Inst $;Def)
- ($d;method #$;Public $;strictM "impl" (implementation-method arity)
- (|>. ($i;label @begin)
- bodyI
- $i;ARETURN)))
-
-(def: function-init-method
- $;Method
- ($t;method (list $t;int) #;None (list)))
-
-(def: (function-init arity env-size)
- (-> ls;Arity Nat $;Inst)
- (if (n.= +1 arity)
- (|>. ($i;int 0)
- ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false))
- (|>. ($i;ILOAD (n.inc env-size))
- ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false))))
-
-(def: (with-init class env arity)
- (-> Text (List Variable) ls;Arity $;Def)
- (let [env-size (list;size env)
- offset-partial (: (-> Nat Nat)
- (|>. n.inc (n.+ env-size)))
- store-capturedI (|> (case env-size
- +0 (list)
- _ (list;n.range +0 (n.dec env-size)))
- (list/map (function [register]
- (|>. ($i;ALOAD +0)
- ($i;ALOAD (n.inc register))
- ($i;PUTFIELD class (captured register) $Object))))
- $i;fuse)
- store-partialI (if (poly-arg? arity)
- (|> (list;n.range +0 (n.- +2 arity))
- (list/map (function [idx]
- (let [register (offset-partial idx)]
- (|>. ($i;ALOAD +0)
- ($i;ALOAD (n.inc register))
- ($i;PUTFIELD class (partial idx) $Object)))))
- $i;fuse)
- id)]
- ($d;method #$;Public $;noneM "<init>" (init-method env arity)
- (|>. ($i;ALOAD +0)
- (function-init arity env-size)
- store-capturedI
- store-partialI
- $i;RETURN))))
-
-(def: (with-apply class env function-arity @begin bodyI apply-arity)
- (-> Text (List Variable) ls;Arity $;Label $;Inst ls;Arity
- $;Def)
- (let [num-partials (n.dec function-arity)
- @default ($;new-label [])
- @labels (list/map $;new-label (list;repeat num-partials []))
- arity-over-extent (|> (nat-to-int function-arity) (i.- (nat-to-int apply-arity)))
- casesI (|> (list/compose @labels (list @default))
- (list;zip2 (list;n.range +0 num-partials))
- (list/map (function [[stage @label]]
- (let [load-partialsI (if (n.> +0 stage)
- (|> (list;n.range +0 (n.dec stage))
- (list/map (|>. partial (load-fieldI class)))
- $i;fuse)
- id)]
- (cond (i.= arity-over-extent (nat-to-int stage))
- (|>. ($i;label @label)
- ($i;ALOAD +0)
- (when (n.> +0 stage)
- ($i;INVOKEVIRTUAL class "reset" (reset-method class) false))
- load-partialsI
- (inputsI +1 apply-arity)
- ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
- $i;ARETURN)
-
- (i.> arity-over-extent (nat-to-int stage))
- (let [args-to-completion (|> function-arity (n.- stage))
- args-left (|> apply-arity (n.- args-to-completion))]
- (|>. ($i;label @label)
- ($i;ALOAD +0)
- ($i;INVOKEVIRTUAL class "reset" (reset-method class) false)
- load-partialsI
- (inputsI +1 args-to-completion)
- ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
- (applysI (n.inc args-to-completion) args-left)
- $i;ARETURN))
-
- ## (i.< arity-over-extent (nat-to-int stage))
- (let [env-size (list;size env)
- load-capturedI (|> (case env-size
- +0 (list)
- _ (list;n.range +0 (n.dec env-size)))
- (list/map (|>. captured (load-fieldI class)))
- $i;fuse)]
- (|>. ($i;label @label)
- ($i;NEW class)
- $i;DUP
- load-capturedI
- get-amount-of-partialsI
- (inc-intI apply-arity)
- load-partialsI
- (inputsI +1 apply-arity)
- (nullsI (|> num-partials (n.- apply-arity) (n.- stage)))
- ($i;INVOKESPECIAL class "<init>" (init-method env function-arity) false)
- $i;ARETURN))
- ))))
- $i;fuse)]
- ($d;method #$;Public $;noneM &runtime;apply-method (&runtime;apply-signature apply-arity)
- (|>. get-amount-of-partialsI
- ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int)
- @default @labels)
- casesI
- ($i;INVOKESTATIC hostL;runtime-class "apply_fail" ($t;method (list) #;None (list)) false)
- $i;NULL
- $i;ARETURN
- ))))
-
-(def: #export (with-function generate class env arity body)
- (-> (-> ls;Synthesis (Meta $;Inst))
- Text (List Variable) ls;Arity ls;Synthesis
- (Meta [$;Def $;Inst]))
- (do meta;Monad<Meta>
- [@begin $i;make-label
- bodyI (&common;with-function class (generate body))
- #let [env-size (list;size env)
- applyD (: $;Def
- (if (poly-arg? arity)
- (|> (n.min arity &runtime;num-apply-variants)
- (list;n.range +1)
- (list/map (with-apply class env arity @begin bodyI))
- (list& (with-implementation arity @begin bodyI))
- $d;fuse)
- ($d;method #$;Public $;strictM &runtime;apply-method (&runtime;apply-signature +1)
- (|>. ($i;label @begin)
- bodyI
- $i;ARETURN))))
- functionD (: $;Def
- (|>. ($d;int-field #$;Public ($_ $;++F $;staticF $;finalF) arity-field (nat-to-int arity))
- (with-captured env)
- (with-partial arity)
- (with-init class env arity)
- (with-reset class arity env)
- applyD))
- instanceI (instance class arity env)]]
- (wrap [functionD instanceI])))
-
-(def: #export (generate-function generate env arity body)
- (-> (-> ls;Synthesis (Meta $;Inst))
- (List Variable) ls;Arity ls;Synthesis
- (Meta $;Inst))
- (do meta;Monad<Meta>
- [function-class (:: @ map %code (meta;gensym "function"))
- [functionD instanceI] (with-function generate function-class env arity body)
- _ (&common;store-class function-class
- ($d;class #$;V1.6 #$;Public $;finalC
- function-class (list)
- ($;simple-class hostL;function-class) (list)
- functionD))]
- (wrap instanceI)))
-
-(def: (segment size elems)
- (All [a] (-> Nat (List a) (List (List a))))
- (let [[pre post] (list;split size elems)]
- (if (list;empty? post)
- (list pre)
- (list& pre (segment size post)))))
-
-(def: #export (generate-call generate functionS argsS)
- (-> (-> ls;Synthesis (Meta $;Inst))
- ls;Synthesis (List ls;Synthesis)
- (Meta $;Inst))
- (do meta;Monad<Meta>
- [functionI (generate functionS)
- argsI (monad;map @ generate argsS)
- #let [applyI (|> (segment &runtime;num-apply-variants argsI)
- (list/map (function [chunkI+]
- (|>. ($i;CHECKCAST hostL;function-class)
- ($i;fuse chunkI+)
- ($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/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux
deleted file mode 100644
index 637f46a85..000000000
--- a/new-luxc/source/luxc/generator/primitive.jvm.lux
+++ /dev/null
@@ -1,36 +0,0 @@
-(;module:
- lux
- (lux (control monad)
- (data text/format)
- [meta "meta/" Monad<Meta>])
- (luxc ["&" base]
- [";L" host]
- (host ["$" jvm]
- (jvm ["$i" inst]
- ["$t" type]))
- (lang ["la" analysis]
- ["ls" synthesis])
- (generator ["&;" common]))
- [../runtime])
-
-(def: #export generate-unit
- (Meta $;Inst)
- (meta/wrap ($i;string hostL;unit)))
-
-(def: #export (generate-bool value)
- (-> Bool (Meta $;Inst))
- (meta/wrap ($i;GETSTATIC "java.lang.Boolean"
- (if value "TRUE" "FALSE")
- ($t;class "java.lang.Boolean" (list)))))
-
-(do-template [<name> <type> <load> <wrap>]
- [(def: #export (<name> value)
- (-> <type> (Meta $;Inst))
- (meta/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-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
deleted file mode 100644
index 973f0e968..000000000
--- a/new-luxc/source/luxc/generator/procedure.jvm.lux
+++ /dev/null
@@ -1,24 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do])
- (data [maybe]
- text/format
- (coll [dict])))
- (luxc ["&" base]
- (host ["$" jvm])
- (lang ["ls" synthesis]))
- (. ["./;" common]
- ["./;" host]))
-
-(def: procedures
- ./common;Bundle
- (|> ./common;procedures
- (dict;merge ./host;procedures)))
-
-(def: #export (generate-procedure generate name args)
- (-> (-> ls;Synthesis (Meta $;Inst)) Text (List ls;Synthesis)
- (Meta $;Inst))
- (<| (maybe;default (&;fail (format "Unknown procedure: " (%t name))))
- (do maybe;Monad<Maybe>
- [proc (dict;get name 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
deleted file mode 100644
index dffbcb64e..000000000
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ /dev/null
@@ -1,708 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do])
- (data [text]
- text/format
- (coll [list "list/" Functor<List>]
- [dict #+ Dict]))
- [meta #+ with-gensyms]
- (meta [code]
- ["s" syntax #+ syntax:])
- [host])
- (luxc ["&" base]
- [";L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- (lang ["la" analysis]
- ["ls" synthesis])
- (generator ["&;" common]
- ["&;" runtime])))
-
-(host;import java.lang.Long
- (#static MIN_VALUE Long)
- (#static MAX_VALUE Long))
-
-(host;import java.lang.Double
- (#static MIN_VALUE Double)
- (#static MAX_VALUE Double)
- (#static NaN Double)
- (#static POSITIVE_INFINITY Double)
- (#static NEGATIVE_INFINITY Double))
-
-## [Types]
-(type: #export Generator
- (-> ls;Synthesis (Meta $;Inst)))
-
-(type: #export Proc
- (-> Generator (List ls;Synthesis) (Meta $;Inst)))
-
-(type: #export Bundle
- (Dict Text Proc))
-
-(syntax: (Vector [size s;nat] elemT)
- (wrap (list (` [(~@ (list;repeat size elemT))]))))
-
-(type: #export Nullary (-> (Vector +0 $;Inst) $;Inst))
-(type: #export Unary (-> (Vector +1 $;Inst) $;Inst))
-(type: #export Binary (-> (Vector +2 $;Inst) $;Inst))
-(type: #export Trinary (-> (Vector +3 $;Inst) $;Inst))
-
-## [Utils]
-(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: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list)))
-(def: $Function $;Type ($t;class hostL;function-class (list)))
-
-(def: #export (install name unnamed)
- (-> Text (-> Text Proc)
- (-> Bundle Bundle))
- (dict;put name (unnamed name)))
-
-(def: #export (prefix prefix bundle)
- (-> Text Bundle Bundle)
- (|> bundle
- dict;entries
- (list/map (function [[key val]] [(format prefix " " key) val]))
- (dict;from-list text;Hash<Text>)))
-
-(def: (wrong-arity proc expected actual)
- (-> Text Nat Nat Text)
- (format "Wrong number of arguments for " (%t proc) "\n"
- "Expected: " (|> expected nat-to-int %i) "\n"
- " Actual: " (|> actual nat-to-int %i)))
-
-(syntax: (arity: [name s;local-symbol] [arity s;nat])
- (with-gensyms [g!proc g!name g!generate g!inputs]
- (do @
- [g!input+ (monad;seq @ (list;repeat arity (meta;gensym "input")))]
- (wrap (list (` (def: #export ((~ (code;local-symbol name)) (~ g!proc))
- (-> (-> (;;Vector (~ (code;nat arity)) $;Inst) $;Inst)
- (-> Text ;;Proc))
- (function [(~ g!name)]
- (function [(~ g!generate) (~ g!inputs)]
- (case (~ g!inputs)
- (^ (list (~@ g!input+)))
- (do meta;Monad<Meta>
- [(~@ (|> g!input+
- (list/map (function [g!input]
- (list g!input (` ((~ g!generate) (~ g!input))))))
- list;concat))]
- ((~' wrap) ((~ g!proc) [(~@ g!input+)])))
-
- (~' _)
- (meta;fail (wrong-arity (~ g!name) +1 (list;size (~ g!inputs))))))))))))))
-
-(arity: nullary +0)
-(arity: unary +1)
-(arity: binary +2)
-(arity: trinary +3)
-
-## [Instructions]
-(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
- $;Inst)
- (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array))
- $i;DUP
- idxI jvm-intI
- elemI
- $i;AASTORE))
-
-(def: (predicateI tester)
- (-> (-> $;Label $;Inst)
- $;Inst)
- (<| $i;with-label (function [@then])
- $i;with-label (function [@end])
- (|>. (tester @then)
- ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
- ($i;GOTO @end)
- ($i;label @then)
- ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
- ($i;label @end)
- )))
-
-## [Procedures]
-## [[Lux]]
-(def: (lux//is [leftI rightI])
- Binary
- (|>. leftI
- rightI
- (predicateI $i;IF_ACMPEQ)))
-
-(def: try-method
- $;Method
- ($t;method (list $Function) (#;Some $Object-Array) (list)))
-(def: (lux//try riskyI)
- Unary
- (|>. riskyI
- ($i;CHECKCAST hostL;function-class)
- ($i;INVOKESTATIC hostL;runtime-class "try" try-method false)))
-
-(def: (lux//noop valueI)
- Unary
- valueI)
-
-## [[Bits]]
-(do-template [<name> <op>]
- [(def: (<name> [inputI maskI])
- Binary
- (|>. inputI ($i;unwrap #$;Long)
- maskI ($i;unwrap #$;Long)
- <op> ($i;wrap #$;Long)))]
-
- [bit//and $i;LAND]
- [bit//or $i;LOR]
- [bit//xor $i;LXOR]
- )
-
-(def: (bit//count inputI)
- Unary
- (|>. 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)
- shiftI jvm-intI
- <op>
- ($i;wrap #$;Long)))]
-
- [bit//shift-left $i;LSHL]
- [bit//shift-right $i;LSHR]
- [bit//unsigned-shift-right $i;LUSHR]
- )
-
-## [[Arrays]]
-(def: (array//new lengthI)
- Unary
- (|>. lengthI jvm-intI ($i;ANEWARRAY ($t;descriptor $Object))))
-
-(def: (array//get [arrayI idxI])
- Binary
- (<| $i;with-label (function [@is-null])
- $i;with-label (function [@end])
- (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array))
- idxI jvm-intI
- $i;AALOAD
- $i;DUP
- ($i;IFNULL @is-null)
- &runtime;someI
- ($i;GOTO @end)
- ($i;label @is-null)
- $i;POP
- &runtime;noneI
- ($i;label @end))))
-
-(def: (array//put [arrayI idxI elemI])
- Trinary
- (array-writeI arrayI idxI elemI))
-
-(def: (array//remove [arrayI idxI])
- Binary
- (array-writeI arrayI idxI $i;NULL))
-
-(def: (array//size arrayI)
- Unary
- (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array))
- $i;ARRAYLENGTH
- lux-intI))
-
-## [[Numbers]]
-(def: nat-method
- $;Method
- ($t;method (list $t;long $t;long) (#;Some $t;long) (list)))
-
-(def: deg-method $;Method nat-method)
-
-(def: compare-nat-method
- $;Method
- ($t;method (list $t;long $t;long) (#;Some $t;int) (list)))
-
-(do-template [<name> <const> <wrapper>]
- [(def: (<name> _)
- Nullary
- (|>. <const> <wrapper>))]
-
- [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)]
-
- [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>]
- [(def: (<name> [subjectI paramI])
- Binary
- (|>. subjectI <unwrap>
- paramI <unwrap>
- <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]
-
- [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 hostL;runtime-class "div_nat" nat-method false)]
- [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($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]
- [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)
- ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)]
- [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($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]
- )
-
-(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 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 hostL;runtime-class "compare_nat" compare-nat-method false)]
- )
-
-(do-template [<name> <prepare> <transform>]
- [(def: (<name> inputI)
- Unary
- (|>. inputI <prepare> <transform>))]
-
- [nat//to-int id id]
- [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-frac ($i;unwrap #$;Long) (<| ($i;wrap #$;Double) $i;L2D)]
-
- [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)]
- [frac//to-deg ($i;unwrap #$;Double)
- (<| ($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 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 hostL;runtime-class "deg_to_frac"
- ($t;method (list $t;long) (#;Some $t;double) (list)) false))]
- )
-
-## [[Text]]
-(do-template [<name> <class> <method> <post> <outputT>]
- [(def: (<name> inputI)
- Unary
- (|>. inputI
- ($i;CHECKCAST "java.lang.String")
- ($i;INVOKEVIRTUAL <class> <method> ($t;method (list) (#;Some <outputT>) (list)) false)
- <post>))]
-
- [text//size "java.lang.String" "length" lux-intI $t;int]
- [text//hash "java.lang.Object" "hashCode" lux-intI $t;int]
- [text//trim "java.lang.String" "trim" id $String]
- [text//upper-case "java.lang.String" "toUpperCase" id $String]
- [text//lower-case "java.lang.String" "toLowerCase" id $String]
- )
-
-(do-template [<name> <pre-subject> <pre-param> <op> <post>]
- [(def: (<name> [subjectI paramI])
- Binary
- (|>. subjectI <pre-subject>
- paramI <pre-param>
- <op> <post>))]
-
- [text//eq id id
- ($i;INVOKEVIRTUAL "java.lang.Object" "equals" ($t;method (list $Object) (#;Some $t;boolean) (list)) false)
- ($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)]
- [text//append ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
- ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)
- 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)]
- [text//char ($i;CHECKCAST "java.lang.String") jvm-intI
- ($i;INVOKESTATIC hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
- lux-intI]
- )
-
-(do-template [<name> <pre-subject> <pre-param> <pre-extra> <op>]
- [(def: (<name> [subjectI paramI extraI])
- Trinary
- (|>. subjectI <pre-subject>
- paramI <pre-param>
- extraI <pre-extra>
- <op>))]
-
- [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI
- ($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)]
- )
-
-(def: index-method $;Method ($t;method (list $String $t;int) (#;Some $t;int) (list)))
-(do-template [<name> <method>]
- [(def: (<name> [textI partI startI])
- Trinary
- (<| $i;with-label (function [@not-found])
- $i;with-label (function [@end])
- (|>. textI ($i;CHECKCAST "java.lang.String")
- partI ($i;CHECKCAST "java.lang.String")
- startI jvm-intI
- ($i;INVOKEVIRTUAL "java.lang.String" <method> index-method false)
- $i;DUP
- ($i;int -1)
- ($i;IF_ICMPEQ @not-found)
- lux-intI
- &runtime;someI
- ($i;GOTO @end)
- ($i;label @not-found)
- $i;POP
- &runtime;noneI
- ($i;label @end))))]
-
- [text//index "indexOf"]
- [text//last-index "lastIndexOf"]
- )
-
-## [[Math]]
-(def: math-unary-method ($t;method (list $t;double) (#;Some $t;double) (list)))
-(def: math-binary-method ($t;method (list $t;double $t;double) (#;Some $t;double) (list)))
-
-(do-template [<name> <method>]
- [(def: (<name> inputI)
- Unary
- (|>. inputI
- ($i;unwrap #$;Double)
- ($i;INVOKESTATIC "java.lang.Math" <method> math-unary-method false)
- ($i;wrap #$;Double)))]
-
- [math//cos "cos"]
- [math//sin "sin"]
- [math//tan "tan"]
- [math//acos "acos"]
- [math//asin "asin"]
- [math//atan "atan"]
- [math//cosh "cosh"]
- [math//sinh "sinh"]
- [math//tanh "tanh"]
- [math//exp "exp"]
- [math//log "log"]
- [math//root2 "sqrt"]
- [math//root3 "cbrt"]
- [math//ceil "ceil"]
- [math//floor "floor"]
- )
-
-(do-template [<name> <method>]
- [(def: (<name> [inputI paramI])
- Binary
- (|>. inputI ($i;unwrap #$;Double)
- paramI ($i;unwrap #$;Double)
- ($i;INVOKESTATIC "java.lang.Math" <method> math-binary-method false)
- ($i;wrap #$;Double)))]
-
- [math//atan2 "atan2"]
- [math//pow "pow"]
- )
-
-(def: (math//round inputI)
- Unary
- (|>. inputI
- ($i;unwrap #$;Double)
- ($i;INVOKESTATIC "java.lang.Math" "round" ($t;method (list $t;double) (#;Some $t;long) (list)) false)
- $i;L2D
- ($i;wrap #$;Double)))
-
-## [[IO]]
-(def: string-method $;Method ($t;method (list $String) #;None (list)))
-(def: (io//log messageI)
- Unary
- (|>. ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list)))
- messageI
- ($i;CHECKCAST "java.lang.String")
- ($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false)
- ($i;string hostL;unit)))
-
-(def: (io//error messageI)
- Unary
- (|>. ($i;NEW "java.lang.Error")
- $i;DUP
- messageI
- ($i;CHECKCAST "java.lang.String")
- ($i;INVOKESPECIAL "java.lang.Error" "<init>" string-method false)
- $i;ATHROW))
-
-(def: (io//exit codeI)
- Unary
- (|>. codeI jvm-intI
- ($i;INVOKESTATIC "java.lang.System" "exit" ($t;method (list $t;int) #;None (list)) false)
- $i;NULL))
-
-(def: (io//current-time [])
- Nullary
- (|>. ($i;INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t;method (list) (#;Some $t;long) (list)) false)
- ($i;wrap #$;Long)))
-
-## [[Atoms]]
-(def: atom-class Text "java.util.concurrent.atomic.AtomicReference")
-(def: (atom//new initI)
- Unary
- (|>. ($i;NEW atom-class)
- $i;DUP
- initI
- ($i;INVOKESPECIAL atom-class "<init>" ($t;method (list $Object) #;None (list)) false)))
-
-(def: (atom//read atomI)
- Unary
- (|>. atomI
- ($i;CHECKCAST atom-class)
- ($i;INVOKEVIRTUAL atom-class "get" ($t;method (list) (#;Some $Object) (list)) false)))
-
-(def: (atom//compare-and-swap [atomI oldI newI])
- Trinary
- (|>. atomI
- ($i;CHECKCAST atom-class)
- oldI
- newI
- ($i;INVOKEVIRTUAL atom-class "compareAndSet" ($t;method (list $Object $Object) (#;Some $t;boolean) (list)) false)
- ($i;wrap #$;Boolean)))
-
-## [[Processes]]
-(def: (process//concurrency-level [])
- Nullary
- (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int)
- lux-intI))
-
-(def: (process//future procedureI)
- Unary
- (|>. 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 hostL;function-class)
- ($i;INVOKESTATIC hostL;runtime-class "schedule"
- ($t;method (list $t;long $Function) (#;Some $Object) (list)) false)))
-
-## [Bundles]
-(def: lux-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "lux noop" (unary lux//noop))
- (install "lux is" (binary lux//is))
- (install "lux try" (unary lux//try))))
-
-(def: bit-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "bit count" (unary bit//count))
- (install "bit and" (binary bit//and))
- (install "bit or" (binary bit//or))
- (install "bit xor" (binary bit//xor))
- (install "bit shift-left" (binary bit//shift-left))
- (install "bit unsigned-shift-right" (binary bit//unsigned-shift-right))
- (install "bit shift-right" (binary bit//shift-right))
- ))
-
-(def: nat-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "nat +" (binary nat//add))
- (install "nat -" (binary nat//sub))
- (install "nat *" (binary nat//mul))
- (install "nat /" (binary nat//div))
- (install "nat %" (binary nat//rem))
- (install "nat =" (binary nat//eq))
- (install "nat <" (binary nat//lt))
- (install "nat min" (nullary nat//min))
- (install "nat max" (nullary nat//max))
- (install "nat to-int" (unary nat//to-int))
- (install "nat to-char" (unary nat//to-char))))
-
-(def: int-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "int +" (binary int//add))
- (install "int -" (binary int//sub))
- (install "int *" (binary int//mul))
- (install "int /" (binary int//div))
- (install "int %" (binary int//rem))
- (install "int =" (binary int//eq))
- (install "int <" (binary int//lt))
- (install "int min" (nullary int//min))
- (install "int max" (nullary int//max))
- (install "int to-nat" (unary int//to-nat))
- (install "int to-frac" (unary int//to-frac))))
-
-(def: deg-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "deg +" (binary deg//add))
- (install "deg -" (binary deg//sub))
- (install "deg *" (binary deg//mul))
- (install "deg /" (binary deg//div))
- (install "deg %" (binary deg//rem))
- (install "deg =" (binary deg//eq))
- (install "deg <" (binary deg//lt))
- (install "deg scale" (binary deg//scale))
- (install "deg reciprocal" (binary deg//reciprocal))
- (install "deg min" (nullary deg//min))
- (install "deg max" (nullary deg//max))
- (install "deg to-frac" (unary deg//to-frac))))
-
-(def: frac-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (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
- (|> (dict;new text;Hash<Text>)
- (install "text =" (binary text//eq))
- (install "text <" (binary text//lt))
- (install "text append" (binary text//append))
- (install "text index" (trinary text//index))
- (install "text size" (unary text//size))
- (install "text hash" (unary text//hash))
- (install "text replace" (trinary text//replace))
- (install "text char" (binary text//char))
- (install "text clip" (trinary text//clip))
- ))
-
-(def: array-procs
- Bundle
- (|> (dict;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
- (|> (dict;new text;Hash<Text>)
- (install "math cos" (unary math//cos))
- (install "math sin" (unary math//sin))
- (install "math tan" (unary math//tan))
- (install "math acos" (unary math//acos))
- (install "math asin" (unary math//asin))
- (install "math atan" (unary math//atan))
- (install "math cosh" (unary math//cosh))
- (install "math sinh" (unary math//sinh))
- (install "math tanh" (unary math//tanh))
- (install "math exp" (unary math//exp))
- (install "math log" (unary math//log))
- (install "math root2" (unary math//root2))
- (install "math root3" (unary math//root3))
- (install "math ceil" (unary math//ceil))
- (install "math floor" (unary math//floor))
- (install "math round" (unary math//round))
- (install "math atan2" (binary math//atan2))
- (install "math pow" (binary math//pow))
- ))
-
-(def: io-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "io log" (unary io//log))
- (install "io error" (unary io//error))
- (install "io exit" (unary io//exit))
- (install "io current-time" (nullary io//current-time))))
-
-(def: atom-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "atom new" (unary atom//new))
- (install "atom read" (unary atom//read))
- (install "atom compare-and-swap" (trinary atom//compare-and-swap))))
-
-(def: process-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "process concurrency-level" (nullary process//concurrency-level))
- (install "process future" (unary process//future))
- (install "process schedule" (binary process//schedule))
- ))
-
-(def: #export procedures
- Bundle
- (|> (dict;new text;Hash<Text>)
- (dict;merge lux-procs)
- (dict;merge bit-procs)
- (dict;merge nat-procs)
- (dict;merge int-procs)
- (dict;merge deg-procs)
- (dict;merge frac-procs)
- (dict;merge text-procs)
- (dict;merge array-procs)
- (dict;merge math-procs)
- (dict;merge io-procs)
- (dict;merge atom-procs)
- (dict;merge process-procs)
- ))
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
deleted file mode 100644
index 9222b2e4a..000000000
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ /dev/null
@@ -1,763 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do]
- ["p" parser "parser/" Monad<Parser>]
- ["ex" exception #+ exception:])
- (data [product]
- ["e" error]
- [text "text/" Eq<Text>]
- (text format
- ["l" lexer])
- (coll [list "list/" Functor<List>]
- [dict #+ Dict]))
- [meta #+ with-gensyms "meta/" Monad<Meta>]
- (meta [code]
- ["s" syntax #+ syntax:])
- [host])
- (luxc ["&" base]
- [";L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- (lang ["la" analysis]
- (analysis (procedure ["&;" host]))
- ["ls" synthesis])
- (generator ["&;" common]
- ["&;" runtime]))
- ["@" ../common])
-
-(do-template [<name> <inst>]
- [(def: <name>
- $;Inst
- <inst>)]
-
- [L2S (|>. $i;L2I $i;I2S)]
- [L2B (|>. $i;L2I $i;I2B)]
- [L2C (|>. $i;L2I $i;I2C)]
- )
-
-(do-template [<name> <unwrap> <conversion> <wrap>]
- [(def: (<name> inputI)
- @;Unary
- (if (is $i;NOP <conversion>)
- (|>. inputI
- ($i;unwrap <unwrap>)
- ($i;wrap <wrap>))
- (|>. inputI
- ($i;unwrap <unwrap>)
- <conversion>
- ($i;wrap <wrap>))))]
-
- [convert//double-to-float #$;Double $i;D2F #$;Float]
- [convert//double-to-int #$;Double $i;D2I #$;Int]
- [convert//double-to-long #$;Double $i;D2L #$;Long]
- [convert//float-to-double #$;Float $i;F2D #$;Double]
- [convert//float-to-int #$;Float $i;F2I #$;Int]
- [convert//float-to-long #$;Float $i;F2L #$;Long]
- [convert//int-to-byte #$;Int $i;I2B #$;Byte]
- [convert//int-to-char #$;Int $i;I2C #$;Char]
- [convert//int-to-double #$;Int $i;I2D #$;Double]
- [convert//int-to-float #$;Int $i;I2F #$;Float]
- [convert//int-to-long #$;Int $i;I2L #$;Long]
- [convert//int-to-short #$;Int $i;I2S #$;Short]
- [convert//long-to-double #$;Long $i;L2D #$;Double]
- [convert//long-to-float #$;Long $i;L2F #$;Float]
- [convert//long-to-int #$;Long $i;L2I #$;Int]
- [convert//long-to-short #$;Long L2S #$;Short]
- [convert//long-to-byte #$;Long L2B #$;Byte]
- [convert//long-to-char #$;Long L2C #$;Char]
- [convert//char-to-byte #$;Char $i;I2B #$;Byte]
- [convert//char-to-short #$;Char $i;I2S #$;Short]
- [convert//char-to-int #$;Char $i;NOP #$;Int]
- [convert//char-to-long #$;Char $i;I2L #$;Long]
- [convert//byte-to-long #$;Byte $i;I2L #$;Long]
- [convert//short-to-long #$;Short $i;I2L #$;Long]
- )
-
-(def: conversion-procs
- @;Bundle
- (<| (@;prefix "convert")
- (|> (dict;new text;Hash<Text>)
- (@;install "double-to-float" (@;unary convert//double-to-float))
- (@;install "double-to-int" (@;unary convert//double-to-int))
- (@;install "double-to-long" (@;unary convert//double-to-long))
- (@;install "float-to-double" (@;unary convert//float-to-double))
- (@;install "float-to-int" (@;unary convert//float-to-int))
- (@;install "float-to-long" (@;unary convert//float-to-long))
- (@;install "int-to-byte" (@;unary convert//int-to-byte))
- (@;install "int-to-char" (@;unary convert//int-to-char))
- (@;install "int-to-double" (@;unary convert//int-to-double))
- (@;install "int-to-float" (@;unary convert//int-to-float))
- (@;install "int-to-long" (@;unary convert//int-to-long))
- (@;install "int-to-short" (@;unary convert//int-to-short))
- (@;install "long-to-double" (@;unary convert//long-to-double))
- (@;install "long-to-float" (@;unary convert//long-to-float))
- (@;install "long-to-int" (@;unary convert//long-to-int))
- (@;install "long-to-short" (@;unary convert//long-to-short))
- (@;install "long-to-byte" (@;unary convert//long-to-byte))
- (@;install "long-to-char" (@;unary convert//long-to-char))
- (@;install "char-to-byte" (@;unary convert//char-to-byte))
- (@;install "char-to-short" (@;unary convert//char-to-short))
- (@;install "char-to-int" (@;unary convert//char-to-int))
- (@;install "char-to-long" (@;unary convert//char-to-long))
- (@;install "byte-to-long" (@;unary convert//byte-to-long))
- (@;install "short-to-long" (@;unary convert//short-to-long))
- )))
-
-(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
- [(def: (<name> [xI yI])
- @;Binary
- (|>. xI ($i;unwrap <unwrapX>)
- yI ($i;unwrap <unwrapY>)
- <op> ($i;wrap <wrap>)))]
-
- [int//+ $i;IADD #$;Int #$;Int #$;Int]
- [int//- $i;ISUB #$;Int #$;Int #$;Int]
- [int//* $i;IMUL #$;Int #$;Int #$;Int]
- [int/// $i;IDIV #$;Int #$;Int #$;Int]
- [int//% $i;IREM #$;Int #$;Int #$;Int]
- [int//and $i;IAND #$;Int #$;Int #$;Int]
- [int//or $i;IOR #$;Int #$;Int #$;Int]
- [int//xor $i;IXOR #$;Int #$;Int #$;Int]
- [int//shl $i;ISHL #$;Int #$;Int #$;Int]
- [int//shr $i;ISHR #$;Int #$;Int #$;Int]
- [int//ushr $i;IUSHR #$;Int #$;Int #$;Int]
-
- [long//+ $i;LADD #$;Long #$;Long #$;Long]
- [long//- $i;LSUB #$;Long #$;Long #$;Long]
- [long//* $i;LMUL #$;Long #$;Long #$;Long]
- [long/// $i;LDIV #$;Long #$;Long #$;Long]
- [long//% $i;LREM #$;Long #$;Long #$;Long]
- [long//and $i;LAND #$;Long #$;Long #$;Long]
- [long//or $i;LOR #$;Long #$;Long #$;Long]
- [long//xor $i;LXOR #$;Long #$;Long #$;Long]
- [long//shl $i;LSHL #$;Long #$;Int #$;Long]
- [long//shr $i;LSHR #$;Long #$;Int #$;Long]
- [long//ushr $i;LUSHR #$;Long #$;Int #$;Long]
-
- [float//+ $i;FADD #$;Float #$;Float #$;Float]
- [float//- $i;FSUB #$;Float #$;Float #$;Float]
- [float//* $i;FMUL #$;Float #$;Float #$;Float]
- [float/// $i;FDIV #$;Float #$;Float #$;Float]
- [float//% $i;FREM #$;Float #$;Float #$;Float]
-
- [double//+ $i;DADD #$;Double #$;Double #$;Double]
- [double//- $i;DSUB #$;Double #$;Double #$;Double]
- [double//* $i;DMUL #$;Double #$;Double #$;Double]
- [double/// $i;DDIV #$;Double #$;Double #$;Double]
- [double//% $i;DREM #$;Double #$;Double #$;Double]
- )
-
-(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
- [(def: (<name> [xI yI])
- @;Binary
- (<| $i;with-label (function [@then])
- $i;with-label (function [@end])
- (|>. xI ($i;unwrap <unwrapX>)
- yI ($i;unwrap <unwrapY>)
- (<op> @then)
- ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
- ($i;GOTO @end)
- ($i;label @then)
- ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
- ($i;label @end))))]
-
- [int//= $i;IF_ICMPEQ #$;Int #$;Int #$;Boolean]
- [int//< $i;IF_ICMPLT #$;Int #$;Int #$;Boolean]
-
- [char//= $i;IF_ICMPEQ #$;Char #$;Char #$;Boolean]
- [char//< $i;IF_ICMPLT #$;Char #$;Char #$;Boolean]
- )
-
-(do-template [<name> <op> <reference> <unwrapX> <unwrapY> <wrap>]
- [(def: (<name> [xI yI])
- @;Binary
- (<| $i;with-label (function [@then])
- $i;with-label (function [@end])
- (|>. xI ($i;unwrap <unwrapX>)
- yI ($i;unwrap <unwrapY>)
- <op>
- ($i;int <reference>)
- ($i;IF_ICMPEQ @then)
- ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
- ($i;GOTO @end)
- ($i;label @then)
- ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
- ($i;label @end))))]
-
- [long//= $i;LCMP 0 #$;Long #$;Long #$;Boolean]
- [long//< $i;LCMP -1 #$;Long #$;Long #$;Boolean]
-
- [float//= $i;FCMPG 0 #$;Float #$;Float #$;Boolean]
- [float//< $i;FCMPG -1 #$;Float #$;Float #$;Boolean]
-
- [double//= $i;DCMPG 0 #$;Double #$;Double #$;Boolean]
- [double//< $i;DCMPG -1 #$;Double #$;Double #$;Boolean]
- )
-
-(def: int-procs
- @;Bundle
- (<| (@;prefix "int")
- (|> (dict;new text;Hash<Text>)
- (@;install "+" (@;binary int//+))
- (@;install "-" (@;binary int//-))
- (@;install "*" (@;binary int//*))
- (@;install "/" (@;binary int///))
- (@;install "%" (@;binary int//%))
- (@;install "=" (@;binary int//=))
- (@;install "<" (@;binary int//<))
- (@;install "and" (@;binary int//and))
- (@;install "or" (@;binary int//or))
- (@;install "xor" (@;binary int//xor))
- (@;install "shl" (@;binary int//shl))
- (@;install "shr" (@;binary int//shr))
- (@;install "ushr" (@;binary int//ushr))
- )))
-
-(def: long-procs
- @;Bundle
- (<| (@;prefix "long")
- (|> (dict;new text;Hash<Text>)
- (@;install "+" (@;binary long//+))
- (@;install "-" (@;binary long//-))
- (@;install "*" (@;binary long//*))
- (@;install "/" (@;binary long///))
- (@;install "%" (@;binary long//%))
- (@;install "=" (@;binary long//=))
- (@;install "<" (@;binary long//<))
- (@;install "and" (@;binary long//and))
- (@;install "or" (@;binary long//or))
- (@;install "xor" (@;binary long//xor))
- (@;install "shl" (@;binary long//shl))
- (@;install "shr" (@;binary long//shr))
- (@;install "ushr" (@;binary long//ushr))
- )))
-
-(def: float-procs
- @;Bundle
- (<| (@;prefix "float")
- (|> (dict;new text;Hash<Text>)
- (@;install "+" (@;binary float//+))
- (@;install "-" (@;binary float//-))
- (@;install "*" (@;binary float//*))
- (@;install "/" (@;binary float///))
- (@;install "%" (@;binary float//%))
- (@;install "=" (@;binary float//=))
- (@;install "<" (@;binary float//<))
- )))
-
-(def: double-procs
- @;Bundle
- (<| (@;prefix "double")
- (|> (dict;new text;Hash<Text>)
- (@;install "+" (@;binary double//+))
- (@;install "-" (@;binary double//-))
- (@;install "*" (@;binary double//*))
- (@;install "/" (@;binary double///))
- (@;install "%" (@;binary double//%))
- (@;install "=" (@;binary double//=))
- (@;install "<" (@;binary double//<))
- )))
-
-(def: char-procs
- @;Bundle
- (<| (@;prefix "char")
- (|> (dict;new text;Hash<Text>)
- (@;install "=" (@;binary char//=))
- (@;install "<" (@;binary char//<))
- )))
-
-(def: (array//length arrayI)
- @;Unary
- (|>. arrayI
- $i;ARRAYLENGTH
- $i;I2L
- ($i;wrap #$;Long)))
-
-(def: (array//new proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS))
- (do meta;Monad<Meta>
- [lengthI (generate lengthS)
- #let [arrayJT ($t;array level (case class
- "boolean" $t;boolean
- "byte" $t;byte
- "short" $t;short
- "int" $t;int
- "long" $t;long
- "float" $t;float
- "double" $t;double
- "char" $t;char
- _ ($t;class class (list))))]]
- (wrap (|>. lengthI
- ($i;unwrap #$;Long)
- $i;L2I
- ($i;array arrayJT))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (array//read proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] idxS arrayS))
- (do meta;Monad<Meta>
- [arrayI (generate arrayS)
- idxI (generate idxS)
- #let [loadI (case class
- "boolean" (|>. $i;BALOAD ($i;wrap #$;Boolean))
- "byte" (|>. $i;BALOAD ($i;wrap #$;Byte))
- "short" (|>. $i;SALOAD ($i;wrap #$;Short))
- "int" (|>. $i;IALOAD ($i;wrap #$;Int))
- "long" (|>. $i;LALOAD ($i;wrap #$;Long))
- "float" (|>. $i;FALOAD ($i;wrap #$;Float))
- "double" (|>. $i;DALOAD ($i;wrap #$;Double))
- "char" (|>. $i;CALOAD ($i;wrap #$;Char))
- _ $i;AALOAD)]]
- (wrap (|>. arrayI
- idxI
- ($i;unwrap #$;Long)
- $i;L2I
- loadI)))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (array//write proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] idxS valueS arrayS))
- (do meta;Monad<Meta>
- [arrayI (generate arrayS)
- idxI (generate idxS)
- valueI (generate valueS)
- #let [storeI (case class
- "boolean" (|>. ($i;unwrap #$;Boolean) $i;BASTORE)
- "byte" (|>. ($i;unwrap #$;Byte) $i;BASTORE)
- "short" (|>. ($i;unwrap #$;Short) $i;SASTORE)
- "int" (|>. ($i;unwrap #$;Int) $i;IASTORE)
- "long" (|>. ($i;unwrap #$;Long) $i;LASTORE)
- "float" (|>. ($i;unwrap #$;Float) $i;FASTORE)
- "double" (|>. ($i;unwrap #$;Double) $i;DASTORE)
- "char" (|>. ($i;unwrap #$;Char) $i;CASTORE)
- _ $i;AASTORE)]]
- (wrap (|>. arrayI
- $i;DUP
- idxI
- ($i;unwrap #$;Long)
- $i;L2I
- valueI
- storeI)))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: array-procs
- @;Bundle
- (<| (@;prefix "array")
- (|> (dict;new text;Hash<Text>)
- (@;install "length" (@;unary array//length))
- (@;install "new" array//new)
- (@;install "read" array//read)
- (@;install "write" array//write)
- )))
-
-(def: (object//null _)
- @;Nullary
- $i;NULL)
-
-(def: (object//null? objectI)
- @;Unary
- (<| $i;with-label (function [@then])
- $i;with-label (function [@end])
- (|>. objectI
- ($i;IFNULL @then)
- ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
- ($i;GOTO @end)
- ($i;label @then)
- ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
- ($i;label @end))))
-
-(def: (object//synchronized [monitorI exprI])
- @;Binary
- (|>. monitorI
- $i;DUP
- $i;MONITORENTER
- exprI
- $i;SWAP
- $i;MONITOREXIT))
-
-(def: (object//throw exceptionI)
- @;Unary
- (|>. exceptionI
- $i;ATHROW))
-
-(def: (object//class proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)]))
- (do meta;Monad<Meta>
- []
- (wrap (|>. ($i;string class)
- ($i;INVOKESTATIC "java.lang.Class" "forName"
- ($t;method (list ($t;class "java.lang.String" (list)))
- (#;Some ($t;class "java.lang.Class" (list)))
- (list))
- false))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (object//instance? proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] objectS))
- (do meta;Monad<Meta>
- [objectI (generate objectS)]
- (wrap (|>. objectI
- ($i;INSTANCEOF class)
- ($i;wrap #$;Boolean))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: object-procs
- @;Bundle
- (<| (@;prefix "object")
- (|> (dict;new text;Hash<Text>)
- (@;install "null" (@;nullary object//null))
- (@;install "null?" (@;unary object//null?))
- (@;install "synchronized" (@;binary object//synchronized))
- (@;install "throw" (@;unary object//throw))
- (@;install "class" object//class)
- (@;install "instance?" object//instance?)
- )))
-
-(def: primitives
- (Dict Text $;Primitive)
- (|> (list ["boolean" #$;Boolean]
- ["byte" #$;Byte]
- ["short" #$;Short]
- ["int" #$;Int]
- ["long" #$;Long]
- ["float" #$;Float]
- ["double" #$;Double]
- ["char" #$;Char])
- (dict;from-list text;Hash<Text>)))
-
-(def: (static//get proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)]))
- (do meta;Monad<Meta>
- []
- (case (dict;get unboxed primitives)
- (#;Some primitive)
- (let [primitive (case unboxed
- "boolean" #$;Boolean
- "byte" #$;Byte
- "short" #$;Short
- "int" #$;Int
- "long" #$;Long
- "float" #$;Float
- "double" #$;Double
- "char" #$;Char
- _ (undefined))]
- (wrap (|>. ($i;GETSTATIC class field (#$;Primitive primitive))
- ($i;wrap primitive))))
-
- #;None
- (wrap ($i;GETSTATIC class field ($t;class unboxed (list))))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (static//put proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS))
- (do meta;Monad<Meta>
- [valueI (generate valueS)]
- (case (dict;get unboxed primitives)
- (#;Some primitive)
- (let [primitive (case unboxed
- "boolean" #$;Boolean
- "byte" #$;Byte
- "short" #$;Short
- "int" #$;Int
- "long" #$;Long
- "float" #$;Float
- "double" #$;Double
- "char" #$;Char
- _ (undefined))]
- (wrap (|>. valueI
- ($i;unwrap primitive)
- ($i;PUTSTATIC class field (#$;Primitive primitive))
- ($i;string hostL;unit))))
-
- #;None
- (wrap (|>. valueI
- ($i;CHECKCAST class)
- ($i;PUTSTATIC class field ($t;class class (list)))
- ($i;string hostL;unit)))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (virtual//get proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS))
- (do meta;Monad<Meta>
- [objectI (generate objectS)]
- (case (dict;get unboxed primitives)
- (#;Some primitive)
- (let [primitive (case unboxed
- "boolean" #$;Boolean
- "byte" #$;Byte
- "short" #$;Short
- "int" #$;Int
- "long" #$;Long
- "float" #$;Float
- "double" #$;Double
- "char" #$;Char
- _ (undefined))]
- (wrap (|>. objectI
- ($i;CHECKCAST class)
- ($i;GETFIELD class field (#$;Primitive primitive))
- ($i;wrap primitive))))
-
- #;None
- (wrap (|>. objectI
- ($i;CHECKCAST class)
- ($i;GETFIELD class field ($t;class unboxed (list)))))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (virtual//put proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS))
- (do meta;Monad<Meta>
- [valueI (generate valueS)
- objectI (generate objectS)]
- (case (dict;get unboxed primitives)
- (#;Some primitive)
- (let [primitive (case unboxed
- "boolean" #$;Boolean
- "byte" #$;Byte
- "short" #$;Short
- "int" #$;Int
- "long" #$;Long
- "float" #$;Float
- "double" #$;Double
- "char" #$;Char
- _ (undefined))]
- (wrap (|>. objectI
- ($i;CHECKCAST class)
- $i;DUP
- valueI
- ($i;unwrap primitive)
- ($i;PUTFIELD class field (#$;Primitive primitive)))))
-
- #;None
- (wrap (|>. objectI
- ($i;CHECKCAST class)
- $i;DUP
- valueI
- ($i;CHECKCAST unboxed)
- ($i;PUTFIELD class field ($t;class unboxed (list)))))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(exception: #export Invalid-Syntax-For-Argument-Generation)
-
-(def: base-type
- (l;Lexer $;Type)
- ($_ p;either
- (p;after (l;this "boolean") (parser/wrap $t;boolean))
- (p;after (l;this "byte") (parser/wrap $t;byte))
- (p;after (l;this "short") (parser/wrap $t;short))
- (p;after (l;this "int") (parser/wrap $t;int))
- (p;after (l;this "long") (parser/wrap $t;long))
- (p;after (l;this "float") (parser/wrap $t;float))
- (p;after (l;this "double") (parser/wrap $t;double))
- (p;after (l;this "char") (parser/wrap $t;char))
- (parser/map (function [name]
- ($t;class name (list)))
- (l;many (l;none-of "[")))
- ))
-
-(def: java-type
- (l;Lexer $;Type)
- (do p;Monad<Parser>
- [raw base-type
- nesting (p;some (l;this "[]"))]
- (wrap ($t;array (list;size nesting) raw))))
-
-(def: (generate-type argD)
- (-> Text (Meta $;Type))
- (case (l;run argD java-type)
- (#e;Error error)
- (&;fail error)
-
- (#e;Success type)
- (meta/wrap type)))
-
-(def: (prepare-input inputT inputI)
- (-> $;Type $;Inst $;Inst)
- (case inputT
- (#$;Primitive primitive)
- (|>. inputI ($i;unwrap primitive))
-
- (#$;Generic generic)
- (case generic
- (^or (#$;Var _) (#$;Wildcard _))
- (|>. inputI ($i;CHECKCAST "java.lang.Object"))
-
- (#$;Class class-name _)
- (|>. inputI ($i;CHECKCAST class-name)))
-
- _
- (|>. inputI ($i;CHECKCAST ($t;descriptor inputT)))))
-
-(def: (generate-args generate argsS)
- (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis)
- (Meta (List [$;Type $;Inst])))
- (case argsS
- #;Nil
- (meta/wrap #;Nil)
-
- (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail))
- (do meta;Monad<Meta>
- [argT (generate-type argD)
- argI (:: @ map (prepare-input argT) (generate argS))
- =tail (generate-args generate tail)]
- (wrap (list& [argT argI] =tail)))
-
- _
- (&;throw Invalid-Syntax-For-Argument-Generation "")))
-
-(def: (method-return-type description)
- (-> Text (Meta (Maybe $;Type)))
- (case description
- "void"
- (meta/wrap #;None)
-
- _
- (:: meta;Monad<Meta> map (|>. #;Some) (generate-type description))))
-
-(def: (prepare-return returnT returnI)
- (-> (Maybe $;Type) $;Inst $;Inst)
- (case returnT
- #;None
- (|>. returnI
- ($i;string hostL;unit))
-
- (#;Some type)
- (case type
- (#$;Primitive primitive)
- (|>. returnI ($i;wrap primitive))
-
- _
- returnI)))
-
-(def: (invoke//static proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list& [_ (#;Text class)] [_ (#;Text method)]
- [_ (#;Text unboxed)] argsS))
- (do meta;Monad<Meta>
- [argsTI (generate-args generate argsS)
- returnT (method-return-type unboxed)
- #let [callI (|>. ($i;fuse (list/map product;right argsTI))
- ($i;INVOKESTATIC class method
- ($t;method (list/map product;left argsTI) returnT (list))
- false))]]
- (wrap (prepare-return returnT callI)))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(do-template [<name> <invoke> <interface?>]
- [(def: (<name> proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list& [_ (#;Text class)] [_ (#;Text method)]
- [_ (#;Text unboxed)] objectS argsS))
- (do meta;Monad<Meta>
- [objectI (generate objectS)
- argsTI (generate-args generate argsS)
- returnT (method-return-type unboxed)
- #let [callI (|>. objectI
- ($i;CHECKCAST class)
- ($i;fuse (list/map product;right argsTI))
- (<invoke> class method
- ($t;method (list/map product;left argsTI) returnT (list))
- <interface?>))]]
- (wrap (prepare-return returnT callI)))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))]
-
- [invoke//virtual $i;INVOKEVIRTUAL false]
- [invoke//special $i;INVOKESPECIAL false]
- [invoke//interface $i;INVOKEINTERFACE true]
- )
-
-(def: (invoke//constructor proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list& [_ (#;Text class)] argsS))
- (do meta;Monad<Meta>
- [argsTI (generate-args generate argsS)]
- (wrap (|>. ($i;NEW class)
- $i;DUP
- ($i;fuse (list/map product;right argsTI))
- ($i;INVOKESPECIAL class "<init>"
- ($t;method (list/map product;left argsTI) #;None (list))
- false))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: member-procs
- @;Bundle
- (<| (@;prefix "member")
- (|> (dict;new text;Hash<Text>)
- (dict;merge (<| (@;prefix "static")
- (|> (dict;new text;Hash<Text>)
- (@;install "get" static//get)
- (@;install "put" static//put))))
- (dict;merge (<| (@;prefix "virtual")
- (|> (dict;new text;Hash<Text>)
- (@;install "get" virtual//get)
- (@;install "put" virtual//put))))
- (dict;merge (<| (@;prefix "invoke")
- (|> (dict;new text;Hash<Text>)
- (@;install "static" invoke//static)
- (@;install "virtual" invoke//virtual)
- (@;install "special" invoke//special)
- (@;install "interface" invoke//interface)
- (@;install "constructor" invoke//constructor)
- )))
- )))
-
-(def: #export procedures
- @;Bundle
- (<| (@;prefix "jvm")
- (|> (dict;new text;Hash<Text>)
- (dict;merge conversion-procs)
- (dict;merge int-procs)
- (dict;merge long-procs)
- (dict;merge float-procs)
- (dict;merge double-procs)
- (dict;merge char-procs)
- (dict;merge array-procs)
- (dict;merge object-procs)
- (dict;merge member-procs)
- )))
diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux
deleted file mode 100644
index 9af511167..000000000
--- a/new-luxc/source/luxc/generator/reference.jvm.lux
+++ /dev/null
@@ -1,31 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do])
- (data text/format)
- [meta "meta/" Monad<Meta>])
- (luxc ["&" base]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$i" inst]))
- (lang ["ls" synthesis]
- [";L" variable #+ Variable])
- (generator [";G" common]
- [";G" function])))
-
-(def: #export (generate-captured variable)
- (-> Variable (Meta $;Inst))
- (do meta;Monad<Meta>
- [function-class commonG;function]
- (wrap (|>. ($i;ALOAD +0)
- ($i;GETFIELD function-class
- (|> variable i.inc (i.* -1) int-to-nat functionG;captured)
- commonG;$Object)))))
-
-(def: #export (generate-variable variable)
- (-> Variable (Meta $;Inst))
- (meta/wrap ($i;ALOAD (int-to-nat variable))))
-
-(def: #export (generate-definition [def-module def-name])
- (-> Ident (Meta $;Inst))
- (let [bytecode-name (format def-module "/" (&;normalize-name def-name))]
- (meta/wrap ($i;GETSTATIC bytecode-name commonG;value-field commonG;$Object))))
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
deleted file mode 100644
index 4b57e802e..000000000
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ /dev/null
@@ -1,608 +0,0 @@
-(;module:
- lux
- (lux (control monad)
- (data text/format
- (coll [list "list/" Functor<List>]))
- [math]
- [meta]
- [host])
- (luxc ["&" base]
- [";L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- (lang ["la" analysis]
- ["ls" synthesis])
- (generator ["&;" common])))
-
-(host;import java.lang.Object)
-(host;import java.lang.String)
-
-(host;import java.lang.reflect.Field
- (get [Object] #try Object))
-
-(host;import (java.lang.Class a)
- (getField [String] Field))
-
-(host;import org.objectweb.asm.Opcodes
- (#static ACC_PUBLIC int)
- (#static ACC_SUPER int)
- (#static ACC_FINAL int)
- (#static ACC_STATIC int)
- (#static V1_6 int))
-
-(host;import org.objectweb.asm.ClassWriter
- (#static COMPUTE_MAXS int)
- (new [int])
- (visit [int int String String String (Array String)] void)
- (visitEnd [] void)
- (toByteArray [] (Array byte)))
-
-(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 $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 hostL;function-class (list)))
-(def: $Throwable $;Type ($t;class "java.lang.Throwable" (list)))
-
-(def: #export 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: variant-method
- $;Method
- ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list)))
-
-(def: variantI
- $;Inst
- ($i;INVOKESTATIC hostL;runtime-class "variant_make" variant-method false))
-
-(def: #export leftI
- $;Inst
- (|>. ($i;int 0)
- $i;NULL
- $i;DUP2_X1
- $i;POP2
- variantI))
-
-(def: #export rightI
- $;Inst
- (|>. ($i;int 1)
- ($i;string "")
- $i;DUP2_X1
- $i;POP2
- variantI))
-
-(def: #export someI $;Inst rightI)
-
-(def: #export noneI
- $;Inst
- (|>. ($i;int 0)
- $i;NULL
- ($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)
-
-(def: #export (apply-signature arity)
- (-> ls;Arity $;Method)
- ($t;method (list;repeat arity $Object) (#;Some $Object) (list)))
-
-(def: adt-methods
- $;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)
- 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))
- (|>. ($i;int 3)
- ($i;array $Object)
- store-tagI
- store-flagI
- 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 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 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
- (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: frac-shiftI $;Inst ($i;double (math;pow 32.0 2.0)))
-
-(def: 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: 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 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)
- ($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: pm-methods
- $;Def
- (let [tuple-sizeI (|>. ($i;ALOAD +0) $i;ARRAYLENGTH)
- tuple-elemI (|>. ($i;ALOAD +0) ($i;ILOAD +1) $i;AALOAD)
- expected-last-sizeI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD)
- tuple-tailI (|>. ($i;ALOAD +0) tuple-sizeI ($i;int 1) $i;ISUB $i;AALOAD ($i;CHECKCAST ($t;descriptor $Tuple)))]
- (|>. ($d;method #$;Public $;staticM "pm_fail" ($t;method (list) #;None (list))
- (|>. ($i;NEW "java.lang.IllegalStateException")
- $i;DUP
- ($i;string "Invalid expression for pattern-matching.")
- ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false)
- $i;ATHROW))
- ($d;method #$;Public $;staticM "apply_fail" ($t;method (list) #;None (list))
- (|>. ($i;NEW "java.lang.IllegalStateException")
- $i;DUP
- ($i;string "Error while applying function.")
- ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false)
- $i;ATHROW))
- ($d;method #$;Public $;staticM "pm_push" ($t;method (list $Stack $Object) (#;Some $Stack) (list))
- (|>. ($i;int 2)
- ($i;ANEWARRAY "java.lang.Object")
- $i;DUP
- ($i;int 0)
- ($i;ALOAD +0)
- $i;AASTORE
- $i;DUP
- ($i;int 1)
- ($i;ALOAD +1)
- $i;AASTORE
- $i;ARETURN))
- ($d;method #$;Public $;staticM "pm_pop" ($t;method (list $Stack) (#;Some $Stack) (list))
- (|>. ($i;ALOAD +0)
- ($i;int 0)
- $i;AALOAD
- ($i;CHECKCAST ($t;descriptor $Stack))
- $i;ARETURN))
- ($d;method #$;Public $;staticM "pm_peek" ($t;method (list $Stack) (#;Some $Object) (list))
- (|>. ($i;ALOAD +0)
- ($i;int 1)
- $i;AALOAD
- $i;ARETURN))
- ($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])
- $i;with-label (function [@further])
- $i;with-label (function [@shorten])
- $i;with-label (function [@wrong])
- (let [variant-partI (: (-> Nat $;Inst)
- (function [idx]
- (|>. ($i;int (nat-to-int idx)) $i;AALOAD)))
- tagI (: $;Inst
- (|>. (variant-partI +0) ($i;unwrap #$;Int)))
- flagI (variant-partI +1)
- datumI (variant-partI +2)
- shortenI (|>. ($i;ALOAD +0) tagI ## Get tag
- ($i;ILOAD +1) $i;ISUB ## Shorten tag
- ($i;ALOAD +0) flagI ## Get flag
- ($i;ALOAD +0) datumI ## Get value
- variantI ## Build sum
- $i;ARETURN)
- update-tagI (|>. $i;ISUB ($i;ISTORE +1))
- update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0))
- wrongI (|>. $i;NULL $i;ARETURN)
- return-datumI (|>. ($i;ALOAD +0) datumI $i;ARETURN)])
- (|>. ($i;label @begin)
- ($i;ILOAD +1) ## tag
- ($i;ALOAD +0) tagI ## tag, sumT
- $i;DUP2 ($i;IF_ICMPEQ @then)
- $i;DUP2 ($i;IF_ICMPGT @further)
- $i;DUP2 ($i;IF_ICMPLT @shorten)
- ## $i;POP2
- wrongI
- ($i;label @then) ## tag, sumT
- ($i;ALOAD +2) ## tag, sumT, wants-last?
- ($i;ALOAD +0) flagI ## tag, sumT, wants-last?, is-last?
- ($i;IF_ACMPEQ @just-return) ## tag, sumT
- ($i;label @further) ## tag, sumT
- ($i;ALOAD +0) flagI ## tag, sumT, last?
- ($i;IFNULL @wrong) ## tag, sumT
- update-tagI
- update-variantI
- ($i;GOTO @begin)
- ($i;label @just-return) ## tag, sumT
- ## $i;POP2
- return-datumI
- ($i;label @shorten) ## tag, sumT
- ($i;ALOAD +2) ($i;IFNULL @wrong)
- ## $i;POP2
- shortenI
- ($i;label @wrong) ## tag, sumT
- ## $i;POP2
- wrongI)))
- ($d;method #$;Public $;staticM "pm_left" ($t;method (list $Tuple $t;int) (#;Some $Object) (list))
- (<| $i;with-label (function [@begin])
- $i;with-label (function [@not-recursive])
- (let [updated-idxI (|>. $i;SWAP $i;ISUB)])
- (|>. ($i;label @begin)
- tuple-sizeI
- expected-last-sizeI
- $i;DUP2 ($i;IF_ICMPGT @not-recursive)
- ## Recursive
- updated-idxI ($i;ISTORE +1)
- tuple-tailI ($i;ASTORE +0)
- ($i;GOTO @begin)
- ($i;label @not-recursive)
- ## $i;POP2
- tuple-elemI
- $i;ARETURN)))
- ($d;method #$;Public $;staticM "pm_right" ($t;method (list $Tuple $t;int) (#;Some $Object) (list))
- (<| $i;with-label (function [@begin])
- $i;with-label (function [@tail])
- $i;with-label (function [@slice])
- (let [updated-idxI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD tuple-sizeI $i;ISUB)
- sliceI (|>. ($i;ALOAD +0) ($i;ILOAD +1) tuple-sizeI
- ($i;INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t;method (list $Object-Array $t;int $t;int) (#;Some $Object-Array) (list)) false))])
- (|>. ($i;label @begin)
- tuple-sizeI
- expected-last-sizeI
- $i;DUP2 ($i;IF_ICMPEQ @tail)
- ($i;IF_ICMPGT @slice)
- ## Must recurse
- tuple-tailI ($i;ASTORE +0)
- updated-idxI ($i;ISTORE +1)
- ($i;GOTO @begin)
- ($i;label @slice)
- sliceI
- $i;ARETURN
- ($i;label @tail)
- ## $i;POP2
- tuple-elemI
- $i;ARETURN)))
- )))
-
-(def: io-methods
- $;Def
- (let [string-writerI (|>. ($i;NEW "java.io.StringWriter")
- $i;DUP
- ($i;INVOKESPECIAL "java.io.StringWriter" "<init>" ($t;method (list) #;None (list)) false))
- print-writerI (|>. ($i;NEW "java.io.PrintWriter")
- $i;SWAP
- $i;DUP2
- $i;POP
- $i;SWAP
- ($i;boolean true)
- ($i;INVOKESPECIAL "java.io.PrintWriter" "<init>" ($t;method (list ($t;class "java.io.Writer" (list)) $t;boolean) #;None (list)) false)
- )]
- (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list))
- (<| $i;with-label (function [@from])
- $i;with-label (function [@to])
- $i;with-label (function [@handler])
- (|>. ($i;try @from @to @handler "java.lang.Throwable")
- ($i;label @from)
- ($i;ALOAD +0)
- $i;NULL
- ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false)
- rightI
- $i;ARETURN
- ($i;label @to)
- ($i;label @handler)
- string-writerI ## TW
- $i;DUP2 ## TWTW
- print-writerI ## TWTP
- ($i;INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t;method (list ($t;class "java.io.PrintWriter" (list))) #;None (list)) false) ## TW
- ($i;INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t;method (list) (#;Some $String) (list)) false) ## TS
- $i;SWAP $i;POP leftI
- $i;ARETURN)))
- )))
-
-(def: generate-runtime
- (Meta &common;Bytecode)
- (do meta;Monad<Meta>
- [_ (wrap [])
- #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 hostL;runtime-class bytecode)]
- (wrap bytecode)))
-
-(def: generate-function
- (Meta &common;Bytecode)
- (do meta;Monad<Meta>
- [_ (wrap [])
- #let [applyI (|> (list;n.range +2 num-apply-variants)
- (list/map (function [arity]
- ($d;method #$;Public $;noneM apply-method (apply-signature arity)
- (let [preI (|> (list;n.range +0 (n.dec arity))
- (list/map $i;ALOAD)
- $i;fuse)]
- (|>. preI
- ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature (n.dec arity)) false)
- ($i;CHECKCAST hostL;function-class)
- ($i;ALOAD arity)
- ($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 hostL;function-class (list) ["java.lang.Object" (list)] (list)
- (|>. ($d;field #$;Public $;finalF partials-field $t;int)
- ($d;method #$;Public $;noneM "<init>" ($t;method (list $t;int) #;None (list))
- (|>. ($i;ALOAD +0)
- ($i;INVOKESPECIAL "java.lang.Object" "<init>" ($t;method (list) #;None (list)) false)
- ($i;ALOAD +0)
- ($i;ILOAD +1)
- ($i;PUTFIELD hostL;function-class partials-field $t;int)
- $i;RETURN))
- applyI))]
- _ (&common;store-class hostL;function-class bytecode)]
- (wrap bytecode)))
-
-(def: #export generate
- (Meta [&common;Bytecode &common;Bytecode])
- (do meta;Monad<Meta>
- [runtime-bc generate-runtime
- function-bc generate-function]
- (wrap [runtime-bc function-bc])))
diff --git a/new-luxc/source/luxc/generator/statement.jvm.lux b/new-luxc/source/luxc/generator/statement.jvm.lux
deleted file mode 100644
index e91e99fc9..000000000
--- a/new-luxc/source/luxc/generator/statement.jvm.lux
+++ /dev/null
@@ -1,82 +0,0 @@
-(;module:
- lux
- (lux (control monad
- ["ex" exception #+ exception:])
- (data ["e" error]
- [maybe]
- [text "text/" Monoid<Text>]
- text/format
- (coll [list "list/" Functor<List> Fold<List>]))
- [meta]
- [host])
- (luxc ["&" base]
- ["&;" scope]
- ["&;" module]
- ["&;" io]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- (generator ["&;" eval]
- ["&;" common])))
-
-(exception: #export Invalid-Definition-Value)
-
-(host;import java.lang.Object
- (toString [] String))
-
-(host;import java.lang.reflect.Field
- (get [#? Object] #try #? Object))
-
-(host;import (java.lang.Class c)
- (getField [String] #try Field))
-
-(def: #export (generate-def def-name valueT valueI metaI metaV)
- (-> Text Type $;Inst $;Inst Code (Meta Unit))
- (do meta;Monad<Meta>
- [current-module meta;current-module-name
- #let [def-ident [current-module def-name]
- normal-name (&;normalize-name def-name)
- bytecode-name (format current-module "/" normal-name)
- class-name (format current-module "." normal-name)
- bytecode ($d;class #$;V1.6
- #$;Public $;finalC
- bytecode-name
- (list) ["java.lang.Object" (list)]
- (list)
- (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) &common;value-field &common;$Object)
- ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list))
- (|>. valueI
- ($i;PUTSTATIC bytecode-name &common;value-field &common;$Object)
- $i;RETURN))))]
- _ (&common;store-class class-name bytecode)
- class (&common;load-class class-name)
- valueV (: (Meta Top)
- (case (do e;Monad<Error>
- [field (Class.getField [&common;value-field] class)]
- (Field.get [#;None] field))
- (#e;Success #;None)
- (&;throw Invalid-Definition-Value (format current-module ";" def-name))
-
- (#e;Success (#;Some valueV))
- (wrap valueV)
-
- (#e;Error error)
- (&;fail error)))
- _ (&module;define [current-module def-name] [valueT metaV valueV])
- _ (if (meta;type? metaV)
- (case (meta;declared-tags metaV)
- #;Nil
- (wrap [])
-
- tags
- (&module;declare-tags tags (meta;export? metaV) (:! Type valueV)))
- (wrap []))
- #let [_ (log! (format "DEF " current-module ";" def-name))]]
- (&common;record-artifact bytecode-name bytecode)))
-
-(def: #export (generate-program program-args programI)
- (-> Text $;Inst (Meta Unit))
- (do meta;Monad<Meta>
- []
- (&;fail "'lux program' is unimplemented.")))
diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux
deleted file mode 100644
index 96d5767c6..000000000
--- a/new-luxc/source/luxc/generator/structure.jvm.lux
+++ /dev/null
@@ -1,59 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do])
- (data text/format
- (coll [list]))
- [meta]
- [host #+ do-to])
- (luxc ["&" base]
- [";L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- (lang ["la" analysis]
- ["ls" synthesis])
- (generator ["&;" common]))
- [../runtime])
-
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-
-(def: #export (generate-tuple generate members)
- (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst))
- (do meta;Monad<Meta>
- [#let [size (list;size members)]
- _ (&;assert "Cannot generate tuples with less than 2 elements."
- (n.>= +2 size))
- membersI (|> members
- list;enumerate
- (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;int (nat-to-int size))
- ($i;array $Object)
- membersI))))
-
-(def: (flagI tail?)
- (-> Bool $;Inst)
- (if tail?
- ($i;string "")
- $i;NULL))
-
-(def: #export (generate-variant generate tag tail? member)
- (-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst))
- (do meta;Monad<Meta>
- [memberI (generate member)]
- (wrap (|>. ($i;int (nat-to-int tag))
- (flagI tail?)
- memberI
- ($i;INVOKESTATIC hostL;runtime-class
- "variant_make"
- ($t;method (list $t;int $Object $Object)
- (#;Some ($t;array +1 $Object))
- (list))
- false)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 08:10:26 +0000