diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation')
15 files changed, 1844 insertions, 1907 deletions
diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux index 3363e007c..b693f50b8 100644 --- a/new-luxc/source/luxc/lang/translation/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux @@ -1,130 +1,130 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) (data text/format) [macro "macro/" Monad<Meta>]) (luxc ["_" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$i" inst])) ["ls" synthesis])) [//runtime]) -(def: $Object $;Type ($t;class "java.lang.Object" (list))) +(def: $Object $.Type ($t.class "java.lang.Object" (list))) (def: (pop-altI stack-depth) - (-> Nat $;Inst) + (-> Nat $.Inst) (case stack-depth +0 id - +1 $i;POP - +2 $i;POP2 - _ ## (n.> +2) - (|>. $i;POP2 - (pop-altI (n.- +2 stack-depth))))) + +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 + $.Inst + (|>> $i.DUP + ($i.INVOKESTATIC hostL.runtime-class "pm_peek" - ($t;method (list //runtime;$Stack) - (#;Some $Object) + ($t.method (list //runtime.$Stack) + (#.Some $Object) (list)) false))) (def: popI - $;Inst - (|>. ($i;INVOKESTATIC hostL;runtime-class + $.Inst + (|>> ($i.INVOKESTATIC hostL.runtime-class "pm_pop" - ($t;method (list //runtime;$Stack) - (#;Some //runtime;$Stack) + ($t.method (list //runtime.$Stack) + (#.Some //runtime.$Stack) (list)) false))) (def: pushI - $;Inst - (|>. ($i;INVOKESTATIC hostL;runtime-class + $.Inst + (|>> ($i.INVOKESTATIC hostL.runtime-class "pm_push" - ($t;method (list //runtime;$Stack $Object) - (#;Some //runtime;$Stack) + ($t.method (list //runtime.$Stack $Object) + (#.Some //runtime.$Stack) (list)) false))) (exception: #export Unrecognized-Path) (def: (translate-path' translate stack-depth @else @end path) - (-> (-> ls;Synthesis (Meta $;Inst)) - Nat $;Label $;Label ls;Path (Meta $;Inst)) + (-> (-> ls.Synthesis (Meta $.Inst)) + Nat $.Label $.Label ls.Path (Meta $.Inst)) (case path - (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) - (do macro;Monad<Meta> + (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))]) + (do macro.Monad<Meta> [bodyI (translate bodyS)] - (wrap (|>. (pop-altI stack-depth) + (wrap (|>> (pop-altI stack-depth) bodyI - ($i;GOTO @end)))) + ($i.GOTO @end)))) - (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))]) + (^ [_ (#.Form (list [_ (#.Text "lux case pop")]))]) (macro/wrap popI) - (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))]) - (macro/wrap (|>. peekI - ($i;ASTORE register))) + (^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))]) + (macro/wrap (|>> peekI + ($i.ASTORE register))) - [_ (#;Bool value)] - (macro/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)] - (|>. peekI - ($i;unwrap #$;Boolean) + [_ (#.Bool value)] + (macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)] + (|>> peekI + ($i.unwrap #$.Boolean) (jumpI @else)))) (^template [<tag> <prep>] [_ (<tag> value)] - (macro/wrap (|>. peekI - ($i;unwrap #$;Long) - ($i;long (|> value <prep>)) - $i;LCMP - ($i;IFNE @else)))) - ([#;Nat (:! Int)] - [#;Int (: Int)] - [#;Deg (:! Int)]) - - [_ (#;Frac value)] - (macro/wrap (|>. peekI - ($i;unwrap #$;Double) - ($i;double value) - $i;DCMPL - ($i;IFNE @else))) + (macro/wrap (|>> peekI + ($i.unwrap #$.Long) + ($i.long (|> value <prep>)) + $i.LCMP + ($i.IFNE @else)))) + ([#.Nat (:! Int)] + [#.Int (: Int)] + [#.Deg (:! Int)]) + + [_ (#.Frac value)] + (macro/wrap (|>> peekI + ($i.unwrap #$.Double) + ($i.double value) + $i.DCMPL + ($i.IFNE @else))) - [_ (#;Text value)] - (macro/wrap (|>. peekI - ($i;string value) - ($i;INVOKEVIRTUAL "java.lang.Object" + [_ (#.Text value)] + (macro/wrap (|>> peekI + ($i.string value) + ($i.INVOKEVIRTUAL "java.lang.Object" "equals" - ($t;method (list $Object) - (#;Some $t;boolean) + ($t.method (list $Object) + (#.Some $t.boolean) (list)) false) - ($i;IFEQ @else))) + ($i.IFEQ @else))) (^template [<special> <method>] - (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))]) + (^ [_ (#.Form (list [_ (#.Text <special>)] [_ (#.Nat idx)]))]) (macro/wrap (case idx +0 - (|>. peekI - ($i;CHECKCAST ($t;descriptor //runtime;$Tuple)) - ($i;int 0) - $i;AALOAD + (|>> peekI + ($i.CHECKCAST ($t.descriptor //runtime.$Tuple)) + ($i.int 0) + $i.AALOAD pushI) _ - (|>. peekI - ($i;CHECKCAST ($t;descriptor //runtime;$Tuple)) - ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC hostL;runtime-class + (|>> 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) + ($t.method (list //runtime.$Tuple $t.int) + (#.Some $Object) (list)) false) pushI)))) @@ -132,99 +132,99 @@ ["lux case tuple right" "pm_right"]) (^template [<special> <flag>] - (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))]) - (macro/wrap (<| $i;with-label (function [@success]) - $i;with-label (function [@fail]) - (|>. peekI - ($i;CHECKCAST ($t;descriptor //runtime;$Variant)) - ($i;int (nat-to-int idx)) + (^ [_ (#.Form (list [_ (#.Text <special>)] [_ (#.Nat idx)]))]) + (macro/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) + ($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) + $i.DUP + ($i.IFNULL @fail) + ($i.GOTO @success) + ($i.label @fail) + $i.POP + ($i.GOTO @else) + ($i.label @success) pushI)))) - (["lux case variant left" $i;NULL] - ["lux case variant right" ($i;string "")]) + (["lux case variant left" $i.NULL] + ["lux case variant right" ($i.string "")]) - (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))]) - (do macro;Monad<Meta> + (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))]) + (do macro.Monad<Meta> [leftI (translate-path' translate stack-depth @else @end leftP) rightI (translate-path' translate stack-depth @else @end rightP)] - (wrap (|>. leftI + (wrap (|>> leftI rightI))) - (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))]) - (do macro;Monad<Meta> - [@alt-else $i;make-label - leftI (translate-path' translate (n.inc stack-depth) @alt-else @end leftP) + (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))]) + (do macro.Monad<Meta> + [@alt-else $i.make-label + leftI (translate-path' translate (n/inc stack-depth) @alt-else @end leftP) rightI (translate-path' translate stack-depth @else @end rightP)] - (wrap (|>. $i;DUP + (wrap (|>> $i.DUP leftI - ($i;label @alt-else) - $i;POP + ($i.label @alt-else) + $i.POP rightI))) _ - (_;throw Unrecognized-Path (%code path)))) + (_.throw Unrecognized-Path (%code path)))) (def: (translate-path translate path @end) - (-> (-> ls;Synthesis (Meta $;Inst)) - ls;Path $;Label (Meta $;Inst)) - (do macro;Monad<Meta> - [@else $i;make-label + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Path $.Label (Meta $.Inst)) + (do macro.Monad<Meta> + [@else $i.make-label pathI (translate-path' translate +1 @else @end path)] - (wrap (|>. pathI - ($i;label @else) - $i;POP - ($i;INVOKESTATIC hostL;runtime-class + (wrap (|>> pathI + ($i.label @else) + $i.POP + ($i.INVOKESTATIC hostL.runtime-class "pm_fail" - ($t;method (list) #;None (list)) + ($t.method (list) #.None (list)) false) - $i;NULL - ($i;GOTO @end))))) + $i.NULL + ($i.GOTO @end))))) (def: #export (translate-if testI thenI elseI) - (-> $;Inst $;Inst $;Inst $;Inst) - (<| $i;with-label (function [@else]) - $i;with-label (function [@end]) - (|>. testI - ($i;unwrap #$;Boolean) - ($i;IFEQ @else) + (-> $.Inst $.Inst $.Inst $.Inst) + (<| $i.with-label (function [@else]) + $i.with-label (function [@end]) + (|>> testI + ($i.unwrap #$.Boolean) + ($i.IFEQ @else) thenI - ($i;GOTO @end) - ($i;label @else) + ($i.GOTO @end) + ($i.label @else) elseI - ($i;label @end)))) + ($i.label @end)))) (def: #export (translate-case translate valueS path) - (-> (-> ls;Synthesis (Meta $;Inst)) - ls;Synthesis ls;Path (Meta $;Inst)) - (do macro;Monad<Meta> - [@end $i;make-label + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Synthesis ls.Path (Meta $.Inst)) + (do macro.Monad<Meta> + [@end $i.make-label valueI (translate valueS) pathI (translate-path translate path @end)] - (wrap (|>. valueI - $i;NULL - $i;SWAP + (wrap (|>> valueI + $i.NULL + $i.SWAP pushI pathI - ($i;label @end))))) + ($i.label @end))))) (def: #export (translate-let translate register inputS exprS) - (-> (-> ls;Synthesis (Meta $;Inst)) - Nat ls;Synthesis ls;Synthesis (Meta $;Inst)) - (do macro;Monad<Meta> + (-> (-> ls.Synthesis (Meta $.Inst)) + Nat ls.Synthesis ls.Synthesis (Meta $.Inst)) + (do macro.Monad<Meta> [inputI (translate inputS) exprI (translate exprS)] - (wrap (|>. inputI - ($i;ASTORE register) + (wrap (|>> inputI + ($i.ASTORE register) exprI)))) diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux index 7a16a749a..b75b0672b 100644 --- a/new-luxc/source/luxc/lang/translation/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: [lux #- function] (lux (control ["ex" exception #+ exception:]) [io] @@ -10,22 +10,22 @@ [host] (world [blob #+ Blob] [file #+ File])) - (luxc (lang [";L" variable #+ Register] + (luxc (lang [".L" variable #+ Register] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst]))))) -(host;import org.objectweb.asm.Opcodes +(host.import org/objectweb/asm/Opcodes (#static V1_6 int)) -(host;import org.objectweb.asm.Label) +(host.import org/objectweb/asm/Label) -(host;import java.lang.Object) +(host.import java/lang/Object) -(host;import (java.lang.Class a)) +(host.import (java/lang/Class a)) -(host;import java.lang.ClassLoader +(host.import java/lang/ClassLoader (loadClass [String] (Class Object))) (type: #export Bytecode Blob) @@ -48,57 +48,57 @@ (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>)) + (.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))) + (#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)) + [(|> compiler' (get@ #.host) (:! Host) (get@ #artifacts)) output]]) - (#e;Error error) - (#e;Error error)))) + (#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)) + (.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) + (.function [compiler] + (let [store (|> (get@ #.host compiler) (:! Host) (get@ #store))] - (if (dict;contains? name (|> store atom;read io;run)) - (ex;throw Class-Already-Stored name) - (#e;Success [compiler (io;run (atom;update (dict;put name byte-code) store))]) + (if (dict.contains? name (|> store atom.read io.run)) + (ex.throw Class-Already-Stored name) + (#e.Success [compiler (io.run (atom.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) atom;read io;run)] - (if (dict;contains? name store) - (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))]) - (ex;throw Unknown-Class name))))) + (.function [compiler] + (let [host (:! Host (get@ #.host compiler)) + store (|> host (get@ #store) atom.read io.run)] + (if (dict.contains? name store) + (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))]) + (ex.throw Unknown-Class name))))) -(def: #export bytecode-version Int Opcodes.V1_6) +## (def: #export bytecode-version Int Opcodes::V1_6) (def: #export value-field Text "_value") -(def: #export $Object $;Type ($t;class "java.lang.Object" (list))) +(def: #export $Object $.Type ($t.class "java.lang.Object" (list))) diff --git a/new-luxc/source/luxc/lang/translation/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/eval.jvm.lux index 6b9ee9743..9cce16a49 100644 --- a/new-luxc/source/luxc/lang/translation/eval.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/eval.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad) (data [text] @@ -12,72 +12,36 @@ ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common])) + (translation [".T" common])) )) -(host;import java.lang.Object) -(host;import java.lang.String) - -(host;import java.lang.reflect.Field +(host.import java/lang/reflect/Field (get [Object] Object)) -(host;import (java.lang.Class a) +(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 macro;Monad<Meta> - [current-module macro;current-module-name - class-name (:: @ map %code (macro;gensym (format current-module "/eval"))) - #let [store-name (text;replace-all "/" "." class-name) - writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) - (ClassWriter.visit [commonT;bytecode-version - (i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_SUPER) - class-name - (host;null) - "java/lang/Object" - (host;null)])) - ($d;field #$;Public ($_ $;++F $;finalF $;staticF) - commonT;value-field commonT;$Object) - ($d;method #$;Public ($_ $;++M $;staticM $;strictM) - "<clinit>" - ($t;method (list) #;None (list)) - (|>. valueI - ($i;PUTSTATIC store-name commonT;value-field commonT;$Object) - $i;RETURN))) - bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))] - _ (commonT;store-class store-name bytecode) - class (commonT;load-class store-name)] + (-> $.Inst (Meta Top)) + (do macro.Monad<Meta> + [current-module macro.current-module-name + class-name (:: @ map %code (macro.gensym (format current-module "/eval"))) + #let [store-name (text.replace-all "/" "." class-name) + bytecode ($d.class #$.V1_6 + #$.Public $.noneC + class-name + (list) ["java.lang.Object" (list)] + (list) + (|>> ($d.field #$.Public ($_ $.++F $.finalF $.staticF) + commonT.value-field commonT.$Object) + ($d.method #$.Public ($_ $.++M $.staticM $.strictM) + "<clinit>" + ($t.method (list) #.None (list)) + (|>> valueI + ($i.PUTSTATIC store-name commonT.value-field commonT.$Object) + $i.RETURN))))] + _ (commonT.store-class store-name bytecode) + class (commonT.load-class store-name)] (wrap (|> class - (Class.getField [commonT;value-field]) - (Field.get (host;null)))))) + (Class::getField [commonT.value-field]) + (Field::get (host.null)))))) diff --git a/new-luxc/source/luxc/lang/translation/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/expression.jvm.lux index 65bb5b772..c75ef0a19 100644 --- a/new-luxc/source/luxc/lang/translation/expression.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/expression.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["ex" exception #+ exception:] @@ -8,25 +8,25 @@ [macro] (macro ["s" syntax])) (luxc ["&" lang] - (lang [";L" variable #+ Variable Register] + (lang [".L" variable #+ Variable Register] (host ["$" jvm]) ["ls" synthesis] - (translation [";T" common] - [";T" primitive] - [";T" structure] - [";T" eval] - [";T" procedure] - [";T" function] - [";T" reference] - [";T" case])))) + (translation [".T" common] + [".T" primitive] + [".T" structure] + [".T" eval] + [".T" procedure] + [".T" function] + [".T" reference] + [".T" case])))) (exception: #export Unrecognized-Synthesis) (def: #export (translate synthesis) - (-> ls;Synthesis (Meta $;Inst)) + (-> ls.Synthesis (Meta $.Inst)) (case synthesis (^code []) - primitiveT;translate-unit + primitiveT.translate-unit (^code [(~ singleton)]) (translate singleton) @@ -34,43 +34,43 @@ (^template [<tag> <generator>] [_ (<tag> value)] (<generator> value)) - ([#;Bool primitiveT;translate-bool] - [#;Nat primitiveT;translate-nat] - [#;Int primitiveT;translate-int] - [#;Deg primitiveT;translate-deg] - [#;Frac primitiveT;translate-frac] - [#;Text primitiveT;translate-text]) + ([#.Bool primitiveT.translate-bool] + [#.Nat primitiveT.translate-nat] + [#.Int primitiveT.translate-int] + [#.Deg primitiveT.translate-deg] + [#.Frac primitiveT.translate-frac] + [#.Text primitiveT.translate-text]) - (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Bool last?)]) (~ valueS))) - (structureT;translate-variant translate tag last? valueS) + (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS))) + (structureT.translate-variant translate tag last? valueS) (^code [(~@ members)]) - (structureT;translate-tuple translate members) + (structureT.translate-tuple translate members) - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (if (variableL;captured? var) - (referenceT;translate-captured var) - (referenceT;translate-local var)) + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (if (variableL.captured? var) + (referenceT.translate-captured var) + (referenceT.translate-local var)) - [_ (#;Symbol definition)] - (referenceT;translate-definition definition) + [_ (#.Symbol definition)] + (referenceT.translate-definition definition) - (^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ exprS))) - (caseT;translate-let translate register inputS exprS) + (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) + (caseT.translate-let translate register inputS exprS) (^code ("lux case" (~ inputS) (~ pathPS))) - (caseT;translate-case translate inputS pathPS) + (caseT.translate-case translate inputS pathPS) - (^multi (^code ("lux function" (~ [_ (#;Nat arity)]) [(~@ environment)] (~ bodyS))) - [(s;run environment (p;some s;int)) (#e;Success environment)]) - (functionT;translate-function translate environment arity bodyS) + (^multi (^code ("lux function" (~ [_ (#.Nat arity)]) [(~@ environment)] (~ bodyS))) + [(s.run environment (p.some s.int)) (#e.Success environment)]) + (functionT.translate-function translate environment arity bodyS) (^code ("lux call" (~ functionS) (~@ argsS))) - (functionT;translate-call translate functionS argsS) + (functionT.translate-call translate functionS argsS) - (^code ((~ [_ (#;Text procedure)]) (~@ argsS))) - (procedureT;translate-procedure translate procedure argsS) + (^code ((~ [_ (#.Text procedure)]) (~@ argsS))) + (procedureT.translate-procedure translate procedure argsS) _ - (&;throw Unrecognized-Synthesis (%code synthesis)) + (&.throw Unrecognized-Synthesis (%code synthesis)) )) diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux index ab3382952..3070800fe 100644 --- a/new-luxc/source/luxc/lang/translation/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do]) (data [text] @@ -6,320 +6,320 @@ (coll [list "list/" Functor<List> Monoid<List>])) [macro]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common] - [";T" runtime] - [";T" reference]) - [";L" variable #+ Variable]))) + (translation [".T" common] + [".T" runtime] + [".T" reference]) + [".L" variable #+ Variable]))) (def: arity-field Text "arity") -(def: $Object $;Type ($t;class "java.lang.Object" (list))) +(def: $Object $.Type ($t.class "java.lang.Object" (list))) (def: (poly-arg? arity) - (-> ls;Arity Bool) - (n.> +1 arity)) + (-> ls.Arity Bool) + (n/> +1 arity)) (def: (reset-method class) - (-> Text $;Method) - ($t;method (list) (#;Some ($t;class class (list))) (list))) + (-> 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)) + (-> (List Variable) (List $.Type)) + (list.repeat (list.size env) $Object)) (def: (init-method env arity) - (-> (List Variable) ls;Arity $;Method) + (-> (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 + ($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)))) + ($t.method (captured-args env) #.None (list)))) (def: (implementation-method arity) - ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) + ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) (def: get-amount-of-partialsI - $;Inst - (|>. ($i;ALOAD +0) - ($i;GETFIELD hostL;function-class runtimeT;partials-field $t;int))) + $.Inst + (|>> ($i.ALOAD +0) + ($i.GETFIELD hostL.function-class runtimeT.partials-field $t.int))) (def: (load-fieldI class field) - (-> Text Text $;Inst) - (|>. ($i;ALOAD +0) - ($i;GETFIELD class field $Object))) + (-> 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)) + (-> $.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 runtimeT;num-apply-variants) - later-applysI (if (n.> runtimeT;num-apply-variants amount) - (applysI (n.+ runtimeT;num-apply-variants start) (n.- runtimeT;num-apply-variants amount)) + (-> $.Register Nat $.Inst) + (let [max-args (n/min amount runtimeT.num-apply-variants) + later-applysI (if (n/> runtimeT.num-apply-variants amount) + (applysI (n/+ runtimeT.num-apply-variants start) (n/- runtimeT.num-apply-variants amount)) id)] - (|>. ($i;CHECKCAST hostL;function-class) + (|>> ($i.CHECKCAST hostL.function-class) (inputsI start max-args) - ($i;INVOKEVIRTUAL hostL;function-class runtimeT;apply-method (runtimeT;apply-signature max-args) false) + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature max-args) false) later-applysI))) (def: (inc-intI by) - (-> Nat $;Inst) - (|>. ($i;int (nat-to-int by)) - $i;IADD)) + (-> Nat $.Inst) + (|>> ($i.int (nat-to-int by)) + $i.IADD)) (def: (nullsI amount) - (-> Nat $;Inst) - (|> $i;NULL - (list;repeat amount) - $i;fuse)) + (-> Nat $.Inst) + (|> $i.NULL + (list.repeat amount) + $i.fuse)) (def: (with-captured env) - (-> (List Variable) $;Def) - (|> (list;enumerate env) + (-> (List Variable) $.Def) + (|> (list.enumerate env) (list/map (function [[env-idx env-source]] - ($d;field #$;Private $;finalF (referenceT;captured env-idx) $Object))) - $d;fuse)) + ($d.field #$.Private $.finalF (referenceT.captured env-idx) $Object))) + $d.fuse)) (def: (with-partial arity) - (-> ls;Arity $;Def) + (-> ls.Arity $.Def) (if (poly-arg? arity) - (|> (list;n.range +0 (n.- +2 arity)) + (|> (list.n/range +0 (n/- +2 arity)) (list/map (function [idx] - ($d;field #$;Private $;finalF (referenceT;partial idx) $Object))) - $d;fuse) + ($d.field #$.Private $.finalF (referenceT.partial idx) $Object))) + $d.fuse) id)) (def: (instance class arity env) - (-> Text ls;Arity (List Variable) (Meta $;Inst)) - (do macro;Monad<Meta> - [captureI+ (monad;map @ referenceT;translate-variable env) + (-> Text ls.Arity (List Variable) (Meta $.Inst)) + (do macro.Monad<Meta> + [captureI+ (monad.map @ referenceT.translate-variable env) #let [argsI (if (poly-arg? arity) - (|> (nullsI (n.dec arity)) - (list ($i;int 0)) - $i;fuse) + (|> (nullsI (n/dec arity)) + (list ($i.int 0)) + $i.fuse) id)]] - (wrap (|>. ($i;NEW class) - $i;DUP - ($i;fuse captureI+) + (wrap (|>> ($i.NEW class) + $i.DUP + ($i.fuse captureI+) argsI - ($i;INVOKESPECIAL class "<init>" (init-method env arity) false))))) + ($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) + (-> Text ls.Arity (List Variable) $.Def) + ($d.method #$.Public $.noneM "reset" (reset-method class) (if (poly-arg? arity) - (let [env-size (list;size env) + (let [env-size (list.size env) captureI (|> (case env-size +0 (list) - _ (list;n.range +0 (n.dec env-size))) + _ (list.n/range +0 (n/dec env-size))) (list/map (function [source] - (|>. ($i;ALOAD +0) - ($i;GETFIELD class (referenceT;captured source) $Object)))) - $i;fuse) - argsI (|> (nullsI (n.dec arity)) - (list ($i;int 0)) - $i;fuse)] - (|>. ($i;NEW class) - $i;DUP + (|>> ($i.ALOAD +0) + ($i.GETFIELD class (referenceT.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)))) + ($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) + (-> Nat $.Label $.Inst $.Def) + ($d.method #$.Public $.strictM "impl" (implementation-method arity) + (|>> ($i.label @begin) bodyI - $i;ARETURN))) + $i.ARETURN))) (def: function-init-method - $;Method - ($t;method (list $t;int) #;None (list))) + $.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)))) + (-> 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) + (-> Text (List Variable) ls.Arity $.Def) + (let [env-size (list.size env) offset-partial (: (-> Nat Nat) - (|>. n.inc (n.+ env-size))) + (|>> n/inc (n/+ env-size))) store-capturedI (|> (case env-size +0 (list) - _ (list;n.range +0 (n.dec env-size))) + _ (list.n/range +0 (n/dec env-size))) (list/map (function [register] - (|>. ($i;ALOAD +0) - ($i;ALOAD (n.inc register)) - ($i;PUTFIELD class (referenceT;captured register) $Object)))) - $i;fuse) + (|>> ($i.ALOAD +0) + ($i.ALOAD (n/inc register)) + ($i.PUTFIELD class (referenceT.captured register) $Object)))) + $i.fuse) store-partialI (if (poly-arg? arity) - (|> (list;n.range +0 (n.- +2 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 (referenceT;partial idx) $Object))))) - $i;fuse) + (|>> ($i.ALOAD +0) + ($i.ALOAD (n/inc register)) + ($i.PUTFIELD class (referenceT.partial idx) $Object))))) + $i.fuse) id)] - ($d;method #$;Public $;noneM "<init>" (init-method env arity) - (|>. ($i;ALOAD +0) + ($d.method #$.Public $.noneM "<init>" (init-method env arity) + (|>> ($i.ALOAD +0) (function-init arity env-size) store-capturedI store-partialI - $i;RETURN)))) + $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))) + (-> 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.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 (|>. referenceT;partial (load-fieldI class))) - $i;fuse) + (let [load-partialsI (if (n/> +0 stage) + (|> (list.n/range +0 (n/dec stage)) + (list/map (|>> referenceT.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)) + (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.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) + (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.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) + ## (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 (|>. referenceT;captured (load-fieldI class))) - $i;fuse)] - (|>. ($i;label @label) - ($i;NEW class) - $i;DUP + _ (list.n/range +0 (n/dec env-size))) + (list/map (|>> referenceT.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)) + (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 runtimeT;apply-method (runtimeT;apply-signature apply-arity) - (|>. get-amount-of-partialsI - ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int) + $i.fuse)] + ($d.method #$.Public $.noneM runtimeT.apply-method (runtimeT.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 + ($i.INVOKESTATIC hostL.runtime-class "apply_fail" ($t.method (list) #.None (list)) false) + $i.NULL + $i.ARETURN )))) (def: #export (with-function @begin class env arity bodyI) - (-> $;Label Text (List Variable) ls;Arity $;Inst - (Meta [$;Def $;Inst])) - (let [env-size (list;size env) - applyD (: $;Def + (-> $.Label Text (List Variable) ls.Arity $.Inst + (Meta [$.Def $.Inst])) + (let [env-size (list.size env) + applyD (: $.Def (if (poly-arg? arity) - (|> (n.min arity runtimeT;num-apply-variants) - (list;n.range +1) + (|> (n/min arity runtimeT.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 runtimeT;apply-method (runtimeT;apply-signature +1) - (|>. ($i;label @begin) + $d.fuse) + ($d.method #$.Public $.strictM runtimeT.apply-method (runtimeT.apply-signature +1) + (|>> ($i.label @begin) bodyI - $i;ARETURN)))) - functionD (: $;Def - (|>. ($d;int-field #$;Public ($_ $;++F $;staticF $;finalF) arity-field (nat-to-int arity)) + $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 ))] - (do macro;Monad<Meta> + (do macro.Monad<Meta> [instanceI (instance class arity env)] (wrap [functionD instanceI])))) (def: #export (translate-function translate env arity bodyS) - (-> (-> ls;Synthesis (Meta $;Inst)) - (List Variable) ls;Arity ls;Synthesis - (Meta $;Inst)) - (do macro;Monad<Meta> - [@begin $i;make-label - [function-class bodyI] (hostL;with-sub-context - (hostL;with-anchor [@begin +1] + (-> (-> ls.Synthesis (Meta $.Inst)) + (List Variable) ls.Arity ls.Synthesis + (Meta $.Inst)) + (do macro.Monad<Meta> + [@begin $i.make-label + [function-class bodyI] (hostL.with-sub-context + (hostL.with-anchor [@begin +1] (translate bodyS))) - this-module macro;current-module-name - #let [function-class (format (text;replace-all "/" "." this-module) "." function-class)] + this-module macro.current-module-name + #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)] [functionD instanceI] (with-function @begin function-class env arity bodyI) - _ (commonT;store-class function-class - ($d;class #$;V1.6 #$;Public $;finalC + _ (commonT.store-class function-class + ($d.class #$.V1_6 #$.Public $.finalC function-class (list) - ($;simple-class hostL;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) + (let [[pre post] (list.split size elems)] + (if (list.empty? post) (list pre) (list& pre (segment size post))))) (def: #export (translate-call translate functionS argsS) - (-> (-> ls;Synthesis (Meta $;Inst)) - ls;Synthesis (List ls;Synthesis) - (Meta $;Inst)) - (do macro;Monad<Meta> + (-> (-> ls.Synthesis (Meta $.Inst)) + ls.Synthesis (List ls.Synthesis) + (Meta $.Inst)) + (do macro.Monad<Meta> [functionI (translate functionS) - argsI (monad;map @ translate argsS) - #let [applyI (|> (segment runtimeT;num-apply-variants argsI) + argsI (monad.map @ translate argsS) + #let [applyI (|> (segment runtimeT.num-apply-variants argsI) (list/map (function [chunkI+] - (|>. ($i;CHECKCAST hostL;function-class) - ($i;fuse chunkI+) - ($i;INVOKEVIRTUAL hostL;function-class runtimeT;apply-method (runtimeT;apply-signature (list;size chunkI+)) false)))) - $i;fuse)]] - (wrap (|>. functionI + (|>> ($i.CHECKCAST hostL.function-class) + ($i.fuse chunkI+) + ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature (list.size chunkI+)) false)))) + $i.fuse)]] + (wrap (|>> functionI applyI)))) diff --git a/new-luxc/source/luxc/lang/translation/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/imports.jvm.lux index be8b828cd..892dd869f 100644 --- a/new-luxc/source/luxc/lang/translation/imports.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/imports.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["p" parser] @@ -19,16 +19,16 @@ [io #+ IO Process io] [host]) (luxc ["&" lang] - (lang [";L" module]))) + (lang [".L" module]))) (exception: #export Invalid-Imports) (exception: #export Module-Cannot-Import-Itself) (exception: #export Circular-Dependency) -(host;import (java.util.concurrent.Future a) +(host.import (java/util/concurrent/Future a) (get [] #io a)) -(host;import (java.util.concurrent.CompletableFuture a) +(host.import (java/util/concurrent/CompletableFuture a) (new []) (complete [a] boolean) (#static [a] completedFuture [a] (CompletableFuture a))) @@ -37,55 +37,55 @@ {#module Text #alias Text}) -(def: import (s;Syntax Import) (s;tuple (p;seq s;text s;text))) +(def: import (s.Syntax Import) (s.tuple (p.seq s.text s.text))) (def: compilations (Var (Dict Text (CompletableFuture (Error Compiler)))) - (stm;var (dict;new text;Hash<Text>))) + (stm.var (dict.new text.Hash<Text>))) (def: (promise-to-future promise) (All [a] (-> (Promise a) (Future a))) - (let [future (CompletableFuture.new [])] - (exec (:: promise;Functor<Promise> map - (function [value] (CompletableFuture.complete [value] future)) + (let [future (CompletableFuture::new [])] + (exec (:: promise.Functor<Promise> map + (function [value] (CompletableFuture::complete [value] future)) promise) future))) (def: from-io (All [a] (-> (IO a) (Process a))) - (:: io;Monad<IO> map (|>. #e;Success))) + (:: io.Monad<IO> map (|>> #e.Success))) (def: (translate-dependency translate-module dependency compiler) (-> (-> Text Compiler (Process Compiler)) (-> Text Compiler (IO (Future (Error Compiler))))) - (<| (Future.get []) + (<| (Future::get []) promise-to-future - (do promise;Monad<Promise> - [[new? future] (stm;commit (: (STM [Bool (CompletableFuture (Error Compiler))]) - (do stm;Monad<STM> - [current-compilations (stm;read compilations)] - (case (dict;get dependency current-compilations) - (#;Some ongoing) + (do promise.Monad<Promise> + [[new? future] (stm.commit (: (STM [Bool (CompletableFuture (Error Compiler))]) + (do stm.Monad<STM> + [current-compilations (stm.read compilations)] + (case (dict.get dependency current-compilations) + (#.Some ongoing) (wrap [false ongoing]) - #;None + #.None (do @ [#let [pending (: (CompletableFuture (Error Compiler)) - (CompletableFuture.new []))] - _ (stm;write (dict;put dependency pending current-compilations) + (CompletableFuture::new []))] + _ (stm.write (dict.put dependency pending current-compilations) compilations)] (wrap [true pending]))))))] (if new? - (exec (promise;future (io (CompletableFuture.complete [(io;run (translate-module dependency compiler))] - future))) + (exec (promise.future (io (CompletableFuture::complete [(io.run (translate-module dependency compiler))] + future))) (wrap future)) (wrap future))))) (def: compiled? (-> Module Bool) - (|>. (get@ #;module-state) + (|>> (get@ #.module-state) (case> - (^or #;Cached #;Compiled) + (^or #.Cached #.Compiled) true _ @@ -94,56 +94,56 @@ (def: (merge-modules current-module from-dependency from-current) (-> Text (List [Text Module]) (List [Text Module]) (List [Text Module])) (|> from-dependency - (list;filter (|>. product;right compiled?)) - (list/fold (function [[dep-name dep-module] total] (&;pl-put dep-name dep-module total)) + (list.filter (|>> product.right compiled?)) + (list/fold (function [[dep-name dep-module] total] (&.pl-put dep-name dep-module total)) from-current))) (def: (merge-compilers current-module dependency total) (-> Text Compiler Compiler Compiler) (|> total - (update@ #;modules (merge-modules current-module (get@ #;modules dependency))) - (set@ #;seed (get@ #;seed dependency)))) + (update@ #.modules (merge-modules current-module (get@ #.modules dependency))) + (set@ #.seed (get@ #.seed dependency)))) (def: #export (translate-imports translate-module annotations) (-> (-> Text Compiler (Process Compiler)) Code (Meta (Process Compiler))) - (do macro;Monad<Meta> - [_ (moduleL;set-annotations annotations) - current-module macro;current-module-name - imports (let [imports (|> (macro;get-tuple-ann (ident-for #;imports) annotations) - (maybe;default (list)))] - (case (s;run imports (p;some import)) - (#e;Success imports) + (do macro.Monad<Meta> + [_ (moduleL.set-annotations annotations) + current-module macro.current-module-name + imports (let [imports (|> (macro.get-tuple-ann (ident-for #.imports) annotations) + (maybe.default (list)))] + (case (s.run imports (p.some import)) + (#e.Success imports) (wrap imports) - (#e;Error error) - (&;throw Invalid-Imports (%code (code;tuple imports))))) - dependencies (monad;map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler))))) + (#e.Error error) + (&.throw Invalid-Imports (%code (code.tuple imports))))) + dependencies (monad.map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler))))) (function [[dependency alias]] (do @ - [_ (&;assert Module-Cannot-Import-Itself current-module + [_ (&.assert Module-Cannot-Import-Itself current-module (not (text/= current-module dependency))) - already-seen? (moduleL;exists? dependency) + already-seen? (moduleL.exists? dependency) circular-dependency? (if already-seen? - (moduleL;active? dependency) + (moduleL.active? dependency) (wrap false)) - _ (&;assert Circular-Dependency (format "From: " current-module "\n" + _ (&.assert Circular-Dependency (format "From: " current-module "\n" " To: " dependency) (not circular-dependency?)) - _ (moduleL;import dependency) + _ (moduleL.import dependency) _ (if (text/= "" alias) (wrap []) - (moduleL;alias alias dependency)) - compiler macro;get-compiler] + (moduleL.alias alias dependency)) + compiler macro.get-compiler] (if already-seen? - (wrap (io (CompletableFuture.completedFuture [(#e;Success compiler)]))) + (wrap (io (CompletableFuture::completedFuture [(#e.Success compiler)]))) (wrap (translate-dependency translate-module dependency compiler)))))) imports) - compiler macro;get-compiler] - (wrap (do io;Monad<Process> - [dependencies (monad;seq io;Monad<Process> (list/map from-io dependencies)) + compiler macro.get-compiler] + (wrap (do io.Monad<Process> + [dependencies (monad.seq io.Monad<Process> (list/map from-io dependencies)) dependencies (|> dependencies - (list/map (Future.get [])) - (monad;seq io;Monad<Process>))] + (list/map (Future::get [])) + (monad.seq io.Monad<Process>))] (wrap (list/fold (merge-compilers current-module) compiler dependencies)))))) diff --git a/new-luxc/source/luxc/lang/translation/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/loop.jvm.lux index 77d43a0e5..8920dc936 100644 --- a/new-luxc/source/luxc/lang/translation/loop.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/loop.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do]) (data [text] @@ -6,23 +6,23 @@ (coll [list "list/" Functor<List> Monoid<List>])) [macro]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common] - [";T" runtime] - [";T" reference]) - [";L" variable #+ Variable Register]))) + (translation [".T" common] + [".T" runtime] + [".T" reference]) + [".L" variable #+ Variable Register]))) (def: (constant? register changeS) - (-> Register ls;Synthesis Bool) + (-> Register ls.Synthesis Bool) (case changeS - (^multi (^code ((~ [_ (#;Int var)]))) - (i.= (variableL;local register) + (^multi (^code ((~ [_ (#.Int var)]))) + (i/= (variableL.local register) var)) true @@ -30,12 +30,12 @@ false)) (def: #export (translate-recur translate argsS) - (-> (-> ls;Synthesis (Meta $;Inst)) - (List ls;Synthesis) - (Meta $;Inst)) - (do macro;Monad<Meta> - [[@begin offset] hostL;anchor - #let [pairs (list;zip2 (list;n.range offset (|> (list;size argsS) n.dec (n.+ offset))) + (-> (-> ls.Synthesis (Meta $.Inst)) + (List ls.Synthesis) + (Meta $.Inst)) + (do macro.Monad<Meta> + [[@begin offset] hostL.anchor + #let [pairs (list.zip2 (list.n/range offset (|> (list.size argsS) n/dec (n/+ offset))) argsS)] ## It may look weird that first I compile the values separately, ## and then I compile the stores/allocations. @@ -45,36 +45,36 @@ ## and stores separately, then by the time Y is evaluated, it ## will refer to the new value of X, instead of the old value, as ## must be the case. - valuesI+ (monad;map @ (function [[register argS]] - (: (Meta $;Inst) + valuesI+ (monad.map @ (function [[register argS]] + (: (Meta $.Inst) (if (constant? register argS) (wrap id) (translate argS)))) pairs) #let [storesI+ (list/map (function [[register argS]] - (: $;Inst + (: $.Inst (if (constant? register argS) id - ($i;ASTORE register)))) - (list;reverse pairs))]] - (wrap (|>. ($i;fuse valuesI+) - ($i;fuse storesI+) - ($i;GOTO @begin))))) + ($i.ASTORE register)))) + (list.reverse pairs))]] + (wrap (|>> ($i.fuse valuesI+) + ($i.fuse storesI+) + ($i.GOTO @begin))))) (def: #export (translate-loop translate offset initsS+ bodyS) - (-> (-> ls;Synthesis (Meta $;Inst)) - Nat (List ls;Synthesis) ls;Synthesis - (Meta $;Inst)) - (do macro;Monad<Meta> - [@begin $i;make-label - initsI+ (monad;map @ translate initsS+) - bodyI (hostL;with-anchor [@begin offset] + (-> (-> ls.Synthesis (Meta $.Inst)) + Nat (List ls.Synthesis) ls.Synthesis + (Meta $.Inst)) + (do macro.Monad<Meta> + [@begin $i.make-label + initsI+ (monad.map @ translate initsS+) + bodyI (hostL.with-anchor [@begin offset] (translate bodyS)) - #let [initializationI (|> (list;enumerate initsI+) + #let [initializationI (|> (list.enumerate initsI+) (list/map (function [[register initI]] - (|>. initI - ($i;ASTORE (n.+ offset register))))) - $i;fuse)]] - (wrap (|>. initializationI - ($i;label @begin) + (|>> initI + ($i.ASTORE (n/+ offset register))))) + $i.fuse)]] + (wrap (|>> initializationI + ($i.label @begin) bodyI)))) diff --git a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux index acd3b95e3..8fed1de18 100644 --- a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux @@ -1,35 +1,35 @@ -(;module: +(.module: lux (lux (control monad) (data text/format) [macro "macro/" Monad<Meta>]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$i" inst] ["$t" type])) ["la" analysis] ["ls" synthesis] - (translation [";T" common])))) + (translation [".T" common])))) (def: #export translate-unit - (Meta $;Inst) - (macro/wrap ($i;string hostL;unit))) + (Meta $.Inst) + (macro/wrap ($i.string hostL.unit))) (def: #export (translate-bool value) - (-> Bool (Meta $;Inst)) - (macro/wrap ($i;GETSTATIC "java.lang.Boolean" + (-> Bool (Meta $.Inst)) + (macro/wrap ($i.GETSTATIC "java.lang.Boolean" (if value "TRUE" "FALSE") - ($t;class "java.lang.Boolean" (list))))) + ($t.class "java.lang.Boolean" (list))))) (do-template [<name> <type> <load> <wrap>] [(def: #export (<name> value) - (-> <type> (Meta $;Inst)) - (macro/wrap (|>. (<load> value) <wrap>)))] + (-> <type> (Meta $.Inst)) + (macro/wrap (|>> (<load> value) <wrap>)))] - [translate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)] - [translate-int Int $i;long ($i;wrap #$;Long)] - [translate-deg Deg (|>. (:! Int) $i;long) ($i;wrap #$;Long)] - [translate-frac Frac $i;double ($i;wrap #$;Double)] - [translate-text Text $i;string id] + [translate-nat Nat (|>> (:! Int) $i.long) ($i.wrap #$.Long)] + [translate-int Int $i.long ($i.wrap #$.Long)] + [translate-deg Deg (|>> (:! Int) $i.long) ($i.wrap #$.Long)] + [translate-frac Frac $i.double ($i.wrap #$.Double)] + [translate-text Text $i.string id] ) diff --git a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux index 14fbe2f1a..e4f8b9908 100644 --- a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -8,20 +8,20 @@ (luxc ["&" lang] (lang (host ["$" jvm]) ["ls" synthesis])) - (/ ["/;" common] - ["/;" host])) + (/ ["/." common] + ["/." host])) (exception: #export Unknown-Procedure) (def: procedures - /common;Bundle - (|> /common;procedures - (dict;merge /host;procedures))) + /common.Bundle + (|> /common.procedures + (dict.merge /host.procedures))) (def: #export (translate-procedure translate name args) - (-> (-> ls;Synthesis (Meta $;Inst)) Text (List ls;Synthesis) - (Meta $;Inst)) - (<| (maybe;default (&;throw Unknown-Procedure (%t name))) - (do maybe;Monad<Maybe> - [proc (dict;get name procedures)] + (-> (-> ls.Synthesis (Meta $.Inst)) Text (List ls.Synthesis) + (Meta $.Inst)) + (<| (maybe.default (&.throw Unknown-Procedure (%t name))) + (do maybe.Monad<Maybe> + [proc (dict.get name procedures)] (wrap (proc translate args))))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux index 01f2a33c7..41d9b91ab 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["p" parser] @@ -13,23 +13,23 @@ ["s" syntax #+ syntax:]) [host]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" runtime] - [";T" case] - [";T" function] - [";T" loop])))) + (translation [".T" runtime] + [".T" case] + [".T" function] + [".T" loop])))) -(host;import java.lang.Long +(host.import java/lang/Long (#static MIN_VALUE Long) (#static MAX_VALUE Long)) -(host;import java.lang.Double +(host.import java/lang/Double (#static MIN_VALUE Double) (#static MAX_VALUE Double) (#static NaN Double) @@ -38,42 +38,42 @@ ## [Types] (type: #export Translator - (-> ls;Synthesis (Meta $;Inst))) + (-> ls.Synthesis (Meta $.Inst))) (type: #export Proc - (-> Translator (List ls;Synthesis) (Meta $;Inst))) + (-> Translator (List ls.Synthesis) (Meta $.Inst))) (type: #export Bundle (Dict Text Proc)) -(syntax: (Vector [size s;nat] elemT) - (wrap (list (` [(~@ (list;repeat size elemT))])))) +(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)) -(type: #export Variadic (-> (List $;Inst) $;Inst)) +(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)) +(type: #export Variadic (-> (List $.Inst) $.Inst)) ## [Utils] -(def: $Object $;Type ($t;class "java.lang.Object" (list))) -(def: $Object-Array $;Type ($t;array +1 $Object)) -(def: $Variant $;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: $Object $.Type ($t.class "java.lang.Object" (list))) +(def: $Object-Array $.Type ($t.array +1 $Object)) +(def: $Variant $.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))) + (dict.put name (unnamed name))) (def: #export (prefix prefix bundle) (-> Text Bundle Bundle) (|> bundle - dict;entries + dict.entries (list/map (function [[key val]] [(format prefix " " key) val])) - (dict;from-list text;Hash<Text>))) + (dict.from-list text.Hash<Text>))) (def: (wrong-arity proc expected actual) (-> Text Nat Nat Text) @@ -81,26 +81,26 @@ "Expected: " (|> expected nat-to-int %i) "\n" " Actual: " (|> actual nat-to-int %i))) -(syntax: (arity: [name s;local-symbol] [arity s;nat]) +(syntax: (arity: [name s.local-symbol] [arity s.nat]) (with-gensyms [g!proc g!name g!translate g!inputs] (do @ - [g!input+ (monad;seq @ (list;repeat arity (macro;gensym "input")))] - (wrap (list (` (def: #export ((~ (code;local-symbol name)) (~ g!proc)) - (-> (-> (;;Vector (~ (code;nat arity)) $;Inst) $;Inst) - (-> Text ;;Proc)) + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) + (-> (-> (..Vector (~ (code.nat arity)) $.Inst) $.Inst) + (-> Text ..Proc)) (function [(~ g!name)] (function [(~ g!translate) (~ g!inputs)] (case (~ g!inputs) (^ (list (~@ g!input+))) - (do macro;Monad<Meta> + (do macro.Monad<Meta> [(~@ (|> g!input+ (list/map (function [g!input] (list g!input (` ((~ g!translate) (~ g!input)))))) - list;concat))] + list.concat))] ((~' wrap) ((~ g!proc) [(~@ g!input+)]))) (~' _) - (macro;fail (wrong-arity (~ g!name) +1 (list;size (~ g!inputs)))))))))))))) + (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) (arity: nullary +0) (arity: unary +1) @@ -111,54 +111,54 @@ (-> Variadic (-> Text Proc)) (function [proc-name] (function [translate inputsS] - (do macro;Monad<Meta> - [inputsI (monad;map @ translate inputsS)] + (do macro.Monad<Meta> + [inputsI (monad.map @ translate inputsS)] (wrap (proc inputsI)))))) ## [Instructions] -(def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long))) -(def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I)) +(def: lux-intI $.Inst (|>> $i.I2L ($i.wrap #$.Long))) +(def: jvm-intI $.Inst (|>> ($i.unwrap #$.Long) $i.L2I)) (def: (array-writeI arrayI idxI elemI) - (-> $;Inst $;Inst $;Inst - $;Inst) - (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) - $i;DUP + (-> $.Inst $.Inst $.Inst + $.Inst) + (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array)) + $i.DUP idxI jvm-intI elemI - $i;AASTORE)) + $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) + (-> (-> $.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 + (|>> leftI rightI - (predicateI $i;IF_ACMPEQ))) + (predicateI $i.IF_ACMPEQ))) (def: (lux//if [testI thenI elseI]) Trinary - (caseT;translate-if testI thenI elseI)) + (caseT.translate-if testI thenI elseI)) (def: (lux//try riskyI) Unary - (|>. riskyI - ($i;CHECKCAST hostL;function-class) - ($i;INVOKESTATIC hostL;runtime-class "try" - ($t;method (list $Function) (#;Some $Object-Array) (list)) + (|>> riskyI + ($i.CHECKCAST hostL.function-class) + ($i.INVOKESTATIC hostL.runtime-class "try" + ($t.method (list $Function) (#.Some $Object-Array) (list)) false))) (def: (lux//noop valueI) @@ -167,80 +167,80 @@ (exception: #export Wrong-Syntax) (def: #export (wrong-syntax procedure args) - (-> Text (List ls;Synthesis) Text) + (-> Text (List ls.Synthesis) Text) (format "Procedure: " procedure "\n" - "Arguments: " (%code (code;tuple args)))) + "Arguments: " (%code (code.tuple args)))) (def: lux//loop (-> Text Proc) (function [proc-name] (function [translate inputsS] - (case (s;run inputsS ($_ p;seq s;nat (s;tuple (p;many s;any)) s;any)) - (#e;Success [offset initsS+ bodyS]) - (loopT;translate-loop translate offset initsS+ bodyS) + (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) + (#e.Success [offset initsS+ bodyS]) + (loopT.translate-loop translate offset initsS+ bodyS) - (#e;Error error) - (&;throw Wrong-Syntax (wrong-syntax proc-name inputsS))) + (#e.Error error) + (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) ))) (def: lux//recur (-> Text Proc) (function [proc-name] (function [translate inputsS] - (loopT;translate-recur translate inputsS)))) + (loopT.translate-recur translate inputsS)))) ## [[Bits]] (do-template [<name> <op>] [(def: (<name> [inputI maskI]) Binary - (|>. inputI ($i;unwrap #$;Long) - maskI ($i;unwrap #$;Long) - <op> ($i;wrap #$;Long)))] + (|>> inputI ($i.unwrap #$.Long) + maskI ($i.unwrap #$.Long) + <op> ($i.wrap #$.Long)))] - [bit//and $i;LAND] - [bit//or $i;LOR] - [bit//xor $i;LXOR] + [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) + (|>> inputI ($i.unwrap #$.Long) + ($i.INVOKESTATIC "java.lang.Long" "bitCount" ($t.method (list $t.long) (#.Some $t.int) (list)) false) lux-intI)) (do-template [<name> <op>] [(def: (<name> [inputI shiftI]) Binary - (|>. inputI ($i;unwrap #$;Long) + (|>> inputI ($i.unwrap #$.Long) shiftI jvm-intI <op> - ($i;wrap #$;Long)))] + ($i.wrap #$.Long)))] - [bit//shift-left $i;LSHL] - [bit//shift-right $i;LSHR] - [bit//unsigned-shift-right $i;LUSHR] + [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;binary-name "java.lang.Object")))) + (|>> lengthI jvm-intI ($i.ANEWARRAY ($t.binary-name "java.lang.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)) + (<| $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) - runtimeT;someI - ($i;GOTO @end) - ($i;label @is-null) - $i;POP - runtimeT;noneI - ($i;label @end)))) + $i.AALOAD + $i.DUP + ($i.IFNULL @is-null) + runtimeT.someI + ($i.GOTO @end) + ($i.label @is-null) + $i.POP + runtimeT.noneI + ($i.label @end)))) (def: (array//put [arrayI idxI elemI]) Trinary @@ -248,137 +248,137 @@ (def: (array//remove [arrayI idxI]) Binary - (array-writeI arrayI idxI $i;NULL)) + (array-writeI arrayI idxI $i.NULL)) (def: (array//size arrayI) Unary - (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) - $i;ARRAYLENGTH + (|>> 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))) + $.Method + ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) -(def: deg-method $;Method nat-method) +(def: deg-method $.Method nat-method) (def: compare-nat-method - $;Method - ($t;method (list $t;long $t;long) (#;Some $t;int) (list))) + $.Method + ($t.method (list $t.long $t.long) (#.Some $t.int) (list))) (do-template [<name> <const> <type>] [(def: (<name> _) Nullary - (|>. <const> ($i;wrap <type>)))] + (|>> <const> ($i.wrap <type>)))] - [nat//min ($i;long 0) #$;Long] - [nat//max ($i;long -1) #$;Long] + [nat//min ($i.long 0) #$.Long] + [nat//max ($i.long -1) #$.Long] - [int//min ($i;long Long.MIN_VALUE) #$;Long] - [int//max ($i;long Long.MAX_VALUE) #$;Long] + [int//min ($i.long Long::MIN_VALUE) #$.Long] + [int//max ($i.long Long::MAX_VALUE) #$.Long] - [frac//smallest ($i;double Double.MIN_VALUE) #$;Double] - [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) #$;Double] - [frac//max ($i;double Double.MAX_VALUE) #$;Double] - [frac//not-a-number ($i;double Double.NaN) #$;Double] - [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) #$;Double] - [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) #$;Double] - - [deg//min ($i;long 0) #$;Long] - [deg//max ($i;long -1) #$;Long] + [frac//smallest ($i.double Double::MIN_VALUE) #$.Double] + [frac//min ($i.double (f/* -1.0 Double::MAX_VALUE)) #$.Double] + [frac//max ($i.double Double::MAX_VALUE) #$.Double] + [frac//not-a-number ($i.double Double::NaN) #$.Double] + [frac//positive-infinity ($i.double Double::POSITIVE_INFINITY) #$.Double] + [frac//negative-infinity ($i.double Double::NEGATIVE_INFINITY) #$.Double] + + [deg//min ($i.long 0) #$.Long] + [deg//max ($i.long -1) #$.Long] ) (do-template [<name> <type> <op>] [(def: (<name> [subjectI paramI]) Binary - (|>. subjectI ($i;unwrap <type>) - paramI ($i;unwrap <type>) + (|>> subjectI ($i.unwrap <type>) + paramI ($i.unwrap <type>) <op> - ($i;wrap <type>)))] + ($i.wrap <type>)))] - [int//add #$;Long $i;LADD] - [int//sub #$;Long $i;LSUB] - [int//mul #$;Long $i;LMUL] - [int//div #$;Long $i;LDIV] - [int//rem #$;Long $i;LREM] + [int//add #$.Long $i.LADD] + [int//sub #$.Long $i.LSUB] + [int//mul #$.Long $i.LMUL] + [int//div #$.Long $i.LDIV] + [int//rem #$.Long $i.LREM] - [nat//add #$;Long $i;LADD] - [nat//sub #$;Long $i;LSUB] - [nat//mul #$;Long $i;LMUL] - [nat//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] - [nat//rem #$;Long ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] - - [frac//add #$;Double $i;DADD] - [frac//sub #$;Double $i;DSUB] - [frac//mul #$;Double $i;DMUL] - [frac//div #$;Double $i;DDIV] - [frac//rem #$;Double $i;DREM] - - [deg//add #$;Long $i;LADD] - [deg//sub #$;Long $i;LSUB] - [deg//mul #$;Long ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] - [deg//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)] - [deg//rem #$;Long $i;LSUB] - [deg//scale #$;Long $i;LMUL] - [deg//reciprocal #$;Long $i;LDIV] + [nat//add #$.Long $i.LADD] + [nat//sub #$.Long $i.LSUB] + [nat//mul #$.Long $i.LMUL] + [nat//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_nat" nat-method false)] + [nat//rem #$.Long ($i.INVOKESTATIC hostL.runtime-class "rem_nat" nat-method false)] + + [frac//add #$.Double $i.DADD] + [frac//sub #$.Double $i.DSUB] + [frac//mul #$.Double $i.DMUL] + [frac//div #$.Double $i.DDIV] + [frac//rem #$.Double $i.DREM] + + [deg//add #$.Long $i.LADD] + [deg//sub #$.Long $i.LSUB] + [deg//mul #$.Long ($i.INVOKESTATIC hostL.runtime-class "mul_deg" deg-method false)] + [deg//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_deg" deg-method false)] + [deg//rem #$.Long $i.LSUB] + [deg//scale #$.Long $i.LMUL] + [deg//reciprocal #$.Long $i.LDIV] ) (do-template [<eq> <lt> <unwrap> <cmp>] [(do-template [<name> <reference>] [(def: (<name> [subjectI paramI]) Binary - (|>. subjectI <unwrap> + (|>> subjectI <unwrap> paramI <unwrap> <cmp> - ($i;int <reference>) - (predicateI $i;IF_ICMPEQ)))] + ($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)] + [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>))] + (|>> inputI <prepare> <transform>))] [nat//to-int id id] - [nat//char ($i;unwrap #$;Long) - ((|>. $i;L2I $i;I2C ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false)))] + [nat//char ($i.unwrap #$.Long) + ((|>> $i.L2I $i.I2C ($i.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) false)))] [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))] + [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) + (|>> 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//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 "java.lang.String" "toUpperCase" id $String] [text//lower "java.lang.String" "toLowerCase" id $String] @@ -387,86 +387,86 @@ (do-template [<name> <pre-subject> <pre-param> <op> <post>] [(def: (<name> [subjectI paramI]) Binary - (|>. subjectI <pre-subject> + (|>> 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) ($i;int -1))] - [text//concat ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false) + ($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) ($i.int -1))] + [text//concat ($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 $Variant) (list)) false) + [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 $Variant) (list)) false) id] ) (do-template [<name> <pre-subject> <pre-param> <pre-extra> <op>] [(def: (<name> [subjectI paramI extraI]) Trinary - (|>. subjectI <pre-subject> + (|>> 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 $Variant) (list)) false)] - [text//replace-once ($i;CHECKCAST "java.lang.String") - (<| ($i;INVOKESTATIC "java.util.regex.Pattern" "quote" ($t;method (list $String) (#;Some $String) (list)) false) - ($i;CHECKCAST "java.lang.String")) - ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t;method (list $String $String) (#;Some $String) (list)) false)] - [text//replace-all ($i;CHECKCAST "java.lang.String") - (<| ($i;INVOKESTATIC "java.util.regex.Pattern" "quote" ($t;method (list $String) (#;Some $String) (list)) false) - ($i;CHECKCAST "java.lang.String")) - ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t;method (list $String $String) (#;Some $String) (list)) false)] + [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 $Variant) (list)) false)] + [text//replace-once ($i.CHECKCAST "java.lang.String") + (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) + ($i.CHECKCAST "java.lang.String")) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t.method (list $String $String) (#.Some $String) (list)) false)] + [text//replace-all ($i.CHECKCAST "java.lang.String") + (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) + ($i.CHECKCAST "java.lang.String")) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t.method (list $String $String) (#.Some $String) (list)) false)] ) -(def: index-method $;Method ($t;method (list $String $t;int) (#;Some $t;int) (list))) +(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") + (<| $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) + ($i.INVOKEVIRTUAL "java.lang.String" <method> index-method false) + $i.DUP + ($i.int -1) + ($i.IF_ICMPEQ @not-found) lux-intI - runtimeT;someI - ($i;GOTO @end) - ($i;label @not-found) - $i;POP - runtimeT;noneI - ($i;label @end))))] + runtimeT.someI + ($i.GOTO @end) + ($i.label @not-found) + $i.POP + runtimeT.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))) +(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)))] + (|>> inputI + ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Math" <method> math-unary-method false) + ($i.wrap #$.Double)))] [math//cos "cos"] [math//sin "sin"] @@ -488,10 +488,10 @@ (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)))] + (|>> 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"] @@ -499,90 +499,90 @@ (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))) + (|>> 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: 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))) + (|>> ($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))) + ($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 + (|>> ($i.NEW "java.lang.Error") + $i.DUP messageI - ($i;CHECKCAST "java.lang.String") - ($i;INVOKESPECIAL "java.lang.Error" "<init>" string-method false) - $i;ATHROW)) + ($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)) + (|>> 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))) + (|>> ($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 + (|>> ($i.NEW atom-class) + $i.DUP initI - ($i;INVOKESPECIAL atom-class "<init>" ($t;method (list $Object) #;None (list)) false))) + ($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))) + (|>> 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) + (|>> 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))) + ($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;INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t;method (list) (#;Some ($t;class "java.lang.Runtime" (list))) (list)) false) - ($i;INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t;method (list) (#;Some $t;int) (list)) false) + (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some ($t.class "java.lang.Runtime" (list))) (list)) false) + ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) false) 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))) + (|>> 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))) + (|>> 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>) + (|> (dict.new text.Hash<Text>) (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary lux//try)) @@ -594,7 +594,7 @@ (def: bit-procs Bundle (<| (prefix "bit") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "count" (unary bit//count)) (install "and" (binary bit//and)) (install "or" (binary bit//or)) @@ -607,7 +607,7 @@ (def: nat-procs Bundle (<| (prefix "nat") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary nat//add)) (install "-" (binary nat//sub)) (install "*" (binary nat//mul)) @@ -623,7 +623,7 @@ (def: int-procs Bundle (<| (prefix "int") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary int//add)) (install "-" (binary int//sub)) (install "*" (binary int//mul)) @@ -639,7 +639,7 @@ (def: deg-procs Bundle (<| (prefix "deg") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary deg//add)) (install "-" (binary deg//sub)) (install "*" (binary deg//mul)) @@ -656,7 +656,7 @@ (def: frac-procs Bundle (<| (prefix "frac") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "+" (binary frac//add)) (install "-" (binary frac//sub)) (install "*" (binary frac//mul)) @@ -678,7 +678,7 @@ (def: text-procs Bundle (<| (prefix "text") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "=" (binary text//eq)) (install "<" (binary text//lt)) (install "concat" (binary text//concat)) @@ -696,7 +696,7 @@ (def: array-procs Bundle (<| (prefix "array") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "new" (unary array//new)) (install "get" (binary array//get)) (install "put" (trinary array//put)) @@ -707,7 +707,7 @@ (def: math-procs Bundle (<| (prefix "math") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "cos" (unary math//cos)) (install "sin" (unary math//sin)) (install "tan" (unary math//tan)) @@ -731,7 +731,7 @@ (def: io-procs Bundle (<| (prefix "io") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "log" (unary io//log)) (install "error" (unary io//error)) (install "exit" (unary io//exit)) @@ -740,7 +740,7 @@ (def: atom-procs Bundle (<| (prefix "atom") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "new" (unary atom//new)) (install "read" (unary atom//read)) (install "compare-and-swap" (trinary atom//compare-and-swap))))) @@ -748,7 +748,7 @@ (def: process-procs Bundle (<| (prefix "process") - (|> (dict;new text;Hash<Text>) + (|> (dict.new text.Hash<Text>) (install "concurrency-level" (nullary process//concurrency-level)) (install "future" (unary process//future)) (install "schedule" (binary process//schedule)) @@ -757,17 +757,17 @@ (def: #export procedures Bundle (<| (prefix "lux") - (|> (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) + (|> (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/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux index 2aa693d2c..f2f88904d 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["p" parser "parser/" Monad<Parser>] @@ -15,13 +15,13 @@ ["s" syntax #+ syntax:]) [host]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] - (analysis (procedure ["&;" host])) + (analysis (procedure ["&." host])) ["ls" synthesis])) ["@" //common]) @@ -30,732 +30,732 @@ (do-template [<name> <inst>] [(def: <name> - $;Inst + $.Inst <inst>)] - [L2S (|>. $i;L2I $i;I2S)] - [L2B (|>. $i;L2I $i;I2B)] - [L2C (|>. $i;L2I $i;I2C)] + [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>) + @.Unary + (if (is $i.NOP <conversion>) + (|>> inputI + ($i.unwrap <unwrap>) + ($i.wrap <wrap>)) + (|>> inputI + ($i.unwrap <unwrap>) <conversion> - ($i;wrap <wrap>))))] + ($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] + [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)) + @.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] + @.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] + [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] + [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>) + @.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))))] + ($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] + [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] + [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>) + @.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] + ($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] + [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] + [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)) + @.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)) + @.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//<)) + @.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//<)) + @.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//<)) + @.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))) + @.Unary + (|>> arrayI + $i.ARRAYLENGTH + $i.I2L + ($i.wrap #$.Long))) (def: (array//new proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS)) + (do macro.Monad<Meta> [lengthI (translate 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)))) + #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)))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (array//read proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] idxS arrayS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] idxS arrayS)) + (do macro.Monad<Meta> [arrayI (translate arrayS) idxI (translate 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 + "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 + ($i.unwrap #$.Long) + $i.L2I loadI))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (array//write proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] idxS valueS arrayS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] idxS valueS arrayS)) + (do macro.Monad<Meta> [arrayI (translate arrayS) idxI (translate idxS) valueI (translate 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 + "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 + ($i.unwrap #$.Long) + $i.L2I valueI storeI))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (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) + @.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) + @.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)))) + @.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 + @.Binary + (|>> monitorI + $i.DUP + $i.MONITORENTER exprI - $i;SWAP - $i;MONITOREXIT)) + $i.SWAP + $i.MONITOREXIT)) (def: (object//throw exceptionI) - @;Unary - (|>. exceptionI - $i;ATHROW)) + @.Unary + (|>> exceptionI + $i.ATHROW)) (def: (object//class proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)])) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)])) + (do macro.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))) + (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)))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (object//instance? proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] objectS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] objectS)) + (do macro.Monad<Meta> [objectI (translate objectS)] - (wrap (|>. objectI - ($i;INSTANCEOF class) - ($i;wrap #$;Boolean)))) + (wrap (|>> objectI + ($i.INSTANCEOF class) + ($i.wrap #$.Boolean)))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (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?) + @.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>))) + (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 translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)])) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)])) + (do macro.Monad<Meta> [] - (case (dict;get unboxed primitives) - (#;Some primitive) + (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 + "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)))) + (wrap (|>> ($i.GETSTATIC class field (#$.Primitive primitive)) + ($i.wrap primitive)))) - #;None - (wrap ($i;GETSTATIC class field ($t;class unboxed (list)))))) + #.None + (wrap ($i.GETSTATIC class field ($t.class unboxed (list)))))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (static//put proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS)) + (do macro.Monad<Meta> [valueI (translate valueS)] - (case (dict;get unboxed primitives) - (#;Some primitive) + (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 + "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)))) + (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))))) + #.None + (wrap (|>> valueI + ($i.CHECKCAST class) + ($i.PUTSTATIC class field ($t.class class (list))) + ($i.string hostL.unit))))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (virtual//get proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS)) + (do macro.Monad<Meta> [objectI (translate objectS)] - (case (dict;get unboxed primitives) - (#;Some primitive) + (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 + "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)))) + (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))))))) + #.None + (wrap (|>> objectI + ($i.CHECKCAST class) + ($i.GETFIELD class field ($t.class unboxed (list))))))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (def: (virtual//put proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS)) - (do macro;Monad<Meta> + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS)) + (do macro.Monad<Meta> [valueI (translate valueS) objectI (translate objectS)] - (case (dict;get unboxed primitives) - (#;Some primitive) + (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 + "boolean" #$.Boolean + "byte" #$.Byte + "short" #$.Short + "int" #$.Int + "long" #$.Long + "float" #$.Float + "double" #$.Double + "char" #$.Char _ (undefined))] - (wrap (|>. objectI - ($i;CHECKCAST class) - $i;DUP + (wrap (|>> objectI + ($i.CHECKCAST class) + $i.DUP valueI - ($i;unwrap primitive) - ($i;PUTFIELD class field (#$;Primitive primitive))))) + ($i.unwrap primitive) + ($i.PUTFIELD class field (#$.Primitive primitive))))) - #;None - (wrap (|>. objectI - ($i;CHECKCAST class) - $i;DUP + #.None + (wrap (|>> objectI + ($i.CHECKCAST class) + $i.DUP valueI - ($i;CHECKCAST unboxed) - ($i;PUTFIELD class field ($t;class unboxed (list))))))) + ($i.CHECKCAST unboxed) + ($i.PUTFIELD class field ($t.class unboxed (list))))))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (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)) + (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 "["))) + ($t.class name (list))) + (l.many (l.none-of "["))) )) (def: java-type - (l;Lexer $;Type) - (do p;Monad<Parser> + (l.Lexer $.Type) + (do p.Monad<Parser> [raw base-type - nesting (p;some (l;this "[]"))] - (wrap ($t;array (list;size nesting) raw)))) + nesting (p.some (l.this "[]"))] + (wrap ($t.array (list.size nesting) raw)))) (def: (translate-type argD) - (-> Text (Meta $;Type)) - (case (l;run argD java-type) - (#e;Error error) - (&;throw Invalid-Syntax-For-JVM-Type argD) + (-> Text (Meta $.Type)) + (case (l.run argD java-type) + (#e.Error error) + (&.throw Invalid-Syntax-For-JVM-Type argD) - (#e;Success type) + (#e.Success type) (macro/wrap type))) (def: (prepare-input inputT inputI) - (-> $;Type $;Inst $;Inst) + (-> $.Type $.Inst $.Inst) (case inputT - (#$;Primitive primitive) - (|>. inputI ($i;unwrap primitive)) + (#$.Primitive primitive) + (|>> inputI ($i.unwrap primitive)) - (#$;Generic generic) + (#$.Generic generic) (case generic - (^or (#$;Var _) (#$;Wildcard _)) - (|>. inputI ($i;CHECKCAST "java.lang.Object")) + (^or (#$.Var _) (#$.Wildcard _)) + (|>> inputI ($i.CHECKCAST "java.lang.Object")) - (#$;Class class-name _) - (|>. inputI ($i;CHECKCAST class-name))) + (#$.Class class-name _) + (|>> inputI ($i.CHECKCAST class-name))) _ - (|>. inputI ($i;CHECKCAST ($t;descriptor inputT))))) + (|>> inputI ($i.CHECKCAST ($t.descriptor inputT))))) (def: (translate-args translate argsS) - (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) - (Meta (List [$;Type $;Inst]))) + (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) + (Meta (List [$.Type $.Inst]))) (case argsS - #;Nil - (macro/wrap #;Nil) + #.Nil + (macro/wrap #.Nil) - (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail)) - (do macro;Monad<Meta> + (^ (list& [_ (#.Tuple (list [_ (#.Text argD)] argS))] tail)) + (do macro.Monad<Meta> [argT (translate-type argD) argI (:: @ map (prepare-input argT) (translate argS)) =tail (translate-args translate tail)] (wrap (list& [argT argI] =tail))) _ - (&;throw Invalid-Syntax-For-Argument-Generation ""))) + (&.throw Invalid-Syntax-For-Argument-Generation ""))) (def: (method-return-type description) - (-> Text (Meta (Maybe $;Type))) + (-> Text (Meta (Maybe $.Type))) (case description "void" - (macro/wrap #;None) + (macro/wrap #.None) _ - (macro/map (|>. #;Some) (translate-type description)))) + (macro/map (|>> #.Some) (translate-type description)))) (def: (prepare-return returnT returnI) - (-> (Maybe $;Type) $;Inst $;Inst) + (-> (Maybe $.Type) $.Inst $.Inst) (case returnT - #;None - (|>. returnI - ($i;string hostL;unit)) + #.None + (|>> returnI + ($i.string hostL.unit)) - (#;Some type) + (#.Some type) (case type - (#$;Primitive primitive) - (|>. returnI ($i;wrap primitive)) + (#$.Primitive primitive) + (|>> returnI ($i.wrap primitive)) _ returnI))) (def: (invoke//static proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list& [_ (#;Text class)] [_ (#;Text method)] - [_ (#;Text unboxed)] argsS)) - (do macro;Monad<Meta> + (^ (list& [_ (#.Text class)] [_ (#.Text method)] + [_ (#.Text unboxed)] argsS)) + (do macro.Monad<Meta> [argsTI (translate-args translate 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)) + #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))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (do-template [<name> <invoke> <interface?>] [(def: (<name> proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list& [_ (#;Text class)] [_ (#;Text method)] - [_ (#;Text unboxed)] objectS argsS)) - (do macro;Monad<Meta> + (^ (list& [_ (#.Text class)] [_ (#.Text method)] + [_ (#.Text unboxed)] objectS argsS)) + (do macro.Monad<Meta> [objectI (translate objectS) argsTI (translate-args translate argsS) returnT (method-return-type unboxed) - #let [callI (|>. objectI - ($i;CHECKCAST class) - ($i;fuse (list/map product;right argsTI)) + #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)) + ($t.method (list/map product.left argsTI) returnT (list)) <interface?>))]] (wrap (prepare-return returnT callI))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))] + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))] - [invoke//virtual $i;INVOKEVIRTUAL false] - [invoke//special $i;INVOKESPECIAL false] - [invoke//interface $i;INVOKEINTERFACE true] + [invoke//virtual $i.INVOKEVIRTUAL false] + [invoke//special $i.INVOKESPECIAL false] + [invoke//interface $i.INVOKEINTERFACE true] ) (def: (invoke//constructor proc translate inputs) - (-> Text @;Proc) + (-> Text @.Proc) (case inputs - (^ (list& [_ (#;Text class)] argsS)) - (do macro;Monad<Meta> + (^ (list& [_ (#.Text class)] argsS)) + (do macro.Monad<Meta> [argsTI (translate-args translate 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)) + (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)))) _ - (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) (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)))) + @.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) + @.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/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux index bfc838041..bfb5856d4 100644 --- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux @@ -1,17 +1,17 @@ -(;module: +(.module: lux (lux (control [monad #+ do]) (data [text "text/" Hash<Text>] text/format) [macro "macro/" Monad<Meta>]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$i" inst])) ["ls" synthesis] - [";L" variable #+ Variable] - (translation [";T" common])))) + [".L" variable #+ Variable] + (translation [".T" common])))) (do-template [<name> <prefix>] [(def: #export (<name> idx) @@ -23,27 +23,27 @@ ) (def: #export (translate-captured variable) - (-> Variable (Meta $;Inst)) - (do macro;Monad<Meta> - [this-module macro;current-module-name - function-class hostL;context - #let [function-class (format (text;replace-all "/" "." this-module) "." function-class)]] - (wrap (|>. ($i;ALOAD +0) - ($i;GETFIELD function-class - (|> variable i.inc (i.* -1) int-to-nat captured) - commonT;$Object))))) + (-> Variable (Meta $.Inst)) + (do macro.Monad<Meta> + [this-module macro.current-module-name + function-class hostL.context + #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)]] + (wrap (|>> ($i.ALOAD +0) + ($i.GETFIELD function-class + (|> variable i/inc (i/* -1) int-to-nat captured) + commonT.$Object))))) (def: #export (translate-local variable) - (-> Variable (Meta $;Inst)) - (macro/wrap ($i;ALOAD (int-to-nat variable)))) + (-> Variable (Meta $.Inst)) + (macro/wrap ($i.ALOAD (int-to-nat variable)))) (def: #export (translate-variable variable) - (-> Variable (Meta $;Inst)) - (if (variableL;captured? variable) + (-> Variable (Meta $.Inst)) + (if (variableL.captured? variable) (translate-captured variable) (translate-local variable))) (def: #export (translate-definition [def-module def-name]) - (-> Ident (Meta $;Inst)) - (let [bytecode-name (format def-module "/" (&;normalize-name def-name) (%n (text/hash def-name)))] - (macro/wrap ($i;GETSTATIC bytecode-name commonT;value-field commonT;$Object)))) + (-> Ident (Meta $.Inst)) + (let [bytecode-name (format def-module "/" (&.normalize-name def-name) (%n (text/hash def-name)))] + (macro/wrap ($i.GETSTATIC bytecode-name commonT.value-field commonT.$Object)))) diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux index d2bb1645b..aa210718b 100644 --- a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux @@ -1,371 +1,347 @@ -(;module: +(.module: lux (lux (control monad) (data text/format (coll [list "list/" Functor<List>])) [math] - [macro] - [host]) + [macro]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common])))) + (translation [".T" 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: $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")))) + $.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))) + $.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)) + $.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 + $.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 + $.Inst + (|>> ($i.int 1) + ($i.string "") + $i.DUP2_X1 + $i.POP2 variantI)) -(def: #export someI $;Inst rightI) +(def: #export someI $.Inst rightI) (def: #export noneI - $;Inst - (|>. ($i;int 0) - $i;NULL - ($i;string hostL;unit) + $.Inst + (|>> ($i.int 0) + $i.NULL + ($i.string hostL.unit) variantI)) (def: (try-methodI unsafeI) - (-> $;Inst $;Inst) - (<| $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) + (-> $.Inst $.Inst) + (<| $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) unsafeI someI - $i;ARETURN - ($i;label @to) - ($i;label @handler) + $i.ARETURN + ($i.label @to) + ($i.label @handler) noneI - $i;ARETURN))) + $i.ARETURN))) (def: #export string-concatI - $;Inst - ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)) + $.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))) + (-> 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 + $.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 + 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 + $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 + 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 + ($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) + 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) + (|>> ($i.int 3) + ($i.array $Object) store-tagI store-flagI store-valueI - $i;ARETURN))))) + $i.ARETURN))))) (def: #export force-textI - $;Inst - ($i;INVOKESTATIC hostL;runtime-class "force_text" ($t;method (list $Object) (#;Some $String) (list)) false)) + $.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)] - (|>. ($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 + $.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)] + (|>> ($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 + ($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) + (<| $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 + ($i.INVOKEVIRTUAL "java.math.BigInteger" "add" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false) + $i.ARETURN ## then - ($i;label @simple) - ($i;LLOAD +0) + ($i.label @simple) + ($i.LLOAD +0) upcastI - $i;ARETURN)))) - ($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))) - ($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) + $i.ARETURN)))) + ($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))) + ($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 + ($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) + ($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) + ($i.label @param-is-large) + ($i.LLOAD +0) ($i.LLOAD +2) (less-thanI @is-zero) ## Greater-than or equals - ($i;long 1) $i;LRETURN + ($i.long 1) $i.LRETURN ## Less than - ($i;label @is-zero) - ($i;long 0) $i;LRETURN)))) - ($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) + ($i.label @is-zero) + ($i.long 0) $i.LRETURN)))) + ($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.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.LLOAD +0) upcastI + ($i.LLOAD +2) upcastI + big-remainderI downcastI $i.LRETURN - ($i;label @subject-is-smaller-than-param) - ($i;LLOAD +0) - $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-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)) + $.Def + (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) (try-methodI - (|>. ($i;ALOAD +0) - ($i;INVOKESTATIC "java.lang.Double" "parseDouble" ($t;method (list $String) (#;Some $t;double) (list)) false) - ($i;wrap #$;Double)))) - ($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) + (|>> ($i.ALOAD +0) + ($i.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) false) + ($i.wrap #$.Double)))) + ($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 + $i.DUP2 ## Get lower half drop-excessI shiftI ## Turn it into a deg - $i;D2L + $i.D2L ## Turn the upper half into deg too swap2 - $i;D2L + $i.D2L ## Combine both pieces - $i;LADD + $i.LADD ## FINISH - $i;LRETURN + $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-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 + $.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 + 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) + (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 + ($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 + ($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 + $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 @@ -373,255 +349,255 @@ 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 + $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))) + $i.DADD + $i.DRETURN))) ))) (def: text-methods - $;Def - (|>. ($d;method #$;Public $;staticM "text_clip" ($t;method (list $String $t;int $t;int) (#;Some $Variant) (list)) + $.Def + (|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) (try-methodI - (|>. ($i;ALOAD +0) - ($i;ILOAD +1) - ($i;ILOAD +2) - ($i;INVOKEVIRTUAL "java.lang.String" "substring" ($t;method (list $t;int $t;int) (#;Some $String) (list)) false)))) - ($d;method #$;Public $;staticM "text_char" ($t;method (list $String $t;int) (#;Some $Variant) (list)) + (|>> ($i.ALOAD +0) + ($i.ILOAD +1) + ($i.ILOAD +2) + ($i.INVOKEVIRTUAL "java.lang.String" "substring" ($t.method (list $t.int $t.int) (#.Some $String) (list)) false)))) + ($d.method #$.Public $.staticM "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) (try-methodI - (|>. ($i;ALOAD +0) - ($i;ILOAD +1) - ($i;INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t;method (list $t;int) (#;Some $t;int) (list)) false) - $i;I2L - ($i;wrap #$;Long)))) + (|>> ($i.ALOAD +0) + ($i.ILOAD +1) + ($i.INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t.method (list $t.int) (#.Some $t.int) (list)) false) + $i.I2L + ($i.wrap #$.Long)))) )) (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) + $.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))) + (|>> ($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 + 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)) - failureI (|>. $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 + $i.ARETURN) + update-tagI (|>> $i.ISUB ($i.ISTORE +1)) + update-variantI (|>> ($i.ALOAD +0) datumI ($i.CHECKCAST ($t.descriptor $Variant)) ($i.ASTORE +0)) + failureI (|>> $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 failureI - ($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 + ($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 + ($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 + ($i.label @shorten) ## tag, sumT + ($i.ALOAD +2) ($i.IFNULL @wrong) + ## $i.POP2 shortenI - ($i;label @wrong) ## tag, sumT - ## $i;POP2 + ($i.label @wrong) ## tag, sumT + ## $i.POP2 failureI))) - ($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) + ($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) + $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 + 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) + $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) + $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) + tuple-tailI ($i.ASTORE +0) + updated-idxI ($i.ISTORE +1) + ($i.GOTO @begin) + ($i.label @slice) sliceI - $i;ARETURN - ($i;label @tail) - ## $i;POP2 + $i.ARETURN + ($i.label @tail) + ## $i.POP2 tuple-elemI - $i;ARETURN))) + $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) + $.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) + (|>> ($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) + $i.ARETURN + ($i.label @to) + ($i.label @handler) string-writerI ## TW - $i;DUP2 ## TWTW + $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))) + ($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: translate-runtime - (Meta commonT;Bytecode) - (do macro;Monad<Meta> + (Meta commonT.Bytecode) + (do macro.Monad<Meta> [_ (wrap []) - #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC hostL;runtime-class (list) ["java.lang.Object" (list)] (list) - (|>. adt-methods + #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 text-methods pm-methods io-methods))] - _ (commonT;store-class hostL;runtime-class bytecode)] + _ (commonT.store-class hostL.runtime-class bytecode)] (wrap bytecode))) (def: translate-function - (Meta commonT;Bytecode) - (do macro;Monad<Meta> + (Meta commonT.Bytecode) + (do macro.Monad<Meta> [_ (wrap []) - #let [applyI (|> (list;n.range +2 num-apply-variants) + #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)) + ($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))] - _ (commonT;store-class hostL;function-class bytecode)] + _ (commonT.store-class hostL.function-class bytecode)] (wrap bytecode))) (def: #export translate - (Meta [commonT;Bytecode commonT;Bytecode]) - (do macro;Monad<Meta> + (Meta [commonT.Bytecode commonT.Bytecode]) + (do macro.Monad<Meta> [runtime-bc translate-runtime function-bc translate-function] (wrap [runtime-bc function-bc]))) diff --git a/new-luxc/source/luxc/lang/translation/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/statement.jvm.lux index df7e26741..a734adfed 100644 --- a/new-luxc/source/luxc/lang/translation/statement.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/statement.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control monad ["ex" exception #+ exception:]) @@ -10,84 +10,81 @@ [macro] [host]) (luxc ["&" lang] - ["&;" io] + ["&." io] (lang (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) - ["&;" scope] - ["&;" module] - (translation [";T" eval] - [";T" common])))) + ["&." scope] + ["&." module] + (translation [".T" eval] + [".T" common])))) (exception: #export Invalid-Definition-Value) (exception: #export Cannot-Evaluate-Definition) -(host;import java.lang.Object - (toString [] String)) - -(host;import java.lang.reflect.Field +(host.import java/lang/reflect/Field (get [#? Object] #try #? Object)) -(host;import (java.lang.Class c) +(host.import (java/lang/Class c) (getField [String] #try Field)) (def: #export (translate-def def-name valueT valueI metaI metaV) - (-> Text Type $;Inst $;Inst Code (Meta Unit)) - (do macro;Monad<Meta> - [current-module macro;current-module-name + (-> Text Type $.Inst $.Inst Code (Meta Unit)) + (do macro.Monad<Meta> + [current-module macro.current-module-name #let [def-ident [current-module def-name]]] - (case (macro;get-symbol-ann (ident-for #;alias) metaV) - (#;Some real-def) + (case (macro.get-symbol-ann (ident-for #.alias) metaV) + (#.Some real-def) (do @ - [[realT realA realV] (macro;find-def real-def) - _ (&module;define def-ident [realT metaV realV])] + [[realT realA realV] (macro.find-def real-def) + _ (&module.define def-ident [realT metaV realV])] (wrap [])) _ (do @ - [#let [normal-name (format (&;normalize-name def-name) (%n (text/hash def-name))) + [#let [normal-name (format (&.normalize-name def-name) (%n (text/hash def-name))) bytecode-name (format current-module "/" normal-name) - class-name (format (text;replace-all "/" "." current-module) "." normal-name) - bytecode ($d;class #$;V1.6 - #$;Public $;finalC + class-name (format (text.replace-all "/" "." 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) commonT;value-field commonT;$Object) - ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list)) - (|>. valueI - ($i;PUTSTATIC bytecode-name commonT;value-field commonT;$Object) - $i;RETURN))))] - _ (commonT;store-class class-name bytecode) - class (commonT;load-class class-name) + (|>> ($d.field #$.Public ($.++F $.finalF $.staticF) commonT.value-field commonT.$Object) + ($d.method #$.Public $.staticM "<clinit>" ($t.method (list) #.None (list)) + (|>> valueI + ($i.PUTSTATIC bytecode-name commonT.value-field commonT.$Object) + $i.RETURN))))] + _ (commonT.store-class class-name bytecode) + class (commonT.load-class class-name) valueV (: (Meta Top) - (case (do e;Monad<Error> - [field (Class.getField [commonT;value-field] class)] - (Field.get [#;None] field)) - (#e;Success #;None) - (&;throw Invalid-Definition-Value (%ident def-ident)) + (case (do e.Monad<Error> + [field (Class::getField [commonT.value-field] class)] + (Field::get [#.None] field)) + (#e.Success #.None) + (&.throw Invalid-Definition-Value (%ident def-ident)) - (#e;Success (#;Some valueV)) + (#e.Success (#.Some valueV)) (wrap valueV) - (#e;Error error) - (&;throw Cannot-Evaluate-Definition + (#e.Error error) + (&.throw Cannot-Evaluate-Definition (format "Definition: " (%ident def-ident) "\n" "Error:\n" error)))) - _ (&module;define def-ident [valueT metaV valueV]) - _ (if (macro;type? metaV) - (case (macro;declared-tags metaV) - #;Nil + _ (&module.define def-ident [valueT metaV valueV]) + _ (if (macro.type? metaV) + (case (macro.declared-tags metaV) + #.Nil (wrap []) tags - (&module;declare-tags tags (macro;export? metaV) (:! Type valueV))) + (&module.declare-tags tags (macro.export? metaV) (:! Type valueV))) (wrap [])) #let [_ (log! (format "DEF " (%ident def-ident)))]] - (commonT;record-artifact (format bytecode-name ".class") bytecode))))) + (commonT.record-artifact (format bytecode-name ".class") bytecode))))) (def: #export (translate-program program-args programI) - (-> Text $;Inst (Meta Unit)) - (&;fail "\"lux program\" is unimplemented.")) + (-> Text $.Inst (Meta Unit)) + (&.fail "\"lux program\" is unimplemented.")) diff --git a/new-luxc/source/luxc/lang/translation/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/structure.jvm.lux index ddb48a31e..9a78be78e 100644 --- a/new-luxc/source/luxc/lang/translation/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/structure.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -7,55 +7,55 @@ [macro] [host #+ do-to]) (luxc ["&" lang] - (lang [";L" host] + (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])) ["la" analysis] ["ls" synthesis] - (translation [";T" common])))) + (translation [".T" common])))) (exception: #export Not-A-Tuple) -(def: $Object $;Type ($t;class "java.lang.Object" (list))) +(def: $Object $.Type ($t.class "java.lang.Object" (list))) (def: #export (translate-tuple translate members) - (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst)) - (do macro;Monad<Meta> - [#let [size (list;size members)] - _ (&;assert Not-A-Tuple (%code (` [(~@ members)])) - (n.>= +2 size)) + (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) (Meta $.Inst)) + (do macro.Monad<Meta> + [#let [size (list.size members)] + _ (&.assert Not-A-Tuple (%code (` [(~@ members)])) + (n/>= +2 size)) membersI (|> members - list;enumerate - (monad;map @ (function [[idx member]] + list.enumerate + (monad.map @ (function [[idx member]] (do @ [memberI (translate member)] - (wrap (|>. $i;DUP - ($i;int (nat-to-int idx)) + (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) + $i.AASTORE))))) + (:: @ map $i.fuse))] + (wrap (|>> ($i.int (nat-to-int size)) + ($i.array $Object) membersI)))) (def: (flagI tail?) - (-> Bool $;Inst) + (-> Bool $.Inst) (if tail? - ($i;string "") - $i;NULL)) + ($i.string "") + $i.NULL)) (def: #export (translate-variant translate tag tail? member) - (-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst)) - (do macro;Monad<Meta> + (-> (-> ls.Synthesis (Meta $.Inst)) Nat Bool ls.Synthesis (Meta $.Inst)) + (do macro.Monad<Meta> [memberI (translate member)] - (wrap (|>. ($i;int (nat-to-int tag)) + (wrap (|>> ($i.int (nat-to-int tag)) (flagI tail?) memberI - ($i;INVOKESTATIC hostL;runtime-class + ($i.INVOKESTATIC hostL.runtime-class "variant_make" - ($t;method (list $t;int $Object $Object) - (#;Some ($t;array +1 $Object)) + ($t.method (list $t.int $Object $Object) + (#.Some ($t.array +1 $Object)) (list)) false))))) |