From 012f6bd41e527479dddbccbdab10daa78fd9a0fd Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 1 Nov 2017 00:51:45 -0400 Subject: - Re-organized code-generation, and re-named it "translation". --- new-luxc/source/luxc/eval.lux | 12 +- new-luxc/source/luxc/generator.lux | 179 ----- new-luxc/source/luxc/generator/case.jvm.lux | 225 ------ new-luxc/source/luxc/generator/common.jvm.lux | 131 ---- new-luxc/source/luxc/generator/eval.jvm.lux | 81 --- new-luxc/source/luxc/generator/expression.jvm.lux | 76 -- new-luxc/source/luxc/generator/function.jvm.lux | 333 --------- new-luxc/source/luxc/generator/primitive.jvm.lux | 36 - new-luxc/source/luxc/generator/procedure.jvm.lux | 24 - .../source/luxc/generator/procedure/common.jvm.lux | 708 ------------------- .../source/luxc/generator/procedure/host.jvm.lux | 763 --------------------- new-luxc/source/luxc/generator/reference.jvm.lux | 31 - new-luxc/source/luxc/generator/runtime.jvm.lux | 608 ---------------- new-luxc/source/luxc/generator/statement.jvm.lux | 82 --- new-luxc/source/luxc/generator/structure.jvm.lux | 59 -- new-luxc/source/luxc/host.jvm.lux | 25 +- new-luxc/source/luxc/lang/analysis/expression.lux | 8 +- new-luxc/source/luxc/lang/translation.lux | 179 +++++ new-luxc/source/luxc/lang/translation/case.jvm.lux | 225 ++++++ .../source/luxc/lang/translation/common.jvm.lux | 131 ++++ new-luxc/source/luxc/lang/translation/eval.jvm.lux | 80 +++ .../luxc/lang/translation/expression.jvm.lux | 76 ++ .../source/luxc/lang/translation/function.jvm.lux | 333 +++++++++ .../source/luxc/lang/translation/primitive.jvm.lux | 36 + .../source/luxc/lang/translation/procedure.jvm.lux | 24 + .../luxc/lang/translation/procedure/common.jvm.lux | 707 +++++++++++++++++++ .../luxc/lang/translation/procedure/host.jvm.lux | 761 ++++++++++++++++++++ .../source/luxc/lang/translation/reference.jvm.lux | 31 + .../source/luxc/lang/translation/runtime.jvm.lux | 608 ++++++++++++++++ .../source/luxc/lang/translation/statement.jvm.lux | 82 +++ .../source/luxc/lang/translation/structure.jvm.lux | 59 ++ new-luxc/source/program.lux | 4 +- new-luxc/test/test/luxc/common.lux | 4 +- new-luxc/test/test/luxc/generator/case.lux | 101 --- new-luxc/test/test/luxc/generator/function.lux | 99 --- new-luxc/test/test/luxc/generator/primitive.lux | 62 -- .../test/luxc/generator/procedure/common.jvm.lux | 367 ---------- .../test/luxc/generator/procedure/host.jvm.lux | 614 ----------------- new-luxc/test/test/luxc/generator/reference.lux | 80 --- new-luxc/test/test/luxc/generator/structure.lux | 110 --- .../test/luxc/lang/analysis/procedure/host.jvm.lux | 4 +- new-luxc/test/test/luxc/lang/analysis/type.lux | 4 +- new-luxc/test/test/luxc/lang/translation/case.lux | 101 +++ .../test/test/luxc/lang/translation/function.lux | 99 +++ .../test/test/luxc/lang/translation/primitive.lux | 62 ++ .../luxc/lang/translation/procedure/common.jvm.lux | 367 ++++++++++ .../luxc/lang/translation/procedure/host.jvm.lux | 614 +++++++++++++++++ .../test/test/luxc/lang/translation/reference.lux | 80 +++ .../test/test/luxc/lang/translation/structure.lux | 110 +++ new-luxc/test/tests.lux | 16 +- 50 files changed, 4804 insertions(+), 4807 deletions(-) delete mode 100644 new-luxc/source/luxc/generator.lux delete mode 100644 new-luxc/source/luxc/generator/case.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/common.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/eval.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/expression.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/function.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/primitive.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/procedure.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/procedure/common.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/procedure/host.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/reference.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/runtime.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/statement.jvm.lux delete mode 100644 new-luxc/source/luxc/generator/structure.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation.lux create mode 100644 new-luxc/source/luxc/lang/translation/case.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/common.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/eval.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/expression.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/function.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/primitive.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/procedure.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/reference.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/runtime.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/statement.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/structure.jvm.lux delete mode 100644 new-luxc/test/test/luxc/generator/case.lux delete mode 100644 new-luxc/test/test/luxc/generator/function.lux delete mode 100644 new-luxc/test/test/luxc/generator/primitive.lux delete mode 100644 new-luxc/test/test/luxc/generator/procedure/common.jvm.lux delete mode 100644 new-luxc/test/test/luxc/generator/procedure/host.jvm.lux delete mode 100644 new-luxc/test/test/luxc/generator/reference.lux delete mode 100644 new-luxc/test/test/luxc/generator/structure.lux create mode 100644 new-luxc/test/test/luxc/lang/translation/case.lux create mode 100644 new-luxc/test/test/luxc/lang/translation/function.lux create mode 100644 new-luxc/test/test/luxc/lang/translation/primitive.lux create mode 100644 new-luxc/test/test/luxc/lang/translation/procedure/common.jvm.lux create mode 100644 new-luxc/test/test/luxc/lang/translation/procedure/host.jvm.lux create mode 100644 new-luxc/test/test/luxc/lang/translation/reference.lux create mode 100644 new-luxc/test/test/luxc/lang/translation/structure.lux diff --git a/new-luxc/source/luxc/eval.lux b/new-luxc/source/luxc/eval.lux index baac56c64..82c355151 100644 --- a/new-luxc/source/luxc/eval.lux +++ b/new-luxc/source/luxc/eval.lux @@ -3,10 +3,10 @@ (lux (control [monad #+ do]) [meta]) (luxc (lang (analysis [";A" expression]) - (synthesis [";S" expression]))) - [../base] - (.. (generator [";G" expression] - [eval]))) + (synthesis [";S" expression]) + (translation [";T" expression] + [";T" eval]))) + [../base]) (def: #export (eval type exprC) ../base;Eval @@ -14,5 +14,5 @@ [exprA (../base;with-expected-type type (expressionA;analyser eval exprC)) #let [exprS (expressionS;synthesize exprA)] - exprI (expressionG;generate exprS)] - (eval;eval exprI))) + exprI (expressionT;generate exprS)] + (evalT;eval exprI))) diff --git a/new-luxc/source/luxc/generator.lux b/new-luxc/source/luxc/generator.lux deleted file mode 100644 index e9b6c4d3f..000000000 --- a/new-luxc/source/luxc/generator.lux +++ /dev/null @@ -1,179 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (concurrency ["T" task]) - (data ["e" error] - [text "text/" Hash] - text/format - (coll [dict])) - [meta] - [host] - [io] - (world [file #+ File])) - (luxc ["&" base] - [";L" host] - ["&;" io] - ["&;" module] - ["&;" eval] - (lang ["&;" syntax] - (analysis [";A" expression] - [";A" common]) - (synthesis [";S" expression])) - (generator ["&&;" runtime] - ["&&;" statement] - ["&&;" common] - [";G" expression] - ["&&;" eval]) - )) - -(def: analyse - (&;Analyser) - (expressionA;analyser &eval;eval)) - -(def: (generate code) - (-> Code (Meta Unit)) - (case code - (^ [_ (#;Form (list [_ (#;Text "lux def")] - [_ (#;Symbol ["" def-name])] - valueC - metaC))]) - (do meta;Monad - [[_ metaA] (&;with-scope - (&;with-expected-type Code - (analyse metaC))) - metaI (expressionG;generate (expressionS;synthesize metaA)) - metaV (&&eval;eval metaI) - [_ valueT valueA] (&;with-scope - (if (meta;type? (:! Code metaV)) - (&;with-expected-type Type - (do @ - [valueA (analyse valueC)] - (wrap [Type valueA]))) - (commonA;with-unknown-type - (analyse valueC)))) - valueI (expressionG;generate (expressionS;synthesize valueA)) - _ (&;with-scope - (&&statement;generate-def def-name valueT valueI metaI (:! Code metaV)))] - (wrap [])) - - (^ [_ (#;Form (list [_ (#;Text "lux program")] - [_ (#;Symbol ["" program-args])] - programC))]) - (do meta;Monad - [[_ programA] (&;with-scope - (&;with-expected-type (type (io;IO Unit)) - (analyse programC))) - programI (expressionG;generate (expressionS;synthesize programA))] - (&&statement;generate-program program-args programI)) - - _ - (&;fail (format "Unrecognized statement: " (%code code))))) - -(def: (exhaust action) - (All [a] (-> (Meta a) (Meta Unit))) - (do meta;Monad - [result action] - (exhaust action))) - -(def: prelude Text "lux") - -(def: (with-active-compilation [module-name file-name source-code] action) - (All [a] (-> [Text Text Text] (Meta a) (Meta a))) - (do meta;Monad - [#let [init-cursor [file-name +1 +0]] - output (&;with-source-code [init-cursor +0 source-code] - action) - _ (&module;flag-compiled! module-name)] - (wrap output))) - -(def: parse - (Meta Code) - (function [compiler] - (case (&syntax;parse (get@ #;source compiler)) - (#e;Error error) - (#e;Error error) - - (#e;Success [source' output]) - (#e;Success [(set@ #;source source' compiler) - output])))) - -(def: (generate-module source-dirs module-name target-dir compiler) - (-> (List File) Text File Compiler (T;Task Compiler)) - (do T;Monad - [_ (&io;prepare-module target-dir module-name) - [file-name file-content] (&io;read-module source-dirs module-name) - #let [module-hash (text/hash file-content)]] - (case (meta;run' compiler - (do meta;Monad - [[_ artifacts _] (&module;with-module module-hash module-name - (&&common;with-artifacts - (with-active-compilation [module-name - file-name - file-content] - (exhaust - (do @ - [code parse - #let [[cursor _] code]] - (&;with-cursor cursor - (generate code)))))))] - (wrap artifacts) - ## (&module;generate-descriptor module-name) - )) - (#e;Success [compiler artifacts ## module-descriptor - ]) - (do @ - [## _ (&io;write-module module-name module-descriptor) - _ (monad;map @ (function [[class-name class-bytecode]] - (&io;write-file target-dir class-name class-bytecode)) - (dict;entries artifacts))] - (wrap compiler)) - - (#e;Error error) - (T;fail error)))) - -(def: init-cursor Cursor ["" +1 +0]) - -(def: #export init-type-context - Type-Context - {#;ex-counter +0 - #;var-counter +0 - #;var-bindings (list)}) - -(def: #export init-info - Info - {#;target "JVM" - #;version &;version - #;mode #;Build}) - -(def: #export (init-compiler host) - (-> &&common;Host Compiler) - {#;info init-info - #;source [init-cursor +0 ""] - #;cursor init-cursor - #;current-module #;None - #;modules (list) - #;scopes (list) - #;type-context init-type-context - #;expected #;None - #;seed +0 - #;scope-type-vars (list) - #;host (:! Void host)}) - -(def: #export (generate-program program target sources) - (-> Text File (List File) (T;Task Unit)) - (do T;Monad - [compiler (|> (case (&&runtime;generate (init-compiler (io;run hostL;init-host))) - (#e;Error error) - (T;fail error) - - (#e;Success [compiler [runtime-bc function-bc]]) - (do @ - [_ (&io;prepare-target target) - _ (&io;write-file target hostL;runtime-class runtime-bc) - _ (&io;write-file target hostL;function-class function-bc)] - (wrap compiler))) - (: (T;Task Compiler)) - (:: @ map (generate-module sources prelude target)) (:: @ join) - (:: @ map (generate-module sources program target)) (:: @ join)) - #let [_ (log! "Compilation complete!")]] - (wrap []))) diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux deleted file mode 100644 index a9ea4482a..000000000 --- a/new-luxc/source/luxc/generator/case.jvm.lux +++ /dev/null @@ -1,225 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data text/format) - [meta "meta/" Monad]) - (luxc ["_" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$i" inst])) - (lang ["ls" synthesis])) - [../runtime]) - -(def: $Object $;Type ($t;class "java.lang.Object" (list))) - -(def: (pop-altI stack-depth) - (-> Nat $;Inst) - (case stack-depth - +0 id - +1 $i;POP - +2 $i;POP2 - _ ## (n.> +2) - (|>. $i;POP2 - (pop-altI (n.- +2 stack-depth))))) - -(def: peekI - $;Inst - (|>. $i;DUP - ($i;INVOKESTATIC hostL;runtime-class - "pm_peek" - ($t;method (list ../runtime;$Stack) - (#;Some $Object) - (list)) - false))) - -(def: popI - $;Inst - (|>. ($i;INVOKESTATIC hostL;runtime-class - "pm_pop" - ($t;method (list ../runtime;$Stack) - (#;Some ../runtime;$Stack) - (list)) - false))) - -(def: pushI - $;Inst - (|>. ($i;INVOKESTATIC hostL;runtime-class - "pm_push" - ($t;method (list ../runtime;$Stack $Object) - (#;Some ../runtime;$Stack) - (list)) - false))) - -(exception: #export Unrecognized-Path) - -(def: (generate-path' generate stack-depth @else @end path) - (-> (-> ls;Synthesis (Meta $;Inst)) - Nat $;Label $;Label ls;Path (Meta $;Inst)) - (case path - (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) - (do meta;Monad - [bodyI (generate bodyS)] - (wrap (|>. (pop-altI stack-depth) - bodyI - ($i;GOTO @end)))) - - (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))]) - (meta/wrap popI) - - (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))]) - (meta/wrap (|>. peekI - ($i;ASTORE register) - popI)) - - [_ (#;Bool value)] - (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)] - (|>. peekI - ($i;unwrap #$;Boolean) - (jumpI @else)))) - - (^template [ ] - [_ ( value)] - (meta/wrap (|>. peekI - ($i;unwrap #$;Long) - ($i;long (|> value )) - $i;LCMP - ($i;IFNE @else)))) - ([#;Nat (:! Int)] - [#;Int (: Int)] - [#;Deg (:! Int)]) - - [_ (#;Frac value)] - (meta/wrap (|>. peekI - ($i;unwrap #$;Double) - ($i;double value) - $i;DCMPL - ($i;IFNE @else))) - - [_ (#;Text value)] - (meta/wrap (|>. peekI - ($i;string value) - ($i;INVOKEVIRTUAL "java.lang.Object" - "equals" - ($t;method (list $Object) - (#;Some $t;boolean) - (list)) - false) - ($i;IFEQ @else))) - - (^template [ ] - (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))]) - (do meta;Monad - [subI (generate-path' generate stack-depth @else @end subP)] - (wrap (case idx - +0 - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) - ($i;int 0) - $i;AALOAD - pushI - subI) - - _ - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) - ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC hostL;runtime-class - - ($t;method (list ../runtime;$Tuple $t;int) - (#;Some $Object) - (list)) - false) - pushI - subI))))) - (["lux case tuple left" "pm_left"] - ["lux case tuple right" "pm_right"]) - - (^template [ ] - (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))]) - (do meta;Monad - [subI (generate-path' generate stack-depth @else @end subP)] - (wrap (<| $i;with-label (function [@success]) - $i;with-label (function [@fail]) - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) - ($i;int (nat-to-int idx)) - - ($i;INVOKESTATIC hostL;runtime-class "pm_variant" - ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) - (#;Some ../runtime;$Datum) - (list)) - false) - $i;DUP - ($i;IFNULL @fail) - ($i;GOTO @success) - ($i;label @fail) - $i;POP - ($i;GOTO @else) - ($i;label @success) - pushI - subI))))) - (["lux case variant left" $i;NULL] - ["lux case variant right" ($i;string "")]) - - (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))]) - (do meta;Monad - [leftI (generate-path' generate stack-depth @else @end leftP) - rightI (generate-path' generate stack-depth @else @end rightP)] - (wrap (|>. leftI - rightI))) - - (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))]) - (do meta;Monad - [@alt-else $i;make-label - leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP) - rightI (generate-path' generate stack-depth @else @end rightP)] - (wrap (|>. $i;DUP - leftI - ($i;label @alt-else) - $i;POP - rightI))) - - _ - (_;throw Unrecognized-Path (%code path)))) - -(def: (generate-path generate path @end) - (-> (-> ls;Synthesis (Meta $;Inst)) - ls;Path $;Label (Meta $;Inst)) - (do meta;Monad - [@else $i;make-label - pathI (generate-path' generate +1 @else @end path)] - (wrap (|>. pathI - ($i;label @else) - $i;POP - ($i;INVOKESTATIC hostL;runtime-class - "pm_fail" - ($t;method (list) #;None (list)) - false) - $i;NULL - ($i;GOTO @end))))) - -(def: #export (generate-case generate valueS path) - (-> (-> ls;Synthesis (Meta $;Inst)) - ls;Synthesis ls;Path (Meta $;Inst)) - (do meta;Monad - [@end $i;make-label - valueI (generate valueS) - pathI (generate-path generate path @end)] - (wrap (|>. valueI - $i;NULL - $i;SWAP - pushI - pathI - ($i;label @end))))) - -(def: #export (generate-let generate register inputS exprS) - (-> (-> ls;Synthesis (Meta $;Inst)) - Nat ls;Synthesis ls;Synthesis (Meta $;Inst)) - (do meta;Monad - [inputI (generate inputS) - exprI (generate exprS)] - (wrap (|>. inputI - ($i;ASTORE register) - exprI)))) diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux deleted file mode 100644 index 1870530c2..000000000 --- a/new-luxc/source/luxc/generator/common.jvm.lux +++ /dev/null @@ -1,131 +0,0 @@ -(;module: - [lux #- function] - (lux (control ["ex" exception #+ exception:]) - [io] - (concurrency ["A" atom]) - (data ["e" error] - [text] - text/format - (coll [dict #+ Dict])) - [host] - (world [blob #+ Blob])) - (luxc (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])))) - -(host;import org.objectweb.asm.Opcodes - (#static V1_6 int)) - -(host;import java.lang.Object) - -(host;import (java.lang.Class a)) - -(host;import java.lang.ClassLoader - (loadClass [String] (Class Object))) - -(type: #export Bytecode (host;type (Array byte))) - -(type: #export Class-Store (A;Atom (Dict Text Bytecode))) - -(type: #export Artifacts (Dict Text Blob)) - -(type: #export Host - {#loader ClassLoader - #store Class-Store - #function-class (Maybe Text) - #artifacts Artifacts}) - -(exception: Unknown-Class) -(exception: Class-Already-Stored) -(exception: No-Function-Being-Compiled) -(exception: Cannot-Overwrite-Artifact) - -(def: #export (with-artifacts action) - (All [a] (-> (Meta a) (Meta [Artifacts a]))) - (;function [compiler] - (case (action (update@ #;host - (|>. (:! Host) - (set@ #artifacts (dict;new text;Hash)) - (:! Void)) - compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! Host) - (set@ #artifacts (|> (get@ #;host compiler) (:! Host) (get@ #artifacts))) - (:! Void)) - compiler') - [(|> compiler' (get@ #;host) (:! Host) (get@ #artifacts)) - output]]) - - (#e;Error error) - (#e;Error error)))) - -(def: #export (record-artifact name content) - (-> Text Blob (Meta Unit)) - (;function [compiler] - (if (|> compiler (get@ #;host) (:! Host) (get@ #artifacts) (dict;contains? name)) - (ex;throw Cannot-Overwrite-Artifact name) - (#e;Success [(update@ #;host - (|>. (:! Host) - (update@ #artifacts (dict;put name content)) - (:! Void)) - compiler) - []])))) - -(def: #export (store-class name byte-code) - (-> Text Bytecode (Meta Unit)) - (;function [compiler] - (let [store (|> (get@ #;host compiler) - (:! Host) - (get@ #store))] - (if (dict;contains? name (|> store A;get io;run)) - (ex;throw Class-Already-Stored name) - (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))]) - )))) - -(def: #export (load-class name) - (-> Text (Meta (Class Object))) - (;function [compiler] - (let [host (:! Host (get@ #;host compiler)) - store (|> host (get@ #store) A;get io;run)] - (if (dict;contains? name store) - (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))]) - (ex;throw Unknown-Class name))))) - -(def: #export (with-function class expr) - (All [a] (-> Text (Meta a) (Meta a))) - (;function [compiler] - (let [host (:! Host (get@ #;host compiler)) - old-function-class (get@ #function-class host)] - (case (expr (set@ #;host - (:! Void (set@ #function-class - (#;Some class) - host)) - compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! Host) - (set@ #function-class old-function-class) - (:! Void)) - compiler') - output]) - - (#e;Error error) - (#e;Error error))))) - -(def: #export function - (Meta Text) - (;function [compiler] - (let [host (:! Host (get@ #;host compiler))] - (case (get@ #function-class host) - #;None - (ex;throw No-Function-Being-Compiled "") - - (#;Some function-class) - (#e;Success [compiler function-class]))))) - -(def: #export bytecode-version Int Opcodes.V1_6) - -(def: #export value-field Text "_value") -(def: #export $Object $;Type ($t;class "java.lang.Object" (list))) diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux deleted file mode 100644 index 2f0ce1c24..000000000 --- a/new-luxc/source/luxc/generator/eval.jvm.lux +++ /dev/null @@ -1,81 +0,0 @@ -(;module: - lux - (lux (control monad) - (data ["R" error] - text/format) - [meta #+ Monad "Meta/" Monad] - [host #+ do-to]) - (luxc ["&" base] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] - ["ls" synthesis]) - (generator ["&;" common]) - )) - -(host;import java.lang.Object) -(host;import java.lang.String) - -(host;import java.lang.reflect.Field - (get [Object] Object)) - -(host;import (java.lang.Class a) - (getField [String] Field)) - -(host;import org.objectweb.asm.Opcodes - (#static ACC_PUBLIC int) - (#static ACC_SUPER int) - (#static ACC_FINAL int) - (#static ACC_STATIC int) - (#static PUTSTATIC int) - (#static RETURN int) - (#static V1_6 int) - ) - -(host;import org.objectweb.asm.MethodVisitor - (visitCode [] void) - (visitEnd [] void) - (visitLdcInsn [Object] void) - (visitFieldInsn [int String String String] void) - (visitInsn [int] void) - (visitMaxs [int int] void)) - -(host;import org.objectweb.asm.FieldVisitor - (visitEnd [] void)) - -(host;import org.objectweb.asm.ClassWriter - (#static COMPUTE_MAXS int) - (new [int]) - (visit [int int String String String (Array String)] void) - (visitEnd [] void) - (visitField [int String String String Object] FieldVisitor) - (visitMethod [int String String String (Array String)] MethodVisitor) - (toByteArray [] (Array byte))) - -(def: #export (eval valueI) - (-> $;Inst (Meta Top)) - (do Monad - [class-name (:: @ map %code (meta;gensym "eval")) - #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) - (ClassWriter.visit [&common;bytecode-version - (i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_SUPER) - class-name - (host;null) - "java/lang/Object" - (host;null)])) - ($d;field #$;Public ($_ $;++F $;finalF $;staticF) - &common;value-field &common;$Object) - ($d;method #$;Public ($_ $;++M $;staticM $;strictM) - "" - ($t;method (list) #;None (list)) - (|>. valueI - ($i;PUTSTATIC class-name &common;value-field &common;$Object) - $i;RETURN))) - bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))] - _ (&common;store-class class-name bytecode) - class (&common;load-class class-name)] - (wrap (|> class - (Class.getField [&common;value-field]) - (Field.get (host;null)))))) diff --git a/new-luxc/source/luxc/generator/expression.jvm.lux b/new-luxc/source/luxc/generator/expression.jvm.lux deleted file mode 100644 index 798998510..000000000 --- a/new-luxc/source/luxc/generator/expression.jvm.lux +++ /dev/null @@ -1,76 +0,0 @@ -(;module: - lux - (lux (control monad - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - text/format) - [meta] - (meta ["s" syntax])) - (luxc ["&" base] - (host ["$" jvm]) - (lang ["ls" synthesis] - [";L" variable #+ Variable Register]) - (generator ["&;" common] - ["&;" primitive] - ["&;" structure] - ["&;" eval] - ["&;" procedure] - ["&;" function] - ["&;" reference] - [";G" case]))) - -(exception: #export Unrecognized-Synthesis) - -(def: #export (generate synthesis) - (-> ls;Synthesis (Meta $;Inst)) - (case synthesis - (^code []) - &primitive;generate-unit - - (^code [(~ singleton)]) - (generate singleton) - - (^template [ ] - [_ ( value)] - ( value)) - ([#;Bool &primitive;generate-bool] - [#;Nat &primitive;generate-nat] - [#;Int &primitive;generate-int] - [#;Deg &primitive;generate-deg] - [#;Frac &primitive;generate-frac] - [#;Text &primitive;generate-text]) - - (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Bool last?)]) (~ valueS))) - (&structure;generate-variant generate tag last? valueS) - - (^code [(~@ members)]) - (&structure;generate-tuple generate members) - - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (if (variableL;captured? var) - (&reference;generate-captured var) - (&reference;generate-variable var)) - - [_ (#;Symbol definition)] - (&reference;generate-definition definition) - - (^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ exprS))) - (caseG;generate-let generate register inputS exprS) - - (^code ("lux case" (~ inputS) (~ pathPS))) - (caseG;generate-case generate inputS pathPS) - - (^multi (^code ("lux function" (~ [_ (#;Nat arity)]) [(~@ environment)] (~ bodyS))) - [(s;run environment (p;some s;int)) (#e;Success environment)]) - (&function;generate-function generate environment arity bodyS) - - (^code ("lux call" (~ functionS) (~@ argsS))) - (&function;generate-call generate functionS argsS) - - (^code ((~ [_ (#;Text procedure)]) (~@ argsS))) - (&procedure;generate-procedure generate procedure argsS) - - _ - (&;throw Unrecognized-Synthesis (%code synthesis)) - )) diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux deleted file mode 100644 index 310f4d7a0..000000000 --- a/new-luxc/source/luxc/generator/function.jvm.lux +++ /dev/null @@ -1,333 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (data text/format - (coll [list "list/" Functor Monoid])) - [meta]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] - ["ls" synthesis] - [";L" variable #+ Variable]) - (generator ["&;" common] - ["&;" runtime]))) - - -(def: arity-field Text "arity") -(def: $Object $;Type ($t;class "java.lang.Object" (list))) - -(do-template [ ] - [(def: #export ( idx) - (-> Nat Text) - (|> idx nat-to-int %i (format )))] - - [captured "c"] - [partial "p"] - ) - -(def: (poly-arg? arity) - (-> ls;Arity Bool) - (n.> +1 arity)) - -(def: (reset-method class) - (-> Text $;Method) - ($t;method (list) (#;Some ($t;class class (list))) (list))) - -(def: (captured-args env) - (-> (List Variable) (List $;Type)) - (list;repeat (list;size env) $Object)) - -(def: (init-method env arity) - (-> (List Variable) ls;Arity $;Method) - (if (poly-arg? arity) - ($t;method (list;concat (list (captured-args env) - (list $t;int) - (list;repeat (n.dec arity) $Object))) - #;None - (list)) - ($t;method (captured-args env) #;None (list)))) - -(def: (implementation-method arity) - ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) - -(def: get-amount-of-partialsI - $;Inst - (|>. ($i;ALOAD +0) - ($i;GETFIELD hostL;function-class &runtime;partials-field $t;int))) - -(def: (load-fieldI class field) - (-> Text Text $;Inst) - (|>. ($i;ALOAD +0) - ($i;GETFIELD class field $Object))) - -(def: (inputsI start amount) - (-> $;Register Nat $;Inst) - (|> (list;n.range start (n.+ start (n.dec amount))) - (list/map $i;ALOAD) - $i;fuse)) - -(def: (applysI start amount) - (-> $;Register Nat $;Inst) - (let [max-args (n.min amount &runtime;num-apply-variants) - later-applysI (if (n.> &runtime;num-apply-variants amount) - (applysI (n.+ &runtime;num-apply-variants start) (n.- &runtime;num-apply-variants amount)) - id)] - (|>. ($i;CHECKCAST hostL;function-class) - (inputsI start max-args) - ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature max-args) false) - later-applysI))) - -(def: (inc-intI by) - (-> Nat $;Inst) - (|>. ($i;int (nat-to-int by)) - $i;IADD)) - -(def: (nullsI amount) - (-> Nat $;Inst) - (|> $i;NULL - (list;repeat amount) - $i;fuse)) - -(def: (with-captured env) - (-> (List Variable) $;Def) - (|> (list;enumerate env) - (list/map (function [[env-idx env-source]] - ($d;field #$;Private $;finalF (captured env-idx) $Object))) - $d;fuse)) - -(def: (with-partial arity) - (-> ls;Arity $;Def) - (if (poly-arg? arity) - (|> (list;n.range +0 (n.- +2 arity)) - (list/map (function [idx] - ($d;field #$;Private $;finalF (partial idx) $Object))) - $d;fuse) - id)) - -(def: (instance class arity env) - (-> Text ls;Arity (List Variable) $;Inst) - (let [captureI (|> env - (list/map (function [source] - (if (variableL;captured? source) - ($i;GETFIELD class (captured (variableL;captured-register source)) $Object) - ($i;ALOAD (int-to-nat source))))) - $i;fuse) - argsI (if (poly-arg? arity) - (|> (nullsI (n.dec arity)) - (list ($i;int 0)) - $i;fuse) - id)] - (|>. ($i;NEW class) - $i;DUP - captureI - argsI - ($i;INVOKESPECIAL class "" (init-method env arity) false)))) - -(def: (with-reset class arity env) - (-> Text ls;Arity (List Variable) $;Def) - ($d;method #$;Public $;noneM "reset" (reset-method class) - (if (poly-arg? arity) - (let [env-size (list;size env) - captureI (|> (case env-size - +0 (list) - _ (list;n.range +0 (n.dec env-size))) - (list/map (function [source] - (|>. ($i;ALOAD +0) - ($i;GETFIELD class (captured source) $Object)))) - $i;fuse) - argsI (|> (nullsI (n.dec arity)) - (list ($i;int 0)) - $i;fuse)] - (|>. ($i;NEW class) - $i;DUP - captureI - argsI - ($i;INVOKESPECIAL class "" (init-method env arity) false) - $i;ARETURN)) - (|>. ($i;ALOAD +0) - $i;ARETURN)))) - -(def: (with-implementation arity @begin bodyI) - (-> Nat $;Label $;Inst $;Def) - ($d;method #$;Public $;strictM "impl" (implementation-method arity) - (|>. ($i;label @begin) - bodyI - $i;ARETURN))) - -(def: function-init-method - $;Method - ($t;method (list $t;int) #;None (list))) - -(def: (function-init arity env-size) - (-> ls;Arity Nat $;Inst) - (if (n.= +1 arity) - (|>. ($i;int 0) - ($i;INVOKESPECIAL hostL;function-class "" function-init-method false)) - (|>. ($i;ILOAD (n.inc env-size)) - ($i;INVOKESPECIAL hostL;function-class "" function-init-method false)))) - -(def: (with-init class env arity) - (-> Text (List Variable) ls;Arity $;Def) - (let [env-size (list;size env) - offset-partial (: (-> Nat Nat) - (|>. n.inc (n.+ env-size))) - store-capturedI (|> (case env-size - +0 (list) - _ (list;n.range +0 (n.dec env-size))) - (list/map (function [register] - (|>. ($i;ALOAD +0) - ($i;ALOAD (n.inc register)) - ($i;PUTFIELD class (captured register) $Object)))) - $i;fuse) - store-partialI (if (poly-arg? arity) - (|> (list;n.range +0 (n.- +2 arity)) - (list/map (function [idx] - (let [register (offset-partial idx)] - (|>. ($i;ALOAD +0) - ($i;ALOAD (n.inc register)) - ($i;PUTFIELD class (partial idx) $Object))))) - $i;fuse) - id)] - ($d;method #$;Public $;noneM "" (init-method env arity) - (|>. ($i;ALOAD +0) - (function-init arity env-size) - store-capturedI - store-partialI - $i;RETURN)))) - -(def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> Text (List Variable) ls;Arity $;Label $;Inst ls;Arity - $;Def) - (let [num-partials (n.dec function-arity) - @default ($;new-label []) - @labels (list/map $;new-label (list;repeat num-partials [])) - arity-over-extent (|> (nat-to-int function-arity) (i.- (nat-to-int apply-arity))) - casesI (|> (list/compose @labels (list @default)) - (list;zip2 (list;n.range +0 num-partials)) - (list/map (function [[stage @label]] - (let [load-partialsI (if (n.> +0 stage) - (|> (list;n.range +0 (n.dec stage)) - (list/map (|>. partial (load-fieldI class))) - $i;fuse) - id)] - (cond (i.= arity-over-extent (nat-to-int stage)) - (|>. ($i;label @label) - ($i;ALOAD +0) - (when (n.> +0 stage) - ($i;INVOKEVIRTUAL class "reset" (reset-method class) false)) - load-partialsI - (inputsI +1 apply-arity) - ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) - $i;ARETURN) - - (i.> arity-over-extent (nat-to-int stage)) - (let [args-to-completion (|> function-arity (n.- stage)) - args-left (|> apply-arity (n.- args-to-completion))] - (|>. ($i;label @label) - ($i;ALOAD +0) - ($i;INVOKEVIRTUAL class "reset" (reset-method class) false) - load-partialsI - (inputsI +1 args-to-completion) - ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) - (applysI (n.inc args-to-completion) args-left) - $i;ARETURN)) - - ## (i.< arity-over-extent (nat-to-int stage)) - (let [env-size (list;size env) - load-capturedI (|> (case env-size - +0 (list) - _ (list;n.range +0 (n.dec env-size))) - (list/map (|>. captured (load-fieldI class))) - $i;fuse)] - (|>. ($i;label @label) - ($i;NEW class) - $i;DUP - load-capturedI - get-amount-of-partialsI - (inc-intI apply-arity) - load-partialsI - (inputsI +1 apply-arity) - (nullsI (|> num-partials (n.- apply-arity) (n.- stage))) - ($i;INVOKESPECIAL class "" (init-method env function-arity) false) - $i;ARETURN)) - )))) - $i;fuse)] - ($d;method #$;Public $;noneM &runtime;apply-method (&runtime;apply-signature apply-arity) - (|>. get-amount-of-partialsI - ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int) - @default @labels) - casesI - ($i;INVOKESTATIC hostL;runtime-class "apply_fail" ($t;method (list) #;None (list)) false) - $i;NULL - $i;ARETURN - )))) - -(def: #export (with-function generate class env arity body) - (-> (-> ls;Synthesis (Meta $;Inst)) - Text (List Variable) ls;Arity ls;Synthesis - (Meta [$;Def $;Inst])) - (do meta;Monad - [@begin $i;make-label - bodyI (&common;with-function class (generate body)) - #let [env-size (list;size env) - applyD (: $;Def - (if (poly-arg? arity) - (|> (n.min arity &runtime;num-apply-variants) - (list;n.range +1) - (list/map (with-apply class env arity @begin bodyI)) - (list& (with-implementation arity @begin bodyI)) - $d;fuse) - ($d;method #$;Public $;strictM &runtime;apply-method (&runtime;apply-signature +1) - (|>. ($i;label @begin) - bodyI - $i;ARETURN)))) - functionD (: $;Def - (|>. ($d;int-field #$;Public ($_ $;++F $;staticF $;finalF) arity-field (nat-to-int arity)) - (with-captured env) - (with-partial arity) - (with-init class env arity) - (with-reset class arity env) - applyD)) - instanceI (instance class arity env)]] - (wrap [functionD instanceI]))) - -(def: #export (generate-function generate env arity body) - (-> (-> ls;Synthesis (Meta $;Inst)) - (List Variable) ls;Arity ls;Synthesis - (Meta $;Inst)) - (do meta;Monad - [function-class (:: @ map %code (meta;gensym "function")) - [functionD instanceI] (with-function generate function-class env arity body) - _ (&common;store-class function-class - ($d;class #$;V1.6 #$;Public $;finalC - function-class (list) - ($;simple-class hostL;function-class) (list) - functionD))] - (wrap instanceI))) - -(def: (segment size elems) - (All [a] (-> Nat (List a) (List (List a)))) - (let [[pre post] (list;split size elems)] - (if (list;empty? post) - (list pre) - (list& pre (segment size post))))) - -(def: #export (generate-call generate functionS argsS) - (-> (-> ls;Synthesis (Meta $;Inst)) - ls;Synthesis (List ls;Synthesis) - (Meta $;Inst)) - (do meta;Monad - [functionI (generate functionS) - argsI (monad;map @ generate argsS) - #let [applyI (|> (segment &runtime;num-apply-variants argsI) - (list/map (function [chunkI+] - (|>. ($i;CHECKCAST hostL;function-class) - ($i;fuse chunkI+) - ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false)))) - $i;fuse)]] - (wrap (|>. functionI - applyI)))) diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux deleted file mode 100644 index 637f46a85..000000000 --- a/new-luxc/source/luxc/generator/primitive.jvm.lux +++ /dev/null @@ -1,36 +0,0 @@ -(;module: - lux - (lux (control monad) - (data text/format) - [meta "meta/" Monad]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$i" inst] - ["$t" type])) - (lang ["la" analysis] - ["ls" synthesis]) - (generator ["&;" common])) - [../runtime]) - -(def: #export generate-unit - (Meta $;Inst) - (meta/wrap ($i;string hostL;unit))) - -(def: #export (generate-bool value) - (-> Bool (Meta $;Inst)) - (meta/wrap ($i;GETSTATIC "java.lang.Boolean" - (if value "TRUE" "FALSE") - ($t;class "java.lang.Boolean" (list))))) - -(do-template [ ] - [(def: #export ( value) - (-> (Meta $;Inst)) - (meta/wrap (|>. ( value) )))] - - [generate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)] - [generate-int Int $i;long ($i;wrap #$;Long)] - [generate-deg Deg (|>. (:! Int) $i;long) ($i;wrap #$;Long)] - [generate-frac Frac $i;double ($i;wrap #$;Double)] - [generate-text Text $i;string id] - ) diff --git a/new-luxc/source/luxc/generator/procedure.jvm.lux b/new-luxc/source/luxc/generator/procedure.jvm.lux deleted file mode 100644 index 973f0e968..000000000 --- a/new-luxc/source/luxc/generator/procedure.jvm.lux +++ /dev/null @@ -1,24 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (data [maybe] - text/format - (coll [dict]))) - (luxc ["&" base] - (host ["$" jvm]) - (lang ["ls" synthesis])) - (. ["./;" common] - ["./;" host])) - -(def: procedures - ./common;Bundle - (|> ./common;procedures - (dict;merge ./host;procedures))) - -(def: #export (generate-procedure generate name args) - (-> (-> ls;Synthesis (Meta $;Inst)) Text (List ls;Synthesis) - (Meta $;Inst)) - (<| (maybe;default (&;fail (format "Unknown procedure: " (%t name)))) - (do maybe;Monad - [proc (dict;get name procedures)] - (wrap (proc generate args))))) diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux deleted file mode 100644 index dffbcb64e..000000000 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ /dev/null @@ -1,708 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor] - [dict #+ Dict])) - [meta #+ with-gensyms] - (meta [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] - ["ls" synthesis]) - (generator ["&;" common] - ["&;" runtime]))) - -(host;import java.lang.Long - (#static MIN_VALUE Long) - (#static MAX_VALUE Long)) - -(host;import java.lang.Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double) - (#static NaN Double) - (#static POSITIVE_INFINITY Double) - (#static NEGATIVE_INFINITY Double)) - -## [Types] -(type: #export Generator - (-> ls;Synthesis (Meta $;Inst))) - -(type: #export Proc - (-> Generator (List ls;Synthesis) (Meta $;Inst))) - -(type: #export Bundle - (Dict Text Proc)) - -(syntax: (Vector [size s;nat] elemT) - (wrap (list (` [(~@ (list;repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 $;Inst) $;Inst)) -(type: #export Unary (-> (Vector +1 $;Inst) $;Inst)) -(type: #export Binary (-> (Vector +2 $;Inst) $;Inst)) -(type: #export Trinary (-> (Vector +3 $;Inst) $;Inst)) - -## [Utils] -(def: $Object $;Type ($t;class "java.lang.Object" (list))) -(def: $Object-Array $;Type ($t;array +1 $Object)) -(def: $String $;Type ($t;class "java.lang.String" (list))) -(def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list))) -(def: $Function $;Type ($t;class hostL;function-class (list))) - -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict;put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict;entries - (list/map (function [[key val]] [(format prefix " " key) val])) - (dict;from-list text;Hash))) - -(def: (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong number of arguments for " (%t proc) "\n" - "Expected: " (|> expected nat-to-int %i) "\n" - " Actual: " (|> actual nat-to-int %i))) - -(syntax: (arity: [name s;local-symbol] [arity s;nat]) - (with-gensyms [g!proc g!name g!generate g!inputs] - (do @ - [g!input+ (monad;seq @ (list;repeat arity (meta;gensym "input")))] - (wrap (list (` (def: #export ((~ (code;local-symbol name)) (~ g!proc)) - (-> (-> (;;Vector (~ (code;nat arity)) $;Inst) $;Inst) - (-> Text ;;Proc)) - (function [(~ g!name)] - (function [(~ g!generate) (~ g!inputs)] - (case (~ g!inputs) - (^ (list (~@ g!input+))) - (do meta;Monad - [(~@ (|> g!input+ - (list/map (function [g!input] - (list g!input (` ((~ g!generate) (~ g!input)))))) - list;concat))] - ((~' wrap) ((~ g!proc) [(~@ g!input+)]))) - - (~' _) - (meta;fail (wrong-arity (~ g!name) +1 (list;size (~ g!inputs)))))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -## [Instructions] -(def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long))) -(def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I)) - -(def: (array-writeI arrayI idxI elemI) - (-> $;Inst $;Inst $;Inst - $;Inst) - (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) - $i;DUP - idxI jvm-intI - elemI - $i;AASTORE)) - -(def: (predicateI tester) - (-> (-> $;Label $;Inst) - $;Inst) - (<| $i;with-label (function [@then]) - $i;with-label (function [@end]) - (|>. (tester @then) - ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) - ($i;GOTO @end) - ($i;label @then) - ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) - ($i;label @end) - ))) - -## [Procedures] -## [[Lux]] -(def: (lux//is [leftI rightI]) - Binary - (|>. leftI - rightI - (predicateI $i;IF_ACMPEQ))) - -(def: try-method - $;Method - ($t;method (list $Function) (#;Some $Object-Array) (list))) -(def: (lux//try riskyI) - Unary - (|>. riskyI - ($i;CHECKCAST hostL;function-class) - ($i;INVOKESTATIC hostL;runtime-class "try" try-method false))) - -(def: (lux//noop valueI) - Unary - valueI) - -## [[Bits]] -(do-template [ ] - [(def: ( [inputI maskI]) - Binary - (|>. inputI ($i;unwrap #$;Long) - maskI ($i;unwrap #$;Long) - ($i;wrap #$;Long)))] - - [bit//and $i;LAND] - [bit//or $i;LOR] - [bit//xor $i;LXOR] - ) - -(def: (bit//count inputI) - Unary - (|>. inputI ($i;unwrap #$;Long) - ($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false) - lux-intI)) - -(do-template [ ] - [(def: ( [inputI shiftI]) - Binary - (|>. inputI ($i;unwrap #$;Long) - shiftI jvm-intI - - ($i;wrap #$;Long)))] - - [bit//shift-left $i;LSHL] - [bit//shift-right $i;LSHR] - [bit//unsigned-shift-right $i;LUSHR] - ) - -## [[Arrays]] -(def: (array//new lengthI) - Unary - (|>. lengthI jvm-intI ($i;ANEWARRAY ($t;descriptor $Object)))) - -(def: (array//get [arrayI idxI]) - Binary - (<| $i;with-label (function [@is-null]) - $i;with-label (function [@end]) - (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) - idxI jvm-intI - $i;AALOAD - $i;DUP - ($i;IFNULL @is-null) - &runtime;someI - ($i;GOTO @end) - ($i;label @is-null) - $i;POP - &runtime;noneI - ($i;label @end)))) - -(def: (array//put [arrayI idxI elemI]) - Trinary - (array-writeI arrayI idxI elemI)) - -(def: (array//remove [arrayI idxI]) - Binary - (array-writeI arrayI idxI $i;NULL)) - -(def: (array//size arrayI) - Unary - (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) - $i;ARRAYLENGTH - lux-intI)) - -## [[Numbers]] -(def: nat-method - $;Method - ($t;method (list $t;long $t;long) (#;Some $t;long) (list))) - -(def: deg-method $;Method nat-method) - -(def: compare-nat-method - $;Method - ($t;method (list $t;long $t;long) (#;Some $t;int) (list))) - -(do-template [ ] - [(def: ( _) - Nullary - (|>. ))] - - [nat//min ($i;long 0) ($i;wrap #$;Long)] - [nat//max ($i;long -1) ($i;wrap #$;Long)] - - [int//min ($i;long Long.MIN_VALUE) ($i;wrap #$;Long)] - [int//max ($i;long Long.MAX_VALUE) ($i;wrap #$;Long)] - - [frac//smallest ($i;double Double.MIN_VALUE) ($i;wrap #$;Double)] - [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) ($i;wrap #$;Double)] - [frac//max ($i;double Double.MAX_VALUE) ($i;wrap #$;Double)] - [frac//not-a-number ($i;double Double.NaN) ($i;wrap #$;Double)] - [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) ($i;wrap #$;Double)] - [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) ($i;wrap #$;Double)] - - [deg//min ($i;long 0) ($i;wrap #$;Long)] - [deg//max ($i;long -1) ($i;wrap #$;Long)] - ) - -(do-template [ ] - [(def: ( [subjectI paramI]) - Binary - (|>. subjectI - paramI - - ))] - - [int//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] - [int//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] - [int//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] - [int//div ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] - [int//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LREM] - - [nat//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] - [nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] - [nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] - [nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] - [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] - - [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD] - [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB] - [frac//mul ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DMUL] - [frac//div ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DDIV] - [frac//rem ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DREM] - - [deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] - [deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] - [deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] - [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)] - [deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] - [deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] - [deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] - ) - -(do-template [ ] - [(do-template [ ] - [(def: ( [subjectI paramI]) - Binary - (|>. subjectI - paramI - - ($i;int ) - (predicateI $i;IF_ICMPEQ)))] - [ 0] - [ -1])] - - [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)] - [int//eq int//lt ($i;unwrap #$;Long) $i;LCMP] - [frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG] - [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)] - ) - -(do-template [ ] - [(def: ( inputI) - Unary - (|>. inputI ))] - - [nat//to-int id id] - [nat//to-char ($i;unwrap #$;Long) - (<| ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false) - $i;I2C $i;L2I)] - - [int//to-nat id id] - [int//to-frac ($i;unwrap #$;Long) (<| ($i;wrap #$;Double) $i;L2D)] - - [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)] - [frac//to-deg ($i;unwrap #$;Double) - (<| ($i;wrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "frac_to_deg" - ($t;method (list $t;double) (#;Some $t;long) (list)) false))] - [frac//encode ($i;unwrap #$;Double) - ($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)] - [frac//decode ($i;CHECKCAST "java.lang.String") - ($i;INVOKESTATIC hostL;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] - - [deg//to-frac ($i;unwrap #$;Long) - (<| ($i;wrap #$;Double) ($i;INVOKESTATIC hostL;runtime-class "deg_to_frac" - ($t;method (list $t;long) (#;Some $t;double) (list)) false))] - ) - -## [[Text]] -(do-template [ ] - [(def: ( inputI) - Unary - (|>. inputI - ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL ($t;method (list) (#;Some ) (list)) false) - ))] - - [text//size "java.lang.String" "length" lux-intI $t;int] - [text//hash "java.lang.Object" "hashCode" lux-intI $t;int] - [text//trim "java.lang.String" "trim" id $String] - [text//upper-case "java.lang.String" "toUpperCase" id $String] - [text//lower-case "java.lang.String" "toLowerCase" id $String] - ) - -(do-template [ ] - [(def: ( [subjectI paramI]) - Binary - (|>. subjectI - paramI - ))] - - [text//eq id id - ($i;INVOKEVIRTUAL "java.lang.Object" "equals" ($t;method (list $Object) (#;Some $t;boolean) (list)) false) - ($i;wrap #$;Boolean)] - [text//lt ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "compareTo" ($t;method (list $String) (#;Some $t;int) (list)) false) - (predicateI $i;IF_ICMPEQ)] - [text//append ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false) - id] - [text//contains? ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false) - ($i;wrap #$;Boolean)] - [text//char ($i;CHECKCAST "java.lang.String") jvm-intI - ($i;INVOKESTATIC hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) - lux-intI] - ) - -(do-template [ ] - [(def: ( [subjectI paramI extraI]) - Trinary - (|>. subjectI - paramI - extraI - ))] - - [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI - ($i;INVOKESTATIC hostL;runtime-class "text_clip" - ($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)] - [text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)] - ) - -(def: index-method $;Method ($t;method (list $String $t;int) (#;Some $t;int) (list))) -(do-template [ ] - [(def: ( [textI partI startI]) - Trinary - (<| $i;with-label (function [@not-found]) - $i;with-label (function [@end]) - (|>. textI ($i;CHECKCAST "java.lang.String") - partI ($i;CHECKCAST "java.lang.String") - startI jvm-intI - ($i;INVOKEVIRTUAL "java.lang.String" index-method false) - $i;DUP - ($i;int -1) - ($i;IF_ICMPEQ @not-found) - lux-intI - &runtime;someI - ($i;GOTO @end) - ($i;label @not-found) - $i;POP - &runtime;noneI - ($i;label @end))))] - - [text//index "indexOf"] - [text//last-index "lastIndexOf"] - ) - -## [[Math]] -(def: math-unary-method ($t;method (list $t;double) (#;Some $t;double) (list))) -(def: math-binary-method ($t;method (list $t;double $t;double) (#;Some $t;double) (list))) - -(do-template [ ] - [(def: ( inputI) - Unary - (|>. inputI - ($i;unwrap #$;Double) - ($i;INVOKESTATIC "java.lang.Math" math-unary-method false) - ($i;wrap #$;Double)))] - - [math//cos "cos"] - [math//sin "sin"] - [math//tan "tan"] - [math//acos "acos"] - [math//asin "asin"] - [math//atan "atan"] - [math//cosh "cosh"] - [math//sinh "sinh"] - [math//tanh "tanh"] - [math//exp "exp"] - [math//log "log"] - [math//root2 "sqrt"] - [math//root3 "cbrt"] - [math//ceil "ceil"] - [math//floor "floor"] - ) - -(do-template [ ] - [(def: ( [inputI paramI]) - Binary - (|>. inputI ($i;unwrap #$;Double) - paramI ($i;unwrap #$;Double) - ($i;INVOKESTATIC "java.lang.Math" math-binary-method false) - ($i;wrap #$;Double)))] - - [math//atan2 "atan2"] - [math//pow "pow"] - ) - -(def: (math//round inputI) - Unary - (|>. inputI - ($i;unwrap #$;Double) - ($i;INVOKESTATIC "java.lang.Math" "round" ($t;method (list $t;double) (#;Some $t;long) (list)) false) - $i;L2D - ($i;wrap #$;Double))) - -## [[IO]] -(def: string-method $;Method ($t;method (list $String) #;None (list))) -(def: (io//log messageI) - Unary - (|>. ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) - messageI - ($i;CHECKCAST "java.lang.String") - ($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) - ($i;string hostL;unit))) - -(def: (io//error messageI) - Unary - (|>. ($i;NEW "java.lang.Error") - $i;DUP - messageI - ($i;CHECKCAST "java.lang.String") - ($i;INVOKESPECIAL "java.lang.Error" "" string-method false) - $i;ATHROW)) - -(def: (io//exit codeI) - Unary - (|>. codeI jvm-intI - ($i;INVOKESTATIC "java.lang.System" "exit" ($t;method (list $t;int) #;None (list)) false) - $i;NULL)) - -(def: (io//current-time []) - Nullary - (|>. ($i;INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t;method (list) (#;Some $t;long) (list)) false) - ($i;wrap #$;Long))) - -## [[Atoms]] -(def: atom-class Text "java.util.concurrent.atomic.AtomicReference") -(def: (atom//new initI) - Unary - (|>. ($i;NEW atom-class) - $i;DUP - initI - ($i;INVOKESPECIAL atom-class "" ($t;method (list $Object) #;None (list)) false))) - -(def: (atom//read atomI) - Unary - (|>. atomI - ($i;CHECKCAST atom-class) - ($i;INVOKEVIRTUAL atom-class "get" ($t;method (list) (#;Some $Object) (list)) false))) - -(def: (atom//compare-and-swap [atomI oldI newI]) - Trinary - (|>. atomI - ($i;CHECKCAST atom-class) - oldI - newI - ($i;INVOKEVIRTUAL atom-class "compareAndSet" ($t;method (list $Object $Object) (#;Some $t;boolean) (list)) false) - ($i;wrap #$;Boolean))) - -## [[Processes]] -(def: (process//concurrency-level []) - Nullary - (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int) - lux-intI)) - -(def: (process//future procedureI) - Unary - (|>. procedureI ($i;CHECKCAST hostL;function-class) - ($i;INVOKESTATIC hostL;runtime-class "future" - ($t;method (list $Function) (#;Some $Object) (list)) false))) - -(def: (process//schedule [millisecondsI procedureI]) - Binary - (|>. millisecondsI ($i;unwrap #$;Long) - procedureI ($i;CHECKCAST hostL;function-class) - ($i;INVOKESTATIC hostL;runtime-class "schedule" - ($t;method (list $t;long $Function) (#;Some $Object) (list)) false))) - -## [Bundles] -(def: lux-procs - Bundle - (|> (dict;new text;Hash) - (install "lux noop" (unary lux//noop)) - (install "lux is" (binary lux//is)) - (install "lux try" (unary lux//try)))) - -(def: bit-procs - Bundle - (|> (dict;new text;Hash) - (install "bit count" (unary bit//count)) - (install "bit and" (binary bit//and)) - (install "bit or" (binary bit//or)) - (install "bit xor" (binary bit//xor)) - (install "bit shift-left" (binary bit//shift-left)) - (install "bit unsigned-shift-right" (binary bit//unsigned-shift-right)) - (install "bit shift-right" (binary bit//shift-right)) - )) - -(def: nat-procs - Bundle - (|> (dict;new text;Hash) - (install "nat +" (binary nat//add)) - (install "nat -" (binary nat//sub)) - (install "nat *" (binary nat//mul)) - (install "nat /" (binary nat//div)) - (install "nat %" (binary nat//rem)) - (install "nat =" (binary nat//eq)) - (install "nat <" (binary nat//lt)) - (install "nat min" (nullary nat//min)) - (install "nat max" (nullary nat//max)) - (install "nat to-int" (unary nat//to-int)) - (install "nat to-char" (unary nat//to-char)))) - -(def: int-procs - Bundle - (|> (dict;new text;Hash) - (install "int +" (binary int//add)) - (install "int -" (binary int//sub)) - (install "int *" (binary int//mul)) - (install "int /" (binary int//div)) - (install "int %" (binary int//rem)) - (install "int =" (binary int//eq)) - (install "int <" (binary int//lt)) - (install "int min" (nullary int//min)) - (install "int max" (nullary int//max)) - (install "int to-nat" (unary int//to-nat)) - (install "int to-frac" (unary int//to-frac)))) - -(def: deg-procs - Bundle - (|> (dict;new text;Hash) - (install "deg +" (binary deg//add)) - (install "deg -" (binary deg//sub)) - (install "deg *" (binary deg//mul)) - (install "deg /" (binary deg//div)) - (install "deg %" (binary deg//rem)) - (install "deg =" (binary deg//eq)) - (install "deg <" (binary deg//lt)) - (install "deg scale" (binary deg//scale)) - (install "deg reciprocal" (binary deg//reciprocal)) - (install "deg min" (nullary deg//min)) - (install "deg max" (nullary deg//max)) - (install "deg to-frac" (unary deg//to-frac)))) - -(def: frac-procs - Bundle - (|> (dict;new text;Hash) - (install "frac +" (binary frac//add)) - (install "frac -" (binary frac//sub)) - (install "frac *" (binary frac//mul)) - (install "frac /" (binary frac//div)) - (install "frac %" (binary frac//rem)) - (install "frac =" (binary frac//eq)) - (install "frac <" (binary frac//lt)) - (install "frac smallest" (nullary frac//smallest)) - (install "frac min" (nullary frac//min)) - (install "frac max" (nullary frac//max)) - (install "frac not-a-number" (nullary frac//not-a-number)) - (install "frac positive-infinity" (nullary frac//positive-infinity)) - (install "frac negative-infinity" (nullary frac//negative-infinity)) - (install "frac to-deg" (unary frac//to-deg)) - (install "frac to-int" (unary frac//to-int)) - (install "frac encode" (unary frac//encode)) - (install "frac decode" (unary frac//decode)))) - -(def: text-procs - Bundle - (|> (dict;new text;Hash) - (install "text =" (binary text//eq)) - (install "text <" (binary text//lt)) - (install "text append" (binary text//append)) - (install "text index" (trinary text//index)) - (install "text size" (unary text//size)) - (install "text hash" (unary text//hash)) - (install "text replace" (trinary text//replace)) - (install "text char" (binary text//char)) - (install "text clip" (trinary text//clip)) - )) - -(def: array-procs - Bundle - (|> (dict;new text;Hash) - (install "array new" (unary array//new)) - (install "array get" (binary array//get)) - (install "array put" (trinary array//put)) - (install "array remove" (binary array//remove)) - (install "array size" (unary array//size)) - )) - -(def: math-procs - Bundle - (|> (dict;new text;Hash) - (install "math cos" (unary math//cos)) - (install "math sin" (unary math//sin)) - (install "math tan" (unary math//tan)) - (install "math acos" (unary math//acos)) - (install "math asin" (unary math//asin)) - (install "math atan" (unary math//atan)) - (install "math cosh" (unary math//cosh)) - (install "math sinh" (unary math//sinh)) - (install "math tanh" (unary math//tanh)) - (install "math exp" (unary math//exp)) - (install "math log" (unary math//log)) - (install "math root2" (unary math//root2)) - (install "math root3" (unary math//root3)) - (install "math ceil" (unary math//ceil)) - (install "math floor" (unary math//floor)) - (install "math round" (unary math//round)) - (install "math atan2" (binary math//atan2)) - (install "math pow" (binary math//pow)) - )) - -(def: io-procs - Bundle - (|> (dict;new text;Hash) - (install "io log" (unary io//log)) - (install "io error" (unary io//error)) - (install "io exit" (unary io//exit)) - (install "io current-time" (nullary io//current-time)))) - -(def: atom-procs - Bundle - (|> (dict;new text;Hash) - (install "atom new" (unary atom//new)) - (install "atom read" (unary atom//read)) - (install "atom compare-and-swap" (trinary atom//compare-and-swap)))) - -(def: process-procs - Bundle - (|> (dict;new text;Hash) - (install "process concurrency-level" (nullary process//concurrency-level)) - (install "process future" (unary process//future)) - (install "process schedule" (binary process//schedule)) - )) - -(def: #export procedures - Bundle - (|> (dict;new text;Hash) - (dict;merge lux-procs) - (dict;merge bit-procs) - (dict;merge nat-procs) - (dict;merge int-procs) - (dict;merge deg-procs) - (dict;merge frac-procs) - (dict;merge text-procs) - (dict;merge array-procs) - (dict;merge math-procs) - (dict;merge io-procs) - (dict;merge atom-procs) - (dict;merge process-procs) - )) diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux deleted file mode 100644 index 9222b2e4a..000000000 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ /dev/null @@ -1,763 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do] - ["p" parser "parser/" Monad] - ["ex" exception #+ exception:]) - (data [product] - ["e" error] - [text "text/" Eq] - (text format - ["l" lexer]) - (coll [list "list/" Functor] - [dict #+ Dict])) - [meta #+ with-gensyms "meta/" Monad] - (meta [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] - (analysis (procedure ["&;" host])) - ["ls" synthesis]) - (generator ["&;" common] - ["&;" runtime])) - ["@" ../common]) - -(do-template [ ] - [(def: - $;Inst - )] - - [L2S (|>. $i;L2I $i;I2S)] - [L2B (|>. $i;L2I $i;I2B)] - [L2C (|>. $i;L2I $i;I2C)] - ) - -(do-template [ ] - [(def: ( inputI) - @;Unary - (if (is $i;NOP ) - (|>. inputI - ($i;unwrap ) - ($i;wrap )) - (|>. inputI - ($i;unwrap ) - - ($i;wrap ))))] - - [convert//double-to-float #$;Double $i;D2F #$;Float] - [convert//double-to-int #$;Double $i;D2I #$;Int] - [convert//double-to-long #$;Double $i;D2L #$;Long] - [convert//float-to-double #$;Float $i;F2D #$;Double] - [convert//float-to-int #$;Float $i;F2I #$;Int] - [convert//float-to-long #$;Float $i;F2L #$;Long] - [convert//int-to-byte #$;Int $i;I2B #$;Byte] - [convert//int-to-char #$;Int $i;I2C #$;Char] - [convert//int-to-double #$;Int $i;I2D #$;Double] - [convert//int-to-float #$;Int $i;I2F #$;Float] - [convert//int-to-long #$;Int $i;I2L #$;Long] - [convert//int-to-short #$;Int $i;I2S #$;Short] - [convert//long-to-double #$;Long $i;L2D #$;Double] - [convert//long-to-float #$;Long $i;L2F #$;Float] - [convert//long-to-int #$;Long $i;L2I #$;Int] - [convert//long-to-short #$;Long L2S #$;Short] - [convert//long-to-byte #$;Long L2B #$;Byte] - [convert//long-to-char #$;Long L2C #$;Char] - [convert//char-to-byte #$;Char $i;I2B #$;Byte] - [convert//char-to-short #$;Char $i;I2S #$;Short] - [convert//char-to-int #$;Char $i;NOP #$;Int] - [convert//char-to-long #$;Char $i;I2L #$;Long] - [convert//byte-to-long #$;Byte $i;I2L #$;Long] - [convert//short-to-long #$;Short $i;I2L #$;Long] - ) - -(def: conversion-procs - @;Bundle - (<| (@;prefix "convert") - (|> (dict;new text;Hash) - (@;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 [ ] - [(def: ( [xI yI]) - @;Binary - (|>. xI ($i;unwrap ) - yI ($i;unwrap ) - ($i;wrap )))] - - [int//+ $i;IADD #$;Int #$;Int #$;Int] - [int//- $i;ISUB #$;Int #$;Int #$;Int] - [int//* $i;IMUL #$;Int #$;Int #$;Int] - [int/// $i;IDIV #$;Int #$;Int #$;Int] - [int//% $i;IREM #$;Int #$;Int #$;Int] - [int//and $i;IAND #$;Int #$;Int #$;Int] - [int//or $i;IOR #$;Int #$;Int #$;Int] - [int//xor $i;IXOR #$;Int #$;Int #$;Int] - [int//shl $i;ISHL #$;Int #$;Int #$;Int] - [int//shr $i;ISHR #$;Int #$;Int #$;Int] - [int//ushr $i;IUSHR #$;Int #$;Int #$;Int] - - [long//+ $i;LADD #$;Long #$;Long #$;Long] - [long//- $i;LSUB #$;Long #$;Long #$;Long] - [long//* $i;LMUL #$;Long #$;Long #$;Long] - [long/// $i;LDIV #$;Long #$;Long #$;Long] - [long//% $i;LREM #$;Long #$;Long #$;Long] - [long//and $i;LAND #$;Long #$;Long #$;Long] - [long//or $i;LOR #$;Long #$;Long #$;Long] - [long//xor $i;LXOR #$;Long #$;Long #$;Long] - [long//shl $i;LSHL #$;Long #$;Int #$;Long] - [long//shr $i;LSHR #$;Long #$;Int #$;Long] - [long//ushr $i;LUSHR #$;Long #$;Int #$;Long] - - [float//+ $i;FADD #$;Float #$;Float #$;Float] - [float//- $i;FSUB #$;Float #$;Float #$;Float] - [float//* $i;FMUL #$;Float #$;Float #$;Float] - [float/// $i;FDIV #$;Float #$;Float #$;Float] - [float//% $i;FREM #$;Float #$;Float #$;Float] - - [double//+ $i;DADD #$;Double #$;Double #$;Double] - [double//- $i;DSUB #$;Double #$;Double #$;Double] - [double//* $i;DMUL #$;Double #$;Double #$;Double] - [double/// $i;DDIV #$;Double #$;Double #$;Double] - [double//% $i;DREM #$;Double #$;Double #$;Double] - ) - -(do-template [ ] - [(def: ( [xI yI]) - @;Binary - (<| $i;with-label (function [@then]) - $i;with-label (function [@end]) - (|>. xI ($i;unwrap ) - yI ($i;unwrap ) - ( @then) - ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) - ($i;GOTO @end) - ($i;label @then) - ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) - ($i;label @end))))] - - [int//= $i;IF_ICMPEQ #$;Int #$;Int #$;Boolean] - [int//< $i;IF_ICMPLT #$;Int #$;Int #$;Boolean] - - [char//= $i;IF_ICMPEQ #$;Char #$;Char #$;Boolean] - [char//< $i;IF_ICMPLT #$;Char #$;Char #$;Boolean] - ) - -(do-template [ ] - [(def: ( [xI yI]) - @;Binary - (<| $i;with-label (function [@then]) - $i;with-label (function [@end]) - (|>. xI ($i;unwrap ) - yI ($i;unwrap ) - - ($i;int ) - ($i;IF_ICMPEQ @then) - ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) - ($i;GOTO @end) - ($i;label @then) - ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) - ($i;label @end))))] - - [long//= $i;LCMP 0 #$;Long #$;Long #$;Boolean] - [long//< $i;LCMP -1 #$;Long #$;Long #$;Boolean] - - [float//= $i;FCMPG 0 #$;Float #$;Float #$;Boolean] - [float//< $i;FCMPG -1 #$;Float #$;Float #$;Boolean] - - [double//= $i;DCMPG 0 #$;Double #$;Double #$;Boolean] - [double//< $i;DCMPG -1 #$;Double #$;Double #$;Boolean] - ) - -(def: int-procs - @;Bundle - (<| (@;prefix "int") - (|> (dict;new text;Hash) - (@;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) - (@;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) - (@;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) - (@;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) - (@;install "=" (@;binary char//=)) - (@;install "<" (@;binary char//<)) - ))) - -(def: (array//length arrayI) - @;Unary - (|>. arrayI - $i;ARRAYLENGTH - $i;I2L - ($i;wrap #$;Long))) - -(def: (array//new proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS)) - (do meta;Monad - [lengthI (generate lengthS) - #let [arrayJT ($t;array level (case class - "boolean" $t;boolean - "byte" $t;byte - "short" $t;short - "int" $t;int - "long" $t;long - "float" $t;float - "double" $t;double - "char" $t;char - _ ($t;class class (list))))]] - (wrap (|>. lengthI - ($i;unwrap #$;Long) - $i;L2I - ($i;array arrayJT)))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(def: (array//read proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list [_ (#;Text class)] idxS arrayS)) - (do meta;Monad - [arrayI (generate arrayS) - idxI (generate idxS) - #let [loadI (case class - "boolean" (|>. $i;BALOAD ($i;wrap #$;Boolean)) - "byte" (|>. $i;BALOAD ($i;wrap #$;Byte)) - "short" (|>. $i;SALOAD ($i;wrap #$;Short)) - "int" (|>. $i;IALOAD ($i;wrap #$;Int)) - "long" (|>. $i;LALOAD ($i;wrap #$;Long)) - "float" (|>. $i;FALOAD ($i;wrap #$;Float)) - "double" (|>. $i;DALOAD ($i;wrap #$;Double)) - "char" (|>. $i;CALOAD ($i;wrap #$;Char)) - _ $i;AALOAD)]] - (wrap (|>. arrayI - idxI - ($i;unwrap #$;Long) - $i;L2I - loadI))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(def: (array//write proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list [_ (#;Text class)] idxS valueS arrayS)) - (do meta;Monad - [arrayI (generate arrayS) - idxI (generate idxS) - valueI (generate valueS) - #let [storeI (case class - "boolean" (|>. ($i;unwrap #$;Boolean) $i;BASTORE) - "byte" (|>. ($i;unwrap #$;Byte) $i;BASTORE) - "short" (|>. ($i;unwrap #$;Short) $i;SASTORE) - "int" (|>. ($i;unwrap #$;Int) $i;IASTORE) - "long" (|>. ($i;unwrap #$;Long) $i;LASTORE) - "float" (|>. ($i;unwrap #$;Float) $i;FASTORE) - "double" (|>. ($i;unwrap #$;Double) $i;DASTORE) - "char" (|>. ($i;unwrap #$;Char) $i;CASTORE) - _ $i;AASTORE)]] - (wrap (|>. arrayI - $i;DUP - idxI - ($i;unwrap #$;Long) - $i;L2I - valueI - storeI))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(def: array-procs - @;Bundle - (<| (@;prefix "array") - (|> (dict;new text;Hash) - (@;install "length" (@;unary array//length)) - (@;install "new" array//new) - (@;install "read" array//read) - (@;install "write" array//write) - ))) - -(def: (object//null _) - @;Nullary - $i;NULL) - -(def: (object//null? objectI) - @;Unary - (<| $i;with-label (function [@then]) - $i;with-label (function [@end]) - (|>. objectI - ($i;IFNULL @then) - ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) - ($i;GOTO @end) - ($i;label @then) - ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) - ($i;label @end)))) - -(def: (object//synchronized [monitorI exprI]) - @;Binary - (|>. monitorI - $i;DUP - $i;MONITORENTER - exprI - $i;SWAP - $i;MONITOREXIT)) - -(def: (object//throw exceptionI) - @;Unary - (|>. exceptionI - $i;ATHROW)) - -(def: (object//class proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list [_ (#;Text class)])) - (do meta;Monad - [] - (wrap (|>. ($i;string class) - ($i;INVOKESTATIC "java.lang.Class" "forName" - ($t;method (list ($t;class "java.lang.String" (list))) - (#;Some ($t;class "java.lang.Class" (list))) - (list)) - false)))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(def: (object//instance? proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list [_ (#;Text class)] objectS)) - (do meta;Monad - [objectI (generate objectS)] - (wrap (|>. objectI - ($i;INSTANCEOF class) - ($i;wrap #$;Boolean)))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(def: object-procs - @;Bundle - (<| (@;prefix "object") - (|> (dict;new text;Hash) - (@;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))) - -(def: (static//get proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)])) - (do meta;Monad - [] - (case (dict;get unboxed primitives) - (#;Some primitive) - (let [primitive (case unboxed - "boolean" #$;Boolean - "byte" #$;Byte - "short" #$;Short - "int" #$;Int - "long" #$;Long - "float" #$;Float - "double" #$;Double - "char" #$;Char - _ (undefined))] - (wrap (|>. ($i;GETSTATIC class field (#$;Primitive primitive)) - ($i;wrap primitive)))) - - #;None - (wrap ($i;GETSTATIC class field ($t;class unboxed (list)))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(def: (static//put proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS)) - (do meta;Monad - [valueI (generate valueS)] - (case (dict;get unboxed primitives) - (#;Some primitive) - (let [primitive (case unboxed - "boolean" #$;Boolean - "byte" #$;Byte - "short" #$;Short - "int" #$;Int - "long" #$;Long - "float" #$;Float - "double" #$;Double - "char" #$;Char - _ (undefined))] - (wrap (|>. valueI - ($i;unwrap primitive) - ($i;PUTSTATIC class field (#$;Primitive primitive)) - ($i;string hostL;unit)))) - - #;None - (wrap (|>. valueI - ($i;CHECKCAST class) - ($i;PUTSTATIC class field ($t;class class (list))) - ($i;string hostL;unit))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(def: (virtual//get proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS)) - (do meta;Monad - [objectI (generate objectS)] - (case (dict;get unboxed primitives) - (#;Some primitive) - (let [primitive (case unboxed - "boolean" #$;Boolean - "byte" #$;Byte - "short" #$;Short - "int" #$;Int - "long" #$;Long - "float" #$;Float - "double" #$;Double - "char" #$;Char - _ (undefined))] - (wrap (|>. objectI - ($i;CHECKCAST class) - ($i;GETFIELD class field (#$;Primitive primitive)) - ($i;wrap primitive)))) - - #;None - (wrap (|>. objectI - ($i;CHECKCAST class) - ($i;GETFIELD class field ($t;class unboxed (list))))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(def: (virtual//put proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS)) - (do meta;Monad - [valueI (generate valueS) - objectI (generate objectS)] - (case (dict;get unboxed primitives) - (#;Some primitive) - (let [primitive (case unboxed - "boolean" #$;Boolean - "byte" #$;Byte - "short" #$;Short - "int" #$;Int - "long" #$;Long - "float" #$;Float - "double" #$;Double - "char" #$;Char - _ (undefined))] - (wrap (|>. objectI - ($i;CHECKCAST class) - $i;DUP - valueI - ($i;unwrap primitive) - ($i;PUTFIELD class field (#$;Primitive primitive))))) - - #;None - (wrap (|>. objectI - ($i;CHECKCAST class) - $i;DUP - valueI - ($i;CHECKCAST unboxed) - ($i;PUTFIELD class field ($t;class unboxed (list))))))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(exception: #export Invalid-Syntax-For-Argument-Generation) - -(def: base-type - (l;Lexer $;Type) - ($_ p;either - (p;after (l;this "boolean") (parser/wrap $t;boolean)) - (p;after (l;this "byte") (parser/wrap $t;byte)) - (p;after (l;this "short") (parser/wrap $t;short)) - (p;after (l;this "int") (parser/wrap $t;int)) - (p;after (l;this "long") (parser/wrap $t;long)) - (p;after (l;this "float") (parser/wrap $t;float)) - (p;after (l;this "double") (parser/wrap $t;double)) - (p;after (l;this "char") (parser/wrap $t;char)) - (parser/map (function [name] - ($t;class name (list))) - (l;many (l;none-of "["))) - )) - -(def: java-type - (l;Lexer $;Type) - (do p;Monad - [raw base-type - nesting (p;some (l;this "[]"))] - (wrap ($t;array (list;size nesting) raw)))) - -(def: (generate-type argD) - (-> Text (Meta $;Type)) - (case (l;run argD java-type) - (#e;Error error) - (&;fail error) - - (#e;Success type) - (meta/wrap type))) - -(def: (prepare-input inputT inputI) - (-> $;Type $;Inst $;Inst) - (case inputT - (#$;Primitive primitive) - (|>. inputI ($i;unwrap primitive)) - - (#$;Generic generic) - (case generic - (^or (#$;Var _) (#$;Wildcard _)) - (|>. inputI ($i;CHECKCAST "java.lang.Object")) - - (#$;Class class-name _) - (|>. inputI ($i;CHECKCAST class-name))) - - _ - (|>. inputI ($i;CHECKCAST ($t;descriptor inputT))))) - -(def: (generate-args generate argsS) - (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) - (Meta (List [$;Type $;Inst]))) - (case argsS - #;Nil - (meta/wrap #;Nil) - - (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail)) - (do meta;Monad - [argT (generate-type argD) - argI (:: @ map (prepare-input argT) (generate argS)) - =tail (generate-args generate tail)] - (wrap (list& [argT argI] =tail))) - - _ - (&;throw Invalid-Syntax-For-Argument-Generation ""))) - -(def: (method-return-type description) - (-> Text (Meta (Maybe $;Type))) - (case description - "void" - (meta/wrap #;None) - - _ - (:: meta;Monad map (|>. #;Some) (generate-type description)))) - -(def: (prepare-return returnT returnI) - (-> (Maybe $;Type) $;Inst $;Inst) - (case returnT - #;None - (|>. returnI - ($i;string hostL;unit)) - - (#;Some type) - (case type - (#$;Primitive primitive) - (|>. returnI ($i;wrap primitive)) - - _ - returnI))) - -(def: (invoke//static proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list& [_ (#;Text class)] [_ (#;Text method)] - [_ (#;Text unboxed)] argsS)) - (do meta;Monad - [argsTI (generate-args generate argsS) - returnT (method-return-type unboxed) - #let [callI (|>. ($i;fuse (list/map product;right argsTI)) - ($i;INVOKESTATIC class method - ($t;method (list/map product;left argsTI) returnT (list)) - false))]] - (wrap (prepare-return returnT callI))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(do-template [ ] - [(def: ( proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list& [_ (#;Text class)] [_ (#;Text method)] - [_ (#;Text unboxed)] objectS argsS)) - (do meta;Monad - [objectI (generate objectS) - argsTI (generate-args generate argsS) - returnT (method-return-type unboxed) - #let [callI (|>. objectI - ($i;CHECKCAST class) - ($i;fuse (list/map product;right argsTI)) - ( class method - ($t;method (list/map product;left argsTI) returnT (list)) - ))]] - (wrap (prepare-return returnT callI))) - - _ - (&;fail (format "Wrong syntax for '" proc "'."))))] - - [invoke//virtual $i;INVOKEVIRTUAL false] - [invoke//special $i;INVOKESPECIAL false] - [invoke//interface $i;INVOKEINTERFACE true] - ) - -(def: (invoke//constructor proc generate inputs) - (-> Text @;Proc) - (case inputs - (^ (list& [_ (#;Text class)] argsS)) - (do meta;Monad - [argsTI (generate-args generate argsS)] - (wrap (|>. ($i;NEW class) - $i;DUP - ($i;fuse (list/map product;right argsTI)) - ($i;INVOKESPECIAL class "" - ($t;method (list/map product;left argsTI) #;None (list)) - false)))) - - _ - (&;fail (format "Wrong syntax for '" proc "'.")))) - -(def: member-procs - @;Bundle - (<| (@;prefix "member") - (|> (dict;new text;Hash) - (dict;merge (<| (@;prefix "static") - (|> (dict;new text;Hash) - (@;install "get" static//get) - (@;install "put" static//put)))) - (dict;merge (<| (@;prefix "virtual") - (|> (dict;new text;Hash) - (@;install "get" virtual//get) - (@;install "put" virtual//put)))) - (dict;merge (<| (@;prefix "invoke") - (|> (dict;new text;Hash) - (@;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) - (dict;merge conversion-procs) - (dict;merge int-procs) - (dict;merge long-procs) - (dict;merge float-procs) - (dict;merge double-procs) - (dict;merge char-procs) - (dict;merge array-procs) - (dict;merge object-procs) - (dict;merge member-procs) - ))) diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux deleted file mode 100644 index 9af511167..000000000 --- a/new-luxc/source/luxc/generator/reference.jvm.lux +++ /dev/null @@ -1,31 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (data text/format) - [meta "meta/" Monad]) - (luxc ["&" base] - (host ["$" jvm] - (jvm ["$t" type] - ["$i" inst])) - (lang ["ls" synthesis] - [";L" variable #+ Variable]) - (generator [";G" common] - [";G" function]))) - -(def: #export (generate-captured variable) - (-> Variable (Meta $;Inst)) - (do meta;Monad - [function-class commonG;function] - (wrap (|>. ($i;ALOAD +0) - ($i;GETFIELD function-class - (|> variable i.inc (i.* -1) int-to-nat functionG;captured) - commonG;$Object))))) - -(def: #export (generate-variable variable) - (-> Variable (Meta $;Inst)) - (meta/wrap ($i;ALOAD (int-to-nat variable)))) - -(def: #export (generate-definition [def-module def-name]) - (-> Ident (Meta $;Inst)) - (let [bytecode-name (format def-module "/" (&;normalize-name def-name))] - (meta/wrap ($i;GETSTATIC bytecode-name commonG;value-field commonG;$Object)))) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux deleted file mode 100644 index 4b57e802e..000000000 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ /dev/null @@ -1,608 +0,0 @@ -(;module: - lux - (lux (control monad) - (data text/format - (coll [list "list/" Functor])) - [math] - [meta] - [host]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] - ["ls" synthesis]) - (generator ["&;" common]))) - -(host;import java.lang.Object) -(host;import java.lang.String) - -(host;import java.lang.reflect.Field - (get [Object] #try Object)) - -(host;import (java.lang.Class a) - (getField [String] Field)) - -(host;import org.objectweb.asm.Opcodes - (#static ACC_PUBLIC int) - (#static ACC_SUPER int) - (#static ACC_FINAL int) - (#static ACC_STATIC int) - (#static V1_6 int)) - -(host;import org.objectweb.asm.ClassWriter - (#static COMPUTE_MAXS int) - (new [int]) - (visit [int int String String String (Array String)] void) - (visitEnd [] void) - (toByteArray [] (Array byte))) - -(def: $Object $;Type ($t;class "java.lang.Object" (list))) -(def: $Object-Array $;Type ($t;array +1 $Object)) -(def: $String $;Type ($t;class "java.lang.String" (list))) -(def: #export $Stack $;Type ($t;array +1 $Object)) -(def: #export $Tuple $;Type $Object-Array) -(def: #export $Variant $;Type $Object-Array) -(def: #export $Tag $;Type $t;int) -(def: #export $Flag $;Type $Object) -(def: #export $Datum $;Type $Object) -(def: #export $Function $;Type ($t;class hostL;function-class (list))) -(def: $Throwable $;Type ($t;class "java.lang.Throwable" (list))) - -(def: #export logI - $;Inst - (let [outI ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) - printI (function [method] ($i;INVOKEVIRTUAL "java.io.PrintStream" method ($t;method (list $Object) #;None (list)) false))] - (|>. outI ($i;string "LOG: ") (printI "print") - outI $i;SWAP (printI "println")))) - -(def: variant-method - $;Method - ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list))) - -(def: variantI - $;Inst - ($i;INVOKESTATIC hostL;runtime-class "variant_make" variant-method false)) - -(def: #export leftI - $;Inst - (|>. ($i;int 0) - $i;NULL - $i;DUP2_X1 - $i;POP2 - variantI)) - -(def: #export rightI - $;Inst - (|>. ($i;int 1) - ($i;string "") - $i;DUP2_X1 - $i;POP2 - variantI)) - -(def: #export someI $;Inst rightI) - -(def: #export noneI - $;Inst - (|>. ($i;int 0) - $i;NULL - ($i;string hostL;unit) - variantI)) - -(def: #export string-concatI - $;Inst - ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)) - -(def: #export partials-field Text "partials") -(def: #export apply-method Text "apply") -(def: #export num-apply-variants Nat +8) - -(def: #export (apply-signature arity) - (-> ls;Arity $;Method) - ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) - -(def: adt-methods - $;Def - (let [store-tagI (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE) - store-flagI (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE) - store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE) - force-textMT ($t;method (list $Object) (#;Some $String) (list))] - (|>. ($d;method #$;Public $;staticM "force_text" force-textMT - (<| $i;with-label (function [@is-null]) - $i;with-label (function [@normal-object]) - $i;with-label (function [@array-loop]) - $i;with-label (function [@within-bounds]) - $i;with-label (function [@is-first]) - $i;with-label (function [@elem-end]) - $i;with-label (function [@fold-end]) - (let [on-normal-objectI (|>. ($i;ALOAD +0) - ($i;INVOKEVIRTUAL "java.lang.Object" "toString" ($t;method (list) (#;Some $String) (list)) false)) - on-null-objectI ($i;string "NULL") - arrayI (|>. ($i;ALOAD +0) - ($i;CHECKCAST ($t;descriptor $Object-Array))) - recurseI ($i;INVOKESTATIC hostL;runtime-class "force_text" force-textMT false) - force-elemI (|>. $i;DUP arrayI $i;SWAP $i;AALOAD recurseI) - swap2 (|>. $i;DUP2_X2 ## X,Y => Y,X,Y - $i;POP2 ## Y,X,Y => Y,X - ) - add-spacingI (|>. ($i;string ", ") $i;SWAP string-concatI) - merge-with-totalI (|>. $i;DUP_X2 $i;POP ## TSIP => TPSI - swap2 ## TPSI => SITP - string-concatI ## SITP => SIT - $i;DUP_X2 $i;POP ## SIT => TSI - ) - foldI (|>. $i;DUP ## TSI => TSII - ($i;IFEQ @is-first) ## TSI - force-elemI add-spacingI merge-with-totalI ($i;GOTO @elem-end) - ($i;label @is-first) ## TSI - force-elemI merge-with-totalI - ($i;label @elem-end) ## TSI - ) - inc-idxI (|>. ($i;int 1) $i;IADD) - on-array-objectI (|>. ($i;string "[") ## T - arrayI $i;ARRAYLENGTH ## TS - ($i;int 0) ## TSI - ($i;label @array-loop) ## TSI - $i;DUP2 - ($i;IF_ICMPGT @within-bounds) ## TSI - $i;POP2 ($i;string "]") string-concatI ($i;GOTO @fold-end) - ($i;label @within-bounds) - foldI inc-idxI ($i;GOTO @array-loop) - ($i;label @fold-end))]) - (|>. ($i;ALOAD +0) - ($i;IFNULL @is-null) - ($i;ALOAD +0) - ($i;INSTANCEOF ($t;descriptor $Object-Array)) - ($i;IFEQ @normal-object) - on-array-objectI $i;ARETURN - ($i;label @normal-object) on-normal-objectI $i;ARETURN - ($i;label @is-null) on-null-objectI $i;ARETURN))) - ($d;method #$;Public $;staticM "variant_make" - ($t;method (list $t;int $Object $Object) - (#;Some $Variant) - (list)) - (|>. ($i;int 3) - ($i;array $Object) - store-tagI - store-flagI - store-valueI - $i;ARETURN))))) - -(def: #export force-textI - $;Inst - ($i;INVOKESTATIC hostL;runtime-class "force_text" ($t;method (list $Object) (#;Some $String) (list)) false)) - -(def: nat-methods - $;Def - (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list)) - less-thanI (function [@where] (|>. ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false) ($i;IFLT @where))) - $BigInteger ($t;class "java.math.BigInteger" (list)) - upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list)) - div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)) - upcastI ($i;INVOKESTATIC hostL;runtime-class "_toUnsignedBigInteger" upcast-method false) - downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)] - ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 - (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method - (let [upcastI ($i;INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) - discernI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGE @where))) - prepare-upperI (|>. ($i;LLOAD +0) ($i;int 32) $i;LUSHR - upcastI - ($i;int 32) ($i;INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t;method (list $t;int) (#;Some $BigInteger) (list)) false)) - prepare-lowerI (|>. ($i;LLOAD +0) ($i;int 32) $i;LSHL - ($i;int 32) $i;LUSHR - upcastI)] - (<| $i;with-label (function [@simple]) - (|>. (discernI @simple) - ## else - prepare-upperI - prepare-lowerI - ($i;INVOKEVIRTUAL "java.math.BigInteger" "add" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false) - $i;ARETURN - ## then - ($i;label @simple) - ($i;LLOAD +0) - upcastI - $i;ARETURN)))) - ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 - ($d;method #$;Public $;staticM "compare_nat" compare-nat-method - (let [shiftI (|>. ($i;GETSTATIC "java.lang.Long" "MIN_VALUE" $t;long) $i;LADD)] - (|>. ($i;LLOAD +0) shiftI - ($i;LLOAD +2) shiftI - $i;LCMP - $i;IRETURN))) - ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 - ($d;method #$;Public $;staticM "div_nat" div-method - (let [is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLT @where))) - is-subject-smallI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGT @where))) - small-division (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LDIV $i;LRETURN) - big-divisionI ($i;INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] - (<| $i;with-label (function [@is-zero]) - $i;with-label (function [@param-is-large]) - $i;with-label (function [@subject-is-small]) - (|>. (is-param-largeI @param-is-large) - ## Param is not too large - (is-subject-smallI @subject-is-small) - ## Param is small, but subject is large - ($i;LLOAD +0) upcastI - ($i;LLOAD +2) upcastI - big-divisionI downcastI $i;LRETURN - ## Both param and subject are small, - ## and can thus be divided normally. - ($i;label @subject-is-small) - small-division - ## Param is too large. Cannot simply divide. - ## Depending on the result of the - ## comparison, a result will be determined. - ($i;label @param-is-large) - ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @is-zero) - ## Greater-than or equals - ($i;long 1) $i;LRETURN - ## Less than - ($i;label @is-zero) - ($i;long 0) $i;LRETURN)))) - ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 - ($d;method #$;Public $;staticM "rem_nat" div-method - (let [is-subject-largeI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFLE @where))) - is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLE @where))) - small-remainderI (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LREM $i;LRETURN) - big-remainderI ($i;INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] - (<| $i;with-label (function [@large-number]) - $i;with-label (function [@subject-is-smaller-than-param]) - (|>. (is-subject-largeI @large-number) - (is-param-largeI @large-number) - small-remainderI - - ($i;label @large-number) - ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @subject-is-smaller-than-param) - - ($i;LLOAD +0) upcastI - ($i;LLOAD +2) upcastI - big-remainderI downcastI $i;LRETURN - - ($i;label @subject-is-smaller-than-param) - ($i;LLOAD +0) - $i;LRETURN)))) - ))) - -(def: frac-shiftI $;Inst ($i;double (math;pow 32.0 2.0))) - -(def: frac-methods - $;Def - (|>. ($d;method #$;Public $;staticM "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) - (<| $i;with-label (function [@from]) - $i;with-label (function [@to]) - $i;with-label (function [@handler]) - (|>. ($i;try @from @to @handler "java.lang.Exception") - ($i;label @from) - ($i;ALOAD +0) - ($i;INVOKESTATIC "java.lang.Double" "parseDouble" ($t;method (list $String) (#;Some $t;double) (list)) false) - ($i;wrap #$;Double) - someI - $i;ARETURN - ($i;label @to) - ($i;label @handler) - noneI - $i;ARETURN))) - ($d;method #$;Public $;staticM "frac_to_deg" ($t;method (list $t;double) (#;Some $t;long) (list)) - (let [swap2 (|>. $i;DUP2_X2 $i;POP2) - drop-excessI (|>. ($i;double 1.0) $i;DREM) - shiftI (|>. frac-shiftI $i;DMUL)] - (|>. ($i;DLOAD +0) - ## Get upper half - drop-excessI - shiftI - ## Make a copy, so the lower half can be extracted - $i;DUP2 - ## Get lower half - drop-excessI - shiftI - ## Turn it into a deg - $i;D2L - ## Turn the upper half into deg too - swap2 - $i;D2L - ## Combine both pieces - $i;LADD - ## FINISH - $i;LRETURN - ))) - )) - -(def: deg-bits Nat +64) -(def: deg-method $;Method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))) -(def: clz-method $;Method ($t;method (list $t;long) (#;Some $t;int) (list))) - -(def: deg-methods - $;Def - (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits. - low-half (|>. ($i;int -1) $i;I2L $i;LAND) - high-half (|>. ($i;int 32) $i;LUSHR)] - (|>. ($d;method #$;Public $;staticM "mul_deg" deg-method - ## Based on: http://stackoverflow.com/a/31629280/6823464 - (let [shift-downI (|>. ($i;int 32) $i;LUSHR) - low-leftI (|>. ($i;LLOAD +0) low-half) - high-leftI (|>. ($i;LLOAD +0) high-half) - low-rightI (|>. ($i;LLOAD +2) low-half) - high-rightI (|>. ($i;LLOAD +2) high-half) - bottomI (|>. low-leftI low-rightI $i;LMUL) - middleLI (|>. high-leftI low-rightI $i;LMUL) - middleRI (|>. low-leftI high-rightI $i;LMUL) - middleI (|>. middleLI middleRI $i;LADD) - topI (|>. high-leftI high-rightI $i;LMUL)] - (|>. bottomI shift-downI - middleI $i;LADD shift-downI - topI $i;LADD - $i;LRETURN))) - ($d;method #$;Public $;staticM "count_leading_zeros" clz-method - (let [when-zeroI (function [@where] (|>. ($i;long 0) $i;LCMP ($i;IFEQ @where))) - shift-rightI (function [amount] (|>. ($i;int amount) $i;LUSHR)) - decI (|>. ($i;int 1) $i;ISUB)] - (<| $i;with-label (function [@start]) - $i;with-label (function [@done]) - (|>. ($i;int 64) - ($i;label @start) - ($i;LLOAD +0) (when-zeroI @done) - ($i;LLOAD +0) (shift-rightI 1) ($i;LSTORE +0) - decI - ($i;GOTO @start) - ($i;label @done) - $i;IRETURN)))) - ($d;method #$;Public $;staticM "div_deg" deg-method - (<| $i;with-label (function [@same]) - (let [subjectI ($i;LLOAD +0) - paramI ($i;LLOAD +2) - equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where))) - count-leading-zerosI ($i;INVOKESTATIC hostL;runtime-class "count_leading_zeros" clz-method false) - calc-max-shiftI (|>. subjectI count-leading-zerosI - paramI count-leading-zerosI - ($i;INVOKESTATIC "java.lang.Math" "min" ($t;method (list $t;int $t;int) (#;Some $t;int) (list)) false) - ($i;ISTORE +4)) - shiftI (|>. ($i;ILOAD +4) $i;LSHL) - imprecise-divisionI (|>. subjectI shiftI - paramI shiftI high-half - $i;LDIV) - scale-downI (|>. ($i;int 32) $i;LSHL)] - (|>. subjectI paramI - (equal?I @same) - ## Based on: http://stackoverflow.com/a/8510587/6823464 - ## Shifting the operands as much as possible can help - ## avoid some loss of precision later. - calc-max-shiftI - imprecise-divisionI - scale-downI - $i;LRETURN - ($i;label @same) - ($i;long -1) ## ~= 1.0 Degrees - $i;LRETURN)))) - ($d;method #$;Public $;staticM "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list)) - (let [highI (|>. ($i;LLOAD +0) high-half $i;L2D) - lowI (|>. ($i;LLOAD +0) low-half $i;L2D) - scaleI (|>. frac-shiftI $i;DDIV)] - (|>. highI scaleI - lowI scaleI scaleI - $i;DADD - $i;DRETURN))) - ))) - -(def: pm-methods - $;Def - (let [tuple-sizeI (|>. ($i;ALOAD +0) $i;ARRAYLENGTH) - tuple-elemI (|>. ($i;ALOAD +0) ($i;ILOAD +1) $i;AALOAD) - expected-last-sizeI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD) - tuple-tailI (|>. ($i;ALOAD +0) tuple-sizeI ($i;int 1) $i;ISUB $i;AALOAD ($i;CHECKCAST ($t;descriptor $Tuple)))] - (|>. ($d;method #$;Public $;staticM "pm_fail" ($t;method (list) #;None (list)) - (|>. ($i;NEW "java.lang.IllegalStateException") - $i;DUP - ($i;string "Invalid expression for pattern-matching.") - ($i;INVOKESPECIAL "java.lang.IllegalStateException" "" ($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" "" ($t;method (list $String) #;None (list)) false) - $i;ATHROW)) - ($d;method #$;Public $;staticM "pm_push" ($t;method (list $Stack $Object) (#;Some $Stack) (list)) - (|>. ($i;int 2) - ($i;ANEWARRAY "java.lang.Object") - $i;DUP - ($i;int 0) - ($i;ALOAD +0) - $i;AASTORE - $i;DUP - ($i;int 1) - ($i;ALOAD +1) - $i;AASTORE - $i;ARETURN)) - ($d;method #$;Public $;staticM "pm_pop" ($t;method (list $Stack) (#;Some $Stack) (list)) - (|>. ($i;ALOAD +0) - ($i;int 0) - $i;AALOAD - ($i;CHECKCAST ($t;descriptor $Stack)) - $i;ARETURN)) - ($d;method #$;Public $;staticM "pm_peek" ($t;method (list $Stack) (#;Some $Object) (list)) - (|>. ($i;ALOAD +0) - ($i;int 1) - $i;AALOAD - $i;ARETURN)) - ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Variant $Tag $Flag) (#;Some $Object) (list)) - (<| $i;with-label (function [@begin]) - $i;with-label (function [@just-return]) - $i;with-label (function [@then]) - $i;with-label (function [@further]) - $i;with-label (function [@shorten]) - $i;with-label (function [@wrong]) - (let [variant-partI (: (-> Nat $;Inst) - (function [idx] - (|>. ($i;int (nat-to-int idx)) $i;AALOAD))) - tagI (: $;Inst - (|>. (variant-partI +0) ($i;unwrap #$;Int))) - flagI (variant-partI +1) - datumI (variant-partI +2) - shortenI (|>. ($i;ALOAD +0) tagI ## Get tag - ($i;ILOAD +1) $i;ISUB ## Shorten tag - ($i;ALOAD +0) flagI ## Get flag - ($i;ALOAD +0) datumI ## Get value - variantI ## Build sum - $i;ARETURN) - update-tagI (|>. $i;ISUB ($i;ISTORE +1)) - update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0)) - wrongI (|>. $i;NULL $i;ARETURN) - return-datumI (|>. ($i;ALOAD +0) datumI $i;ARETURN)]) - (|>. ($i;label @begin) - ($i;ILOAD +1) ## tag - ($i;ALOAD +0) tagI ## tag, sumT - $i;DUP2 ($i;IF_ICMPEQ @then) - $i;DUP2 ($i;IF_ICMPGT @further) - $i;DUP2 ($i;IF_ICMPLT @shorten) - ## $i;POP2 - wrongI - ($i;label @then) ## tag, sumT - ($i;ALOAD +2) ## tag, sumT, wants-last? - ($i;ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? - ($i;IF_ACMPEQ @just-return) ## tag, sumT - ($i;label @further) ## tag, sumT - ($i;ALOAD +0) flagI ## tag, sumT, last? - ($i;IFNULL @wrong) ## tag, sumT - update-tagI - update-variantI - ($i;GOTO @begin) - ($i;label @just-return) ## tag, sumT - ## $i;POP2 - return-datumI - ($i;label @shorten) ## tag, sumT - ($i;ALOAD +2) ($i;IFNULL @wrong) - ## $i;POP2 - shortenI - ($i;label @wrong) ## tag, sumT - ## $i;POP2 - wrongI))) - ($d;method #$;Public $;staticM "pm_left" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) - (<| $i;with-label (function [@begin]) - $i;with-label (function [@not-recursive]) - (let [updated-idxI (|>. $i;SWAP $i;ISUB)]) - (|>. ($i;label @begin) - tuple-sizeI - expected-last-sizeI - $i;DUP2 ($i;IF_ICMPGT @not-recursive) - ## Recursive - updated-idxI ($i;ISTORE +1) - tuple-tailI ($i;ASTORE +0) - ($i;GOTO @begin) - ($i;label @not-recursive) - ## $i;POP2 - tuple-elemI - $i;ARETURN))) - ($d;method #$;Public $;staticM "pm_right" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) - (<| $i;with-label (function [@begin]) - $i;with-label (function [@tail]) - $i;with-label (function [@slice]) - (let [updated-idxI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD tuple-sizeI $i;ISUB) - sliceI (|>. ($i;ALOAD +0) ($i;ILOAD +1) tuple-sizeI - ($i;INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t;method (list $Object-Array $t;int $t;int) (#;Some $Object-Array) (list)) false))]) - (|>. ($i;label @begin) - tuple-sizeI - expected-last-sizeI - $i;DUP2 ($i;IF_ICMPEQ @tail) - ($i;IF_ICMPGT @slice) - ## Must recurse - tuple-tailI ($i;ASTORE +0) - updated-idxI ($i;ISTORE +1) - ($i;GOTO @begin) - ($i;label @slice) - sliceI - $i;ARETURN - ($i;label @tail) - ## $i;POP2 - tuple-elemI - $i;ARETURN))) - ))) - -(def: io-methods - $;Def - (let [string-writerI (|>. ($i;NEW "java.io.StringWriter") - $i;DUP - ($i;INVOKESPECIAL "java.io.StringWriter" "" ($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" "" ($t;method (list ($t;class "java.io.Writer" (list)) $t;boolean) #;None (list)) false) - )] - (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list)) - (<| $i;with-label (function [@from]) - $i;with-label (function [@to]) - $i;with-label (function [@handler]) - (|>. ($i;try @from @to @handler "java.lang.Throwable") - ($i;label @from) - ($i;ALOAD +0) - $i;NULL - ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) - rightI - $i;ARETURN - ($i;label @to) - ($i;label @handler) - string-writerI ## TW - $i;DUP2 ## TWTW - print-writerI ## TWTP - ($i;INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t;method (list ($t;class "java.io.PrintWriter" (list))) #;None (list)) false) ## TW - ($i;INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t;method (list) (#;Some $String) (list)) false) ## TS - $i;SWAP $i;POP leftI - $i;ARETURN))) - ))) - -(def: generate-runtime - (Meta &common;Bytecode) - (do meta;Monad - [_ (wrap []) - #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC hostL;runtime-class (list) ["java.lang.Object" (list)] (list) - (|>. adt-methods - nat-methods - frac-methods - deg-methods - pm-methods - io-methods))] - _ (&common;store-class hostL;runtime-class bytecode)] - (wrap bytecode))) - -(def: generate-function - (Meta &common;Bytecode) - (do meta;Monad - [_ (wrap []) - #let [applyI (|> (list;n.range +2 num-apply-variants) - (list/map (function [arity] - ($d;method #$;Public $;noneM apply-method (apply-signature arity) - (let [preI (|> (list;n.range +0 (n.dec arity)) - (list/map $i;ALOAD) - $i;fuse)] - (|>. preI - ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature (n.dec arity)) false) - ($i;CHECKCAST hostL;function-class) - ($i;ALOAD arity) - ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) - $i;ARETURN))))) - (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1))) - $d;fuse) - bytecode ($d;abstract #$;V1.6 #$;Public $;noneC hostL;function-class (list) ["java.lang.Object" (list)] (list) - (|>. ($d;field #$;Public $;finalF partials-field $t;int) - ($d;method #$;Public $;noneM "" ($t;method (list $t;int) #;None (list)) - (|>. ($i;ALOAD +0) - ($i;INVOKESPECIAL "java.lang.Object" "" ($t;method (list) #;None (list)) false) - ($i;ALOAD +0) - ($i;ILOAD +1) - ($i;PUTFIELD hostL;function-class partials-field $t;int) - $i;RETURN)) - applyI))] - _ (&common;store-class hostL;function-class bytecode)] - (wrap bytecode))) - -(def: #export generate - (Meta [&common;Bytecode &common;Bytecode]) - (do meta;Monad - [runtime-bc generate-runtime - function-bc generate-function] - (wrap [runtime-bc function-bc]))) diff --git a/new-luxc/source/luxc/generator/statement.jvm.lux b/new-luxc/source/luxc/generator/statement.jvm.lux deleted file mode 100644 index e91e99fc9..000000000 --- a/new-luxc/source/luxc/generator/statement.jvm.lux +++ /dev/null @@ -1,82 +0,0 @@ -(;module: - lux - (lux (control monad - ["ex" exception #+ exception:]) - (data ["e" error] - [maybe] - [text "text/" Monoid] - text/format - (coll [list "list/" Functor Fold])) - [meta] - [host]) - (luxc ["&" base] - ["&;" scope] - ["&;" module] - ["&;" io] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (generator ["&;" eval] - ["&;" common]))) - -(exception: #export Invalid-Definition-Value) - -(host;import java.lang.Object - (toString [] String)) - -(host;import java.lang.reflect.Field - (get [#? Object] #try #? Object)) - -(host;import (java.lang.Class c) - (getField [String] #try Field)) - -(def: #export (generate-def def-name valueT valueI metaI metaV) - (-> Text Type $;Inst $;Inst Code (Meta Unit)) - (do meta;Monad - [current-module meta;current-module-name - #let [def-ident [current-module def-name] - normal-name (&;normalize-name def-name) - bytecode-name (format current-module "/" normal-name) - class-name (format current-module "." normal-name) - bytecode ($d;class #$;V1.6 - #$;Public $;finalC - bytecode-name - (list) ["java.lang.Object" (list)] - (list) - (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) &common;value-field &common;$Object) - ($d;method #$;Public $;staticM "" ($t;method (list) #;None (list)) - (|>. valueI - ($i;PUTSTATIC bytecode-name &common;value-field &common;$Object) - $i;RETURN))))] - _ (&common;store-class class-name bytecode) - class (&common;load-class class-name) - valueV (: (Meta Top) - (case (do e;Monad - [field (Class.getField [&common;value-field] class)] - (Field.get [#;None] field)) - (#e;Success #;None) - (&;throw Invalid-Definition-Value (format current-module ";" def-name)) - - (#e;Success (#;Some valueV)) - (wrap valueV) - - (#e;Error error) - (&;fail error))) - _ (&module;define [current-module def-name] [valueT metaV valueV]) - _ (if (meta;type? metaV) - (case (meta;declared-tags metaV) - #;Nil - (wrap []) - - tags - (&module;declare-tags tags (meta;export? metaV) (:! Type valueV))) - (wrap [])) - #let [_ (log! (format "DEF " current-module ";" def-name))]] - (&common;record-artifact bytecode-name bytecode))) - -(def: #export (generate-program program-args programI) - (-> Text $;Inst (Meta Unit)) - (do meta;Monad - [] - (&;fail "'lux program' is unimplemented."))) diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux deleted file mode 100644 index 96d5767c6..000000000 --- a/new-luxc/source/luxc/generator/structure.jvm.lux +++ /dev/null @@ -1,59 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do]) - (data text/format - (coll [list])) - [meta] - [host #+ do-to]) - (luxc ["&" base] - [";L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - (lang ["la" analysis] - ["ls" synthesis]) - (generator ["&;" common])) - [../runtime]) - -(def: $Object $;Type ($t;class "java.lang.Object" (list))) - -(def: #export (generate-tuple generate members) - (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst)) - (do meta;Monad - [#let [size (list;size members)] - _ (&;assert "Cannot generate tuples with less than 2 elements." - (n.>= +2 size)) - membersI (|> members - list;enumerate - (monad;map @ (function [[idx member]] - (do @ - [memberI (generate member)] - (wrap (|>. $i;DUP - ($i;int (nat-to-int idx)) - memberI - $i;AASTORE))))) - (:: @ map $i;fuse))] - (wrap (|>. ($i;int (nat-to-int size)) - ($i;array $Object) - membersI)))) - -(def: (flagI tail?) - (-> Bool $;Inst) - (if tail? - ($i;string "") - $i;NULL)) - -(def: #export (generate-variant generate tag tail? member) - (-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst)) - (do meta;Monad - [memberI (generate member)] - (wrap (|>. ($i;int (nat-to-int tag)) - (flagI tail?) - memberI - ($i;INVOKESTATIC hostL;runtime-class - "variant_make" - ($t;method (list $t;int $Object $Object) - (#;Some ($t;array +1 $Object)) - (list)) - false))))) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux index b74c9748c..2cbdf5883 100644 --- a/new-luxc/source/luxc/host.jvm.lux +++ b/new-luxc/source/luxc/host.jvm.lux @@ -11,8 +11,7 @@ [host #+ do-to object] [io]) (luxc ["&" base] - (generator ["&&;" common]) - )) + (lang (translation [";T" common])))) (host;import java.lang.reflect.AccessibleObject (setAccessible [boolean] void)) @@ -48,7 +47,7 @@ (error! error))) (def: (define-class class-name byte-code loader) - (-> Text &&common;Bytecode ClassLoader (e;Error Object)) + (-> Text commonT;Bytecode ClassLoader (e;Error Object)) (Method.invoke [loader (array;from-list (list (:! Object class-name) (:! Object byte-code) @@ -57,11 +56,11 @@ ClassLoader::defineClass)) (def: (fetch-byte-code class-name store) - (-> Text &&common;Class-Store (Maybe &&common;Bytecode)) + (-> Text commonT;Class-Store (Maybe commonT;Bytecode)) (|> store A;get io;run (dict;get class-name))) (def: (memory-class-loader store) - (-> &&common;Class-Store ClassLoader) + (-> commonT;Class-Store ClassLoader) (object ClassLoader [] [] (ClassLoader (findClass [class-name String]) Class @@ -79,13 +78,13 @@ (error! (format "Class not found: " class-name)))))) (def: #export init-host - (io;IO &&common;Host) - (io;io (let [store (: &&common;Class-Store + (io;IO commonT;Host) + (io;io (let [store (: commonT;Class-Store (A;atom (dict;new text;Hash)))] - {#&&common;loader (memory-class-loader store) - #&&common;store store - #&&common;function-class #;None - #&&common;artifacts (dict;new text;Hash)}))) + {#commonT;loader (memory-class-loader store) + #commonT;store store + #commonT;function-class #;None + #commonT;artifacts (dict;new text;Hash)}))) (def: #export class-loader (Meta ClassLoader) @@ -93,8 +92,8 @@ (#e;Success [compiler (|> compiler (get@ #;host) - (:! &&common;Host) - (get@ #&&common;loader))]))) + (:! commonT;Host) + (get@ #commonT;loader))]))) (def: #export runtime-class Text "LuxRuntime") (def: #export function-class Text "LuxFunction") diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux index e3a623089..de0e49dbc 100644 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -11,9 +11,9 @@ [host]) (luxc ["&" base] [";L" host] - (lang ["la" analysis]) - ["&;" module] - (generator [";G" common])) + (lang ["la" analysis] + (translation [";T" common])) + ["&;" module]) (.. [";A" common] [";A" function] [";A" primitive] @@ -37,7 +37,7 @@ (def: (call-macro macro inputs) (-> Macro (List Code) (Meta (List Code))) (do meta;Monad - [class (commonG;load-class hostL;function-class)] + [class (commonT;load-class hostL;function-class)] (function [compiler] (do e;Monad [apply-method (Class.getMethod ["apply" _apply-args] class) diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux new file mode 100644 index 000000000..4fcc3ccb2 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation.lux @@ -0,0 +1,179 @@ +(;module: + lux + (lux (control [monad #+ do]) + (concurrency ["T" task]) + (data ["e" error] + [text "text/" Hash] + text/format + (coll [dict])) + [meta] + [host] + [io] + (world [file #+ File])) + (luxc ["&" base] + [";L" host] + ["&;" io] + ["&;" module] + ["&;" eval] + (lang ["&;" syntax] + (analysis [";A" expression] + [";A" common]) + (synthesis [";S" expression]) + (translation [";T" runtime] + [";T" statement] + [";T" common] + [";T" expression] + [";T" eval])) + )) + +(def: analyse + (&;Analyser) + (expressionA;analyser &eval;eval)) + +(def: (generate code) + (-> Code (Meta Unit)) + (case code + (^ [_ (#;Form (list [_ (#;Text "lux def")] + [_ (#;Symbol ["" def-name])] + valueC + metaC))]) + (do meta;Monad + [[_ metaA] (&;with-scope + (&;with-expected-type Code + (analyse metaC))) + metaI (expressionT;generate (expressionS;synthesize metaA)) + metaV (evalT;eval metaI) + [_ valueT valueA] (&;with-scope + (if (meta;type? (:! Code metaV)) + (&;with-expected-type Type + (do @ + [valueA (analyse valueC)] + (wrap [Type valueA]))) + (commonA;with-unknown-type + (analyse valueC)))) + valueI (expressionT;generate (expressionS;synthesize valueA)) + _ (&;with-scope + (statementT;generate-def def-name valueT valueI metaI (:! Code metaV)))] + (wrap [])) + + (^ [_ (#;Form (list [_ (#;Text "lux program")] + [_ (#;Symbol ["" program-args])] + programC))]) + (do meta;Monad + [[_ programA] (&;with-scope + (&;with-expected-type (type (io;IO Unit)) + (analyse programC))) + programI (expressionT;generate (expressionS;synthesize programA))] + (statementT;generate-program program-args programI)) + + _ + (&;fail (format "Unrecognized statement: " (%code code))))) + +(def: (exhaust action) + (All [a] (-> (Meta a) (Meta Unit))) + (do meta;Monad + [result action] + (exhaust action))) + +(def: prelude Text "lux") + +(def: (with-active-compilation [module-name file-name source-code] action) + (All [a] (-> [Text Text Text] (Meta a) (Meta a))) + (do meta;Monad + [#let [init-cursor [file-name +1 +0]] + output (&;with-source-code [init-cursor +0 source-code] + action) + _ (&module;flag-compiled! module-name)] + (wrap output))) + +(def: parse + (Meta Code) + (function [compiler] + (case (&syntax;parse (get@ #;source compiler)) + (#e;Error error) + (#e;Error error) + + (#e;Success [source' output]) + (#e;Success [(set@ #;source source' compiler) + output])))) + +(def: (generate-module source-dirs module-name target-dir compiler) + (-> (List File) Text File Compiler (T;Task Compiler)) + (do T;Monad + [_ (&io;prepare-module target-dir module-name) + [file-name file-content] (&io;read-module source-dirs module-name) + #let [module-hash (text/hash file-content)]] + (case (meta;run' compiler + (do meta;Monad + [[_ artifacts _] (&module;with-module module-hash module-name + (commonT;with-artifacts + (with-active-compilation [module-name + file-name + file-content] + (exhaust + (do @ + [code parse + #let [[cursor _] code]] + (&;with-cursor cursor + (generate code)))))))] + (wrap artifacts) + ## (&module;generate-descriptor module-name) + )) + (#e;Success [compiler artifacts ## module-descriptor + ]) + (do @ + [## _ (&io;write-module module-name module-descriptor) + _ (monad;map @ (function [[class-name class-bytecode]] + (&io;write-file target-dir class-name class-bytecode)) + (dict;entries artifacts))] + (wrap compiler)) + + (#e;Error error) + (T;fail error)))) + +(def: init-cursor Cursor ["" +1 +0]) + +(def: #export init-type-context + Type-Context + {#;ex-counter +0 + #;var-counter +0 + #;var-bindings (list)}) + +(def: #export init-info + Info + {#;target "JVM" + #;version &;version + #;mode #;Build}) + +(def: #export (init-compiler host) + (-> commonT;Host Compiler) + {#;info init-info + #;source [init-cursor +0 ""] + #;cursor init-cursor + #;current-module #;None + #;modules (list) + #;scopes (list) + #;type-context init-type-context + #;expected #;None + #;seed +0 + #;scope-type-vars (list) + #;host (:! Void host)}) + +(def: #export (generate-program program target sources) + (-> Text File (List File) (T;Task Unit)) + (do T;Monad + [compiler (|> (case (runtimeT;generate (init-compiler (io;run hostL;init-host))) + (#e;Error error) + (T;fail error) + + (#e;Success [compiler [runtime-bc function-bc]]) + (do @ + [_ (&io;prepare-target target) + _ (&io;write-file target hostL;runtime-class runtime-bc) + _ (&io;write-file target hostL;function-class function-bc)] + (wrap compiler))) + (: (T;Task Compiler)) + (:: @ map (generate-module sources prelude target)) (:: @ join) + (:: @ map (generate-module sources program target)) (:: @ join)) + #let [_ (log! "Compilation complete!")]] + (wrap []))) diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux new file mode 100644 index 000000000..a9ea4482a --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux @@ -0,0 +1,225 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data text/format) + [meta "meta/" Monad]) + (luxc ["_" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$i" inst])) + (lang ["ls" synthesis])) + [../runtime]) + +(def: $Object $;Type ($t;class "java.lang.Object" (list))) + +(def: (pop-altI stack-depth) + (-> Nat $;Inst) + (case stack-depth + +0 id + +1 $i;POP + +2 $i;POP2 + _ ## (n.> +2) + (|>. $i;POP2 + (pop-altI (n.- +2 stack-depth))))) + +(def: peekI + $;Inst + (|>. $i;DUP + ($i;INVOKESTATIC hostL;runtime-class + "pm_peek" + ($t;method (list ../runtime;$Stack) + (#;Some $Object) + (list)) + false))) + +(def: popI + $;Inst + (|>. ($i;INVOKESTATIC hostL;runtime-class + "pm_pop" + ($t;method (list ../runtime;$Stack) + (#;Some ../runtime;$Stack) + (list)) + false))) + +(def: pushI + $;Inst + (|>. ($i;INVOKESTATIC hostL;runtime-class + "pm_push" + ($t;method (list ../runtime;$Stack $Object) + (#;Some ../runtime;$Stack) + (list)) + false))) + +(exception: #export Unrecognized-Path) + +(def: (generate-path' generate stack-depth @else @end path) + (-> (-> ls;Synthesis (Meta $;Inst)) + Nat $;Label $;Label ls;Path (Meta $;Inst)) + (case path + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (do meta;Monad + [bodyI (generate bodyS)] + (wrap (|>. (pop-altI stack-depth) + bodyI + ($i;GOTO @end)))) + + (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))]) + (meta/wrap popI) + + (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))]) + (meta/wrap (|>. peekI + ($i;ASTORE register) + popI)) + + [_ (#;Bool value)] + (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)] + (|>. peekI + ($i;unwrap #$;Boolean) + (jumpI @else)))) + + (^template [ ] + [_ ( value)] + (meta/wrap (|>. peekI + ($i;unwrap #$;Long) + ($i;long (|> value )) + $i;LCMP + ($i;IFNE @else)))) + ([#;Nat (:! Int)] + [#;Int (: Int)] + [#;Deg (:! Int)]) + + [_ (#;Frac value)] + (meta/wrap (|>. peekI + ($i;unwrap #$;Double) + ($i;double value) + $i;DCMPL + ($i;IFNE @else))) + + [_ (#;Text value)] + (meta/wrap (|>. peekI + ($i;string value) + ($i;INVOKEVIRTUAL "java.lang.Object" + "equals" + ($t;method (list $Object) + (#;Some $t;boolean) + (list)) + false) + ($i;IFEQ @else))) + + (^template [ ] + (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))]) + (do meta;Monad + [subI (generate-path' generate stack-depth @else @end subP)] + (wrap (case idx + +0 + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int 0) + $i;AALOAD + pushI + subI) + + _ + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int (nat-to-int idx)) + ($i;INVOKESTATIC hostL;runtime-class + + ($t;method (list ../runtime;$Tuple $t;int) + (#;Some $Object) + (list)) + false) + pushI + subI))))) + (["lux case tuple left" "pm_left"] + ["lux case tuple right" "pm_right"]) + + (^template [ ] + (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))]) + (do meta;Monad + [subI (generate-path' generate stack-depth @else @end subP)] + (wrap (<| $i;with-label (function [@success]) + $i;with-label (function [@fail]) + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) + ($i;int (nat-to-int idx)) + + ($i;INVOKESTATIC hostL;runtime-class "pm_variant" + ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) + (#;Some ../runtime;$Datum) + (list)) + false) + $i;DUP + ($i;IFNULL @fail) + ($i;GOTO @success) + ($i;label @fail) + $i;POP + ($i;GOTO @else) + ($i;label @success) + pushI + subI))))) + (["lux case variant left" $i;NULL] + ["lux case variant right" ($i;string "")]) + + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))]) + (do meta;Monad + [leftI (generate-path' generate stack-depth @else @end leftP) + rightI (generate-path' generate stack-depth @else @end rightP)] + (wrap (|>. leftI + rightI))) + + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))]) + (do meta;Monad + [@alt-else $i;make-label + leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP) + rightI (generate-path' generate stack-depth @else @end rightP)] + (wrap (|>. $i;DUP + leftI + ($i;label @alt-else) + $i;POP + rightI))) + + _ + (_;throw Unrecognized-Path (%code path)))) + +(def: (generate-path generate path @end) + (-> (-> ls;Synthesis (Meta $;Inst)) + ls;Path $;Label (Meta $;Inst)) + (do meta;Monad + [@else $i;make-label + pathI (generate-path' generate +1 @else @end path)] + (wrap (|>. pathI + ($i;label @else) + $i;POP + ($i;INVOKESTATIC hostL;runtime-class + "pm_fail" + ($t;method (list) #;None (list)) + false) + $i;NULL + ($i;GOTO @end))))) + +(def: #export (generate-case generate valueS path) + (-> (-> ls;Synthesis (Meta $;Inst)) + ls;Synthesis ls;Path (Meta $;Inst)) + (do meta;Monad + [@end $i;make-label + valueI (generate valueS) + pathI (generate-path generate path @end)] + (wrap (|>. valueI + $i;NULL + $i;SWAP + pushI + pathI + ($i;label @end))))) + +(def: #export (generate-let generate register inputS exprS) + (-> (-> ls;Synthesis (Meta $;Inst)) + Nat ls;Synthesis ls;Synthesis (Meta $;Inst)) + (do meta;Monad + [inputI (generate inputS) + exprI (generate exprS)] + (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 new file mode 100644 index 000000000..1870530c2 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux @@ -0,0 +1,131 @@ +(;module: + [lux #- function] + (lux (control ["ex" exception #+ exception:]) + [io] + (concurrency ["A" atom]) + (data ["e" error] + [text] + text/format + (coll [dict #+ Dict])) + [host] + (world [blob #+ Blob])) + (luxc (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])))) + +(host;import org.objectweb.asm.Opcodes + (#static V1_6 int)) + +(host;import java.lang.Object) + +(host;import (java.lang.Class a)) + +(host;import java.lang.ClassLoader + (loadClass [String] (Class Object))) + +(type: #export Bytecode (host;type (Array byte))) + +(type: #export Class-Store (A;Atom (Dict Text Bytecode))) + +(type: #export Artifacts (Dict Text Blob)) + +(type: #export Host + {#loader ClassLoader + #store Class-Store + #function-class (Maybe Text) + #artifacts Artifacts}) + +(exception: Unknown-Class) +(exception: Class-Already-Stored) +(exception: No-Function-Being-Compiled) +(exception: Cannot-Overwrite-Artifact) + +(def: #export (with-artifacts action) + (All [a] (-> (Meta a) (Meta [Artifacts a]))) + (;function [compiler] + (case (action (update@ #;host + (|>. (:! Host) + (set@ #artifacts (dict;new text;Hash)) + (:! Void)) + compiler)) + (#e;Success [compiler' output]) + (#e;Success [(update@ #;host + (|>. (:! Host) + (set@ #artifacts (|> (get@ #;host compiler) (:! Host) (get@ #artifacts))) + (:! Void)) + compiler') + [(|> compiler' (get@ #;host) (:! Host) (get@ #artifacts)) + output]]) + + (#e;Error error) + (#e;Error error)))) + +(def: #export (record-artifact name content) + (-> Text Blob (Meta Unit)) + (;function [compiler] + (if (|> compiler (get@ #;host) (:! Host) (get@ #artifacts) (dict;contains? name)) + (ex;throw Cannot-Overwrite-Artifact name) + (#e;Success [(update@ #;host + (|>. (:! Host) + (update@ #artifacts (dict;put name content)) + (:! Void)) + compiler) + []])))) + +(def: #export (store-class name byte-code) + (-> Text Bytecode (Meta Unit)) + (;function [compiler] + (let [store (|> (get@ #;host compiler) + (:! Host) + (get@ #store))] + (if (dict;contains? name (|> store A;get io;run)) + (ex;throw Class-Already-Stored name) + (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))]) + )))) + +(def: #export (load-class name) + (-> Text (Meta (Class Object))) + (;function [compiler] + (let [host (:! Host (get@ #;host compiler)) + store (|> host (get@ #store) A;get io;run)] + (if (dict;contains? name store) + (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))]) + (ex;throw Unknown-Class name))))) + +(def: #export (with-function class expr) + (All [a] (-> Text (Meta a) (Meta a))) + (;function [compiler] + (let [host (:! Host (get@ #;host compiler)) + old-function-class (get@ #function-class host)] + (case (expr (set@ #;host + (:! Void (set@ #function-class + (#;Some class) + host)) + compiler)) + (#e;Success [compiler' output]) + (#e;Success [(update@ #;host + (|>. (:! Host) + (set@ #function-class old-function-class) + (:! Void)) + compiler') + output]) + + (#e;Error error) + (#e;Error error))))) + +(def: #export function + (Meta Text) + (;function [compiler] + (let [host (:! Host (get@ #;host compiler))] + (case (get@ #function-class host) + #;None + (ex;throw No-Function-Being-Compiled "") + + (#;Some function-class) + (#e;Success [compiler function-class]))))) + +(def: #export bytecode-version Int Opcodes.V1_6) + +(def: #export value-field Text "_value") +(def: #export $Object $;Type ($t;class "java.lang.Object" (list))) diff --git a/new-luxc/source/luxc/lang/translation/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/eval.jvm.lux new file mode 100644 index 000000000..9514741f8 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/eval.jvm.lux @@ -0,0 +1,80 @@ +(;module: + lux + (lux (control monad) + (data text/format) + [meta] + [host #+ do-to]) + (luxc ["&" base] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + ["ls" synthesis] + (translation [";T" common])) + )) + +(host;import java.lang.Object) +(host;import java.lang.String) + +(host;import java.lang.reflect.Field + (get [Object] Object)) + +(host;import (java.lang.Class a) + (getField [String] Field)) + +(host;import org.objectweb.asm.Opcodes + (#static ACC_PUBLIC int) + (#static ACC_SUPER int) + (#static ACC_FINAL int) + (#static ACC_STATIC int) + (#static PUTSTATIC int) + (#static RETURN int) + (#static V1_6 int) + ) + +(host;import org.objectweb.asm.MethodVisitor + (visitCode [] void) + (visitEnd [] void) + (visitLdcInsn [Object] void) + (visitFieldInsn [int String String String] void) + (visitInsn [int] void) + (visitMaxs [int int] void)) + +(host;import org.objectweb.asm.FieldVisitor + (visitEnd [] void)) + +(host;import org.objectweb.asm.ClassWriter + (#static COMPUTE_MAXS int) + (new [int]) + (visit [int int String String String (Array String)] void) + (visitEnd [] void) + (visitField [int String String String Object] FieldVisitor) + (visitMethod [int String String String (Array String)] MethodVisitor) + (toByteArray [] (Array byte))) + +(def: #export (eval valueI) + (-> $;Inst (Meta Top)) + (do meta;Monad + [class-name (:: @ map %code (meta;gensym "eval")) + #let [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) + "" + ($t;method (list) #;None (list)) + (|>. valueI + ($i;PUTSTATIC class-name commonT;value-field commonT;$Object) + $i;RETURN))) + bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))] + _ (commonT;store-class class-name bytecode) + class (commonT;load-class class-name)] + (wrap (|> class + (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 new file mode 100644 index 000000000..af66d4994 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/expression.jvm.lux @@ -0,0 +1,76 @@ +(;module: + lux + (lux (control monad + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + text/format) + [meta] + (meta ["s" syntax])) + (luxc ["&" base] + (host ["$" jvm]) + (lang ["ls" synthesis] + (translation [";T" common] + [";T" primitive] + [";T" structure] + [";T" eval] + [";T" procedure] + [";T" function] + [";T" reference] + [";T" case]) + [";L" variable #+ Variable Register]))) + +(exception: #export Unrecognized-Synthesis) + +(def: #export (generate synthesis) + (-> ls;Synthesis (Meta $;Inst)) + (case synthesis + (^code []) + primitiveT;generate-unit + + (^code [(~ singleton)]) + (generate singleton) + + (^template [ ] + [_ ( value)] + ( value)) + ([#;Bool primitiveT;generate-bool] + [#;Nat primitiveT;generate-nat] + [#;Int primitiveT;generate-int] + [#;Deg primitiveT;generate-deg] + [#;Frac primitiveT;generate-frac] + [#;Text primitiveT;generate-text]) + + (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Bool last?)]) (~ valueS))) + (structureT;generate-variant generate tag last? valueS) + + (^code [(~@ members)]) + (structureT;generate-tuple generate members) + + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (if (variableL;captured? var) + (referenceT;generate-captured var) + (referenceT;generate-variable var)) + + [_ (#;Symbol definition)] + (referenceT;generate-definition definition) + + (^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ exprS))) + (caseT;generate-let generate register inputS exprS) + + (^code ("lux case" (~ inputS) (~ pathPS))) + (caseT;generate-case generate inputS pathPS) + + (^multi (^code ("lux function" (~ [_ (#;Nat arity)]) [(~@ environment)] (~ bodyS))) + [(s;run environment (p;some s;int)) (#e;Success environment)]) + (functionT;generate-function generate environment arity bodyS) + + (^code ("lux call" (~ functionS) (~@ argsS))) + (functionT;generate-call generate functionS argsS) + + (^code ((~ [_ (#;Text procedure)]) (~@ argsS))) + (procedureT;generate-procedure generate procedure argsS) + + _ + (&;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 new file mode 100644 index 000000000..35c88e4ed --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux @@ -0,0 +1,333 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data text/format + (coll [list "list/" Functor Monoid])) + [meta]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + ["ls" synthesis] + (translation [";T" common] + [";T" runtime]) + [";L" variable #+ Variable]))) + + +(def: arity-field Text "arity") +(def: $Object $;Type ($t;class "java.lang.Object" (list))) + +(do-template [ ] + [(def: #export ( idx) + (-> Nat Text) + (|> idx nat-to-int %i (format )))] + + [captured "c"] + [partial "p"] + ) + +(def: (poly-arg? arity) + (-> ls;Arity Bool) + (n.> +1 arity)) + +(def: (reset-method class) + (-> Text $;Method) + ($t;method (list) (#;Some ($t;class class (list))) (list))) + +(def: (captured-args env) + (-> (List Variable) (List $;Type)) + (list;repeat (list;size env) $Object)) + +(def: (init-method env arity) + (-> (List Variable) ls;Arity $;Method) + (if (poly-arg? arity) + ($t;method (list;concat (list (captured-args env) + (list $t;int) + (list;repeat (n.dec arity) $Object))) + #;None + (list)) + ($t;method (captured-args env) #;None (list)))) + +(def: (implementation-method arity) + ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) + +(def: get-amount-of-partialsI + $;Inst + (|>. ($i;ALOAD +0) + ($i;GETFIELD hostL;function-class runtimeT;partials-field $t;int))) + +(def: (load-fieldI class field) + (-> Text Text $;Inst) + (|>. ($i;ALOAD +0) + ($i;GETFIELD class field $Object))) + +(def: (inputsI start amount) + (-> $;Register Nat $;Inst) + (|> (list;n.range start (n.+ start (n.dec amount))) + (list/map $i;ALOAD) + $i;fuse)) + +(def: (applysI start amount) + (-> $;Register Nat $;Inst) + (let [max-args (n.min amount 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) + (inputsI start max-args) + ($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)) + +(def: (nullsI amount) + (-> Nat $;Inst) + (|> $i;NULL + (list;repeat amount) + $i;fuse)) + +(def: (with-captured env) + (-> (List Variable) $;Def) + (|> (list;enumerate env) + (list/map (function [[env-idx env-source]] + ($d;field #$;Private $;finalF (captured env-idx) $Object))) + $d;fuse)) + +(def: (with-partial arity) + (-> ls;Arity $;Def) + (if (poly-arg? arity) + (|> (list;n.range +0 (n.- +2 arity)) + (list/map (function [idx] + ($d;field #$;Private $;finalF (partial idx) $Object))) + $d;fuse) + id)) + +(def: (instance class arity env) + (-> Text ls;Arity (List Variable) $;Inst) + (let [captureI (|> env + (list/map (function [source] + (if (variableL;captured? source) + ($i;GETFIELD class (captured (variableL;captured-register source)) $Object) + ($i;ALOAD (int-to-nat source))))) + $i;fuse) + argsI (if (poly-arg? arity) + (|> (nullsI (n.dec arity)) + (list ($i;int 0)) + $i;fuse) + id)] + (|>. ($i;NEW class) + $i;DUP + captureI + argsI + ($i;INVOKESPECIAL class "" (init-method env arity) false)))) + +(def: (with-reset class arity env) + (-> Text ls;Arity (List Variable) $;Def) + ($d;method #$;Public $;noneM "reset" (reset-method class) + (if (poly-arg? arity) + (let [env-size (list;size env) + captureI (|> (case env-size + +0 (list) + _ (list;n.range +0 (n.dec env-size))) + (list/map (function [source] + (|>. ($i;ALOAD +0) + ($i;GETFIELD class (captured source) $Object)))) + $i;fuse) + argsI (|> (nullsI (n.dec arity)) + (list ($i;int 0)) + $i;fuse)] + (|>. ($i;NEW class) + $i;DUP + captureI + argsI + ($i;INVOKESPECIAL class "" (init-method env arity) false) + $i;ARETURN)) + (|>. ($i;ALOAD +0) + $i;ARETURN)))) + +(def: (with-implementation arity @begin bodyI) + (-> Nat $;Label $;Inst $;Def) + ($d;method #$;Public $;strictM "impl" (implementation-method arity) + (|>. ($i;label @begin) + bodyI + $i;ARETURN))) + +(def: function-init-method + $;Method + ($t;method (list $t;int) #;None (list))) + +(def: (function-init arity env-size) + (-> ls;Arity Nat $;Inst) + (if (n.= +1 arity) + (|>. ($i;int 0) + ($i;INVOKESPECIAL hostL;function-class "" function-init-method false)) + (|>. ($i;ILOAD (n.inc env-size)) + ($i;INVOKESPECIAL hostL;function-class "" function-init-method false)))) + +(def: (with-init class env arity) + (-> Text (List Variable) ls;Arity $;Def) + (let [env-size (list;size env) + offset-partial (: (-> Nat Nat) + (|>. n.inc (n.+ env-size))) + store-capturedI (|> (case env-size + +0 (list) + _ (list;n.range +0 (n.dec env-size))) + (list/map (function [register] + (|>. ($i;ALOAD +0) + ($i;ALOAD (n.inc register)) + ($i;PUTFIELD class (captured register) $Object)))) + $i;fuse) + store-partialI (if (poly-arg? arity) + (|> (list;n.range +0 (n.- +2 arity)) + (list/map (function [idx] + (let [register (offset-partial idx)] + (|>. ($i;ALOAD +0) + ($i;ALOAD (n.inc register)) + ($i;PUTFIELD class (partial idx) $Object))))) + $i;fuse) + id)] + ($d;method #$;Public $;noneM "" (init-method env arity) + (|>. ($i;ALOAD +0) + (function-init arity env-size) + store-capturedI + store-partialI + $i;RETURN)))) + +(def: (with-apply class env function-arity @begin bodyI apply-arity) + (-> Text (List Variable) ls;Arity $;Label $;Inst ls;Arity + $;Def) + (let [num-partials (n.dec function-arity) + @default ($;new-label []) + @labels (list/map $;new-label (list;repeat num-partials [])) + arity-over-extent (|> (nat-to-int function-arity) (i.- (nat-to-int apply-arity))) + casesI (|> (list/compose @labels (list @default)) + (list;zip2 (list;n.range +0 num-partials)) + (list/map (function [[stage @label]] + (let [load-partialsI (if (n.> +0 stage) + (|> (list;n.range +0 (n.dec stage)) + (list/map (|>. partial (load-fieldI class))) + $i;fuse) + id)] + (cond (i.= arity-over-extent (nat-to-int stage)) + (|>. ($i;label @label) + ($i;ALOAD +0) + (when (n.> +0 stage) + ($i;INVOKEVIRTUAL class "reset" (reset-method class) false)) + load-partialsI + (inputsI +1 apply-arity) + ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + $i;ARETURN) + + (i.> arity-over-extent (nat-to-int stage)) + (let [args-to-completion (|> function-arity (n.- stage)) + args-left (|> apply-arity (n.- args-to-completion))] + (|>. ($i;label @label) + ($i;ALOAD +0) + ($i;INVOKEVIRTUAL class "reset" (reset-method class) false) + load-partialsI + (inputsI +1 args-to-completion) + ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + (applysI (n.inc args-to-completion) args-left) + $i;ARETURN)) + + ## (i.< arity-over-extent (nat-to-int stage)) + (let [env-size (list;size env) + load-capturedI (|> (case env-size + +0 (list) + _ (list;n.range +0 (n.dec env-size))) + (list/map (|>. captured (load-fieldI class))) + $i;fuse)] + (|>. ($i;label @label) + ($i;NEW class) + $i;DUP + load-capturedI + get-amount-of-partialsI + (inc-intI apply-arity) + load-partialsI + (inputsI +1 apply-arity) + (nullsI (|> num-partials (n.- apply-arity) (n.- stage))) + ($i;INVOKESPECIAL class "" (init-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) + @default @labels) + casesI + ($i;INVOKESTATIC hostL;runtime-class "apply_fail" ($t;method (list) #;None (list)) false) + $i;NULL + $i;ARETURN + )))) + +(def: #export (with-function generate class env arity body) + (-> (-> ls;Synthesis (Meta $;Inst)) + Text (List Variable) ls;Arity ls;Synthesis + (Meta [$;Def $;Inst])) + (do meta;Monad + [@begin $i;make-label + bodyI (commonT;with-function class (generate body)) + #let [env-size (list;size env) + applyD (: $;Def + (if (poly-arg? arity) + (|> (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) + bodyI + $i;ARETURN)))) + functionD (: $;Def + (|>. ($d;int-field #$;Public ($_ $;++F $;staticF $;finalF) arity-field (nat-to-int arity)) + (with-captured env) + (with-partial arity) + (with-init class env arity) + (with-reset class arity env) + applyD)) + instanceI (instance class arity env)]] + (wrap [functionD instanceI]))) + +(def: #export (generate-function generate env arity body) + (-> (-> ls;Synthesis (Meta $;Inst)) + (List Variable) ls;Arity ls;Synthesis + (Meta $;Inst)) + (do meta;Monad + [function-class (:: @ map %code (meta;gensym "function")) + [functionD instanceI] (with-function generate function-class env arity body) + _ (commonT;store-class function-class + ($d;class #$;V1.6 #$;Public $;finalC + function-class (list) + ($;simple-class hostL;function-class) (list) + functionD))] + (wrap instanceI))) + +(def: (segment size elems) + (All [a] (-> Nat (List a) (List (List a)))) + (let [[pre post] (list;split size elems)] + (if (list;empty? post) + (list pre) + (list& pre (segment size post))))) + +(def: #export (generate-call generate functionS argsS) + (-> (-> ls;Synthesis (Meta $;Inst)) + ls;Synthesis (List ls;Synthesis) + (Meta $;Inst)) + (do meta;Monad + [functionI (generate functionS) + argsI (monad;map @ generate 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 + applyI)))) diff --git a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux new file mode 100644 index 000000000..72b5f4e9d --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux @@ -0,0 +1,36 @@ +(;module: + lux + (lux (control monad) + (data text/format) + [meta "meta/" Monad]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$i" inst] + ["$t" type])) + (lang ["la" analysis] + ["ls" synthesis] + (translation [";T" common]))) + [../runtime]) + +(def: #export generate-unit + (Meta $;Inst) + (meta/wrap ($i;string hostL;unit))) + +(def: #export (generate-bool value) + (-> Bool (Meta $;Inst)) + (meta/wrap ($i;GETSTATIC "java.lang.Boolean" + (if value "TRUE" "FALSE") + ($t;class "java.lang.Boolean" (list))))) + +(do-template [ ] + [(def: #export ( value) + (-> (Meta $;Inst)) + (meta/wrap (|>. ( value) )))] + + [generate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)] + [generate-int Int $i;long ($i;wrap #$;Long)] + [generate-deg Deg (|>. (:! Int) $i;long) ($i;wrap #$;Long)] + [generate-frac Frac $i;double ($i;wrap #$;Double)] + [generate-text Text $i;string id] + ) diff --git a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux new file mode 100644 index 000000000..973f0e968 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux @@ -0,0 +1,24 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data [maybe] + text/format + (coll [dict]))) + (luxc ["&" base] + (host ["$" jvm]) + (lang ["ls" synthesis])) + (. ["./;" common] + ["./;" host])) + +(def: procedures + ./common;Bundle + (|> ./common;procedures + (dict;merge ./host;procedures))) + +(def: #export (generate-procedure generate name args) + (-> (-> ls;Synthesis (Meta $;Inst)) Text (List ls;Synthesis) + (Meta $;Inst)) + (<| (maybe;default (&;fail (format "Unknown procedure: " (%t name)))) + (do maybe;Monad + [proc (dict;get name procedures)] + (wrap (proc generate 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 new file mode 100644 index 000000000..80becb058 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -0,0 +1,707 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor] + [dict #+ Dict])) + [meta #+ with-gensyms] + (meta [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + ["ls" synthesis] + (translation [";T" runtime])))) + +(host;import java.lang.Long + (#static MIN_VALUE Long) + (#static MAX_VALUE Long)) + +(host;import java.lang.Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double) + (#static NaN Double) + (#static POSITIVE_INFINITY Double) + (#static NEGATIVE_INFINITY Double)) + +## [Types] +(type: #export Generator + (-> ls;Synthesis (Meta $;Inst))) + +(type: #export Proc + (-> Generator (List ls;Synthesis) (Meta $;Inst))) + +(type: #export Bundle + (Dict Text Proc)) + +(syntax: (Vector [size s;nat] elemT) + (wrap (list (` [(~@ (list;repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 $;Inst) $;Inst)) +(type: #export Unary (-> (Vector +1 $;Inst) $;Inst)) +(type: #export Binary (-> (Vector +2 $;Inst) $;Inst)) +(type: #export Trinary (-> (Vector +3 $;Inst) $;Inst)) + +## [Utils] +(def: $Object $;Type ($t;class "java.lang.Object" (list))) +(def: $Object-Array $;Type ($t;array +1 $Object)) +(def: $String $;Type ($t;class "java.lang.String" (list))) +(def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list))) +(def: $Function $;Type ($t;class hostL;function-class (list))) + +(def: #export (install name unnamed) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) + (dict;put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict;entries + (list/map (function [[key val]] [(format prefix " " key) val])) + (dict;from-list text;Hash))) + +(def: (wrong-arity proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong number of arguments for " (%t proc) "\n" + "Expected: " (|> expected nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i))) + +(syntax: (arity: [name s;local-symbol] [arity s;nat]) + (with-gensyms [g!proc g!name g!generate g!inputs] + (do @ + [g!input+ (monad;seq @ (list;repeat arity (meta;gensym "input")))] + (wrap (list (` (def: #export ((~ (code;local-symbol name)) (~ g!proc)) + (-> (-> (;;Vector (~ (code;nat arity)) $;Inst) $;Inst) + (-> Text ;;Proc)) + (function [(~ g!name)] + (function [(~ g!generate) (~ g!inputs)] + (case (~ g!inputs) + (^ (list (~@ g!input+))) + (do meta;Monad + [(~@ (|> g!input+ + (list/map (function [g!input] + (list g!input (` ((~ g!generate) (~ g!input)))))) + list;concat))] + ((~' wrap) ((~ g!proc) [(~@ g!input+)]))) + + (~' _) + (meta;fail (wrong-arity (~ g!name) +1 (list;size (~ g!inputs)))))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +## [Instructions] +(def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long))) +(def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I)) + +(def: (array-writeI arrayI idxI elemI) + (-> $;Inst $;Inst $;Inst + $;Inst) + (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) + $i;DUP + idxI jvm-intI + elemI + $i;AASTORE)) + +(def: (predicateI tester) + (-> (-> $;Label $;Inst) + $;Inst) + (<| $i;with-label (function [@then]) + $i;with-label (function [@end]) + (|>. (tester @then) + ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) + ($i;GOTO @end) + ($i;label @then) + ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) + ($i;label @end) + ))) + +## [Procedures] +## [[Lux]] +(def: (lux//is [leftI rightI]) + Binary + (|>. leftI + rightI + (predicateI $i;IF_ACMPEQ))) + +(def: try-method + $;Method + ($t;method (list $Function) (#;Some $Object-Array) (list))) +(def: (lux//try riskyI) + Unary + (|>. riskyI + ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "try" try-method false))) + +(def: (lux//noop valueI) + Unary + valueI) + +## [[Bits]] +(do-template [ ] + [(def: ( [inputI maskI]) + Binary + (|>. inputI ($i;unwrap #$;Long) + maskI ($i;unwrap #$;Long) + ($i;wrap #$;Long)))] + + [bit//and $i;LAND] + [bit//or $i;LOR] + [bit//xor $i;LXOR] + ) + +(def: (bit//count inputI) + Unary + (|>. inputI ($i;unwrap #$;Long) + ($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false) + lux-intI)) + +(do-template [ ] + [(def: ( [inputI shiftI]) + Binary + (|>. inputI ($i;unwrap #$;Long) + shiftI jvm-intI + + ($i;wrap #$;Long)))] + + [bit//shift-left $i;LSHL] + [bit//shift-right $i;LSHR] + [bit//unsigned-shift-right $i;LUSHR] + ) + +## [[Arrays]] +(def: (array//new lengthI) + Unary + (|>. lengthI jvm-intI ($i;ANEWARRAY ($t;descriptor $Object)))) + +(def: (array//get [arrayI idxI]) + Binary + (<| $i;with-label (function [@is-null]) + $i;with-label (function [@end]) + (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) + idxI jvm-intI + $i;AALOAD + $i;DUP + ($i;IFNULL @is-null) + runtimeT;someI + ($i;GOTO @end) + ($i;label @is-null) + $i;POP + runtimeT;noneI + ($i;label @end)))) + +(def: (array//put [arrayI idxI elemI]) + Trinary + (array-writeI arrayI idxI elemI)) + +(def: (array//remove [arrayI idxI]) + Binary + (array-writeI arrayI idxI $i;NULL)) + +(def: (array//size arrayI) + Unary + (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) + $i;ARRAYLENGTH + lux-intI)) + +## [[Numbers]] +(def: nat-method + $;Method + ($t;method (list $t;long $t;long) (#;Some $t;long) (list))) + +(def: deg-method $;Method nat-method) + +(def: compare-nat-method + $;Method + ($t;method (list $t;long $t;long) (#;Some $t;int) (list))) + +(do-template [ ] + [(def: ( _) + Nullary + (|>. ))] + + [nat//min ($i;long 0) ($i;wrap #$;Long)] + [nat//max ($i;long -1) ($i;wrap #$;Long)] + + [int//min ($i;long Long.MIN_VALUE) ($i;wrap #$;Long)] + [int//max ($i;long Long.MAX_VALUE) ($i;wrap #$;Long)] + + [frac//smallest ($i;double Double.MIN_VALUE) ($i;wrap #$;Double)] + [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) ($i;wrap #$;Double)] + [frac//max ($i;double Double.MAX_VALUE) ($i;wrap #$;Double)] + [frac//not-a-number ($i;double Double.NaN) ($i;wrap #$;Double)] + [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) ($i;wrap #$;Double)] + [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) ($i;wrap #$;Double)] + + [deg//min ($i;long 0) ($i;wrap #$;Long)] + [deg//max ($i;long -1) ($i;wrap #$;Long)] + ) + +(do-template [ ] + [(def: ( [subjectI paramI]) + Binary + (|>. subjectI + paramI + + ))] + + [int//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] + [int//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] + [int//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] + [int//div ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] + [int//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LREM] + + [nat//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] + [nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] + [nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] + [nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long) + ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] + [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) + ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] + + [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD] + [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB] + [frac//mul ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DMUL] + [frac//div ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DDIV] + [frac//rem ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DREM] + + [deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] + [deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] + [deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) + ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] + [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long) + ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)] + [deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] + [deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] + [deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] + ) + +(do-template [ ] + [(do-template [ ] + [(def: ( [subjectI paramI]) + Binary + (|>. subjectI + paramI + + ($i;int ) + (predicateI $i;IF_ICMPEQ)))] + [ 0] + [ -1])] + + [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)] + [int//eq int//lt ($i;unwrap #$;Long) $i;LCMP] + [frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG] + [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)] + ) + +(do-template [ ] + [(def: ( inputI) + Unary + (|>. inputI ))] + + [nat//to-int id id] + [nat//to-char ($i;unwrap #$;Long) + (<| ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false) + $i;I2C $i;L2I)] + + [int//to-nat id id] + [int//to-frac ($i;unwrap #$;Long) (<| ($i;wrap #$;Double) $i;L2D)] + + [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)] + [frac//to-deg ($i;unwrap #$;Double) + (<| ($i;wrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "frac_to_deg" + ($t;method (list $t;double) (#;Some $t;long) (list)) false))] + [frac//encode ($i;unwrap #$;Double) + ($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)] + [frac//decode ($i;CHECKCAST "java.lang.String") + ($i;INVOKESTATIC hostL;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] + + [deg//to-frac ($i;unwrap #$;Long) + (<| ($i;wrap #$;Double) ($i;INVOKESTATIC hostL;runtime-class "deg_to_frac" + ($t;method (list $t;long) (#;Some $t;double) (list)) false))] + ) + +## [[Text]] +(do-template [ ] + [(def: ( inputI) + Unary + (|>. inputI + ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL ($t;method (list) (#;Some ) (list)) false) + ))] + + [text//size "java.lang.String" "length" lux-intI $t;int] + [text//hash "java.lang.Object" "hashCode" lux-intI $t;int] + [text//trim "java.lang.String" "trim" id $String] + [text//upper-case "java.lang.String" "toUpperCase" id $String] + [text//lower-case "java.lang.String" "toLowerCase" id $String] + ) + +(do-template [ ] + [(def: ( [subjectI paramI]) + Binary + (|>. subjectI + paramI + ))] + + [text//eq id id + ($i;INVOKEVIRTUAL "java.lang.Object" "equals" ($t;method (list $Object) (#;Some $t;boolean) (list)) false) + ($i;wrap #$;Boolean)] + [text//lt ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.lang.String" "compareTo" ($t;method (list $String) (#;Some $t;int) (list)) false) + (predicateI $i;IF_ICMPEQ)] + [text//append ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false) + id] + [text//contains? ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false) + ($i;wrap #$;Boolean)] + [text//char ($i;CHECKCAST "java.lang.String") jvm-intI + ($i;INVOKESTATIC hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) + lux-intI] + ) + +(do-template [ ] + [(def: ( [subjectI paramI extraI]) + Trinary + (|>. subjectI + paramI + extraI + ))] + + [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI + ($i;INVOKESTATIC hostL;runtime-class "text_clip" + ($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)] + [text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)] + ) + +(def: index-method $;Method ($t;method (list $String $t;int) (#;Some $t;int) (list))) +(do-template [ ] + [(def: ( [textI partI startI]) + Trinary + (<| $i;with-label (function [@not-found]) + $i;with-label (function [@end]) + (|>. textI ($i;CHECKCAST "java.lang.String") + partI ($i;CHECKCAST "java.lang.String") + startI jvm-intI + ($i;INVOKEVIRTUAL "java.lang.String" 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))))] + + [text//index "indexOf"] + [text//last-index "lastIndexOf"] + ) + +## [[Math]] +(def: math-unary-method ($t;method (list $t;double) (#;Some $t;double) (list))) +(def: math-binary-method ($t;method (list $t;double $t;double) (#;Some $t;double) (list))) + +(do-template [ ] + [(def: ( inputI) + Unary + (|>. inputI + ($i;unwrap #$;Double) + ($i;INVOKESTATIC "java.lang.Math" math-unary-method false) + ($i;wrap #$;Double)))] + + [math//cos "cos"] + [math//sin "sin"] + [math//tan "tan"] + [math//acos "acos"] + [math//asin "asin"] + [math//atan "atan"] + [math//cosh "cosh"] + [math//sinh "sinh"] + [math//tanh "tanh"] + [math//exp "exp"] + [math//log "log"] + [math//root2 "sqrt"] + [math//root3 "cbrt"] + [math//ceil "ceil"] + [math//floor "floor"] + ) + +(do-template [ ] + [(def: ( [inputI paramI]) + Binary + (|>. inputI ($i;unwrap #$;Double) + paramI ($i;unwrap #$;Double) + ($i;INVOKESTATIC "java.lang.Math" math-binary-method false) + ($i;wrap #$;Double)))] + + [math//atan2 "atan2"] + [math//pow "pow"] + ) + +(def: (math//round inputI) + Unary + (|>. inputI + ($i;unwrap #$;Double) + ($i;INVOKESTATIC "java.lang.Math" "round" ($t;method (list $t;double) (#;Some $t;long) (list)) false) + $i;L2D + ($i;wrap #$;Double))) + +## [[IO]] +(def: string-method $;Method ($t;method (list $String) #;None (list))) +(def: (io//log messageI) + Unary + (|>. ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) + messageI + ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) + ($i;string hostL;unit))) + +(def: (io//error messageI) + Unary + (|>. ($i;NEW "java.lang.Error") + $i;DUP + messageI + ($i;CHECKCAST "java.lang.String") + ($i;INVOKESPECIAL "java.lang.Error" "" string-method false) + $i;ATHROW)) + +(def: (io//exit codeI) + Unary + (|>. codeI jvm-intI + ($i;INVOKESTATIC "java.lang.System" "exit" ($t;method (list $t;int) #;None (list)) false) + $i;NULL)) + +(def: (io//current-time []) + Nullary + (|>. ($i;INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t;method (list) (#;Some $t;long) (list)) false) + ($i;wrap #$;Long))) + +## [[Atoms]] +(def: atom-class Text "java.util.concurrent.atomic.AtomicReference") +(def: (atom//new initI) + Unary + (|>. ($i;NEW atom-class) + $i;DUP + initI + ($i;INVOKESPECIAL atom-class "" ($t;method (list $Object) #;None (list)) false))) + +(def: (atom//read atomI) + Unary + (|>. atomI + ($i;CHECKCAST atom-class) + ($i;INVOKEVIRTUAL atom-class "get" ($t;method (list) (#;Some $Object) (list)) false))) + +(def: (atom//compare-and-swap [atomI oldI newI]) + Trinary + (|>. atomI + ($i;CHECKCAST atom-class) + oldI + newI + ($i;INVOKEVIRTUAL atom-class "compareAndSet" ($t;method (list $Object $Object) (#;Some $t;boolean) (list)) false) + ($i;wrap #$;Boolean))) + +## [[Processes]] +(def: (process//concurrency-level []) + Nullary + (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int) + lux-intI)) + +(def: (process//future procedureI) + Unary + (|>. procedureI ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "future" + ($t;method (list $Function) (#;Some $Object) (list)) false))) + +(def: (process//schedule [millisecondsI procedureI]) + Binary + (|>. millisecondsI ($i;unwrap #$;Long) + procedureI ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "schedule" + ($t;method (list $t;long $Function) (#;Some $Object) (list)) false))) + +## [Bundles] +(def: lux-procs + Bundle + (|> (dict;new text;Hash) + (install "lux noop" (unary lux//noop)) + (install "lux is" (binary lux//is)) + (install "lux try" (unary lux//try)))) + +(def: bit-procs + Bundle + (|> (dict;new text;Hash) + (install "bit count" (unary bit//count)) + (install "bit and" (binary bit//and)) + (install "bit or" (binary bit//or)) + (install "bit xor" (binary bit//xor)) + (install "bit shift-left" (binary bit//shift-left)) + (install "bit unsigned-shift-right" (binary bit//unsigned-shift-right)) + (install "bit shift-right" (binary bit//shift-right)) + )) + +(def: nat-procs + Bundle + (|> (dict;new text;Hash) + (install "nat +" (binary nat//add)) + (install "nat -" (binary nat//sub)) + (install "nat *" (binary nat//mul)) + (install "nat /" (binary nat//div)) + (install "nat %" (binary nat//rem)) + (install "nat =" (binary nat//eq)) + (install "nat <" (binary nat//lt)) + (install "nat min" (nullary nat//min)) + (install "nat max" (nullary nat//max)) + (install "nat to-int" (unary nat//to-int)) + (install "nat to-char" (unary nat//to-char)))) + +(def: int-procs + Bundle + (|> (dict;new text;Hash) + (install "int +" (binary int//add)) + (install "int -" (binary int//sub)) + (install "int *" (binary int//mul)) + (install "int /" (binary int//div)) + (install "int %" (binary int//rem)) + (install "int =" (binary int//eq)) + (install "int <" (binary int//lt)) + (install "int min" (nullary int//min)) + (install "int max" (nullary int//max)) + (install "int to-nat" (unary int//to-nat)) + (install "int to-frac" (unary int//to-frac)))) + +(def: deg-procs + Bundle + (|> (dict;new text;Hash) + (install "deg +" (binary deg//add)) + (install "deg -" (binary deg//sub)) + (install "deg *" (binary deg//mul)) + (install "deg /" (binary deg//div)) + (install "deg %" (binary deg//rem)) + (install "deg =" (binary deg//eq)) + (install "deg <" (binary deg//lt)) + (install "deg scale" (binary deg//scale)) + (install "deg reciprocal" (binary deg//reciprocal)) + (install "deg min" (nullary deg//min)) + (install "deg max" (nullary deg//max)) + (install "deg to-frac" (unary deg//to-frac)))) + +(def: frac-procs + Bundle + (|> (dict;new text;Hash) + (install "frac +" (binary frac//add)) + (install "frac -" (binary frac//sub)) + (install "frac *" (binary frac//mul)) + (install "frac /" (binary frac//div)) + (install "frac %" (binary frac//rem)) + (install "frac =" (binary frac//eq)) + (install "frac <" (binary frac//lt)) + (install "frac smallest" (nullary frac//smallest)) + (install "frac min" (nullary frac//min)) + (install "frac max" (nullary frac//max)) + (install "frac not-a-number" (nullary frac//not-a-number)) + (install "frac positive-infinity" (nullary frac//positive-infinity)) + (install "frac negative-infinity" (nullary frac//negative-infinity)) + (install "frac to-deg" (unary frac//to-deg)) + (install "frac to-int" (unary frac//to-int)) + (install "frac encode" (unary frac//encode)) + (install "frac decode" (unary frac//decode)))) + +(def: text-procs + Bundle + (|> (dict;new text;Hash) + (install "text =" (binary text//eq)) + (install "text <" (binary text//lt)) + (install "text append" (binary text//append)) + (install "text index" (trinary text//index)) + (install "text size" (unary text//size)) + (install "text hash" (unary text//hash)) + (install "text replace" (trinary text//replace)) + (install "text char" (binary text//char)) + (install "text clip" (trinary text//clip)) + )) + +(def: array-procs + Bundle + (|> (dict;new text;Hash) + (install "array new" (unary array//new)) + (install "array get" (binary array//get)) + (install "array put" (trinary array//put)) + (install "array remove" (binary array//remove)) + (install "array size" (unary array//size)) + )) + +(def: math-procs + Bundle + (|> (dict;new text;Hash) + (install "math cos" (unary math//cos)) + (install "math sin" (unary math//sin)) + (install "math tan" (unary math//tan)) + (install "math acos" (unary math//acos)) + (install "math asin" (unary math//asin)) + (install "math atan" (unary math//atan)) + (install "math cosh" (unary math//cosh)) + (install "math sinh" (unary math//sinh)) + (install "math tanh" (unary math//tanh)) + (install "math exp" (unary math//exp)) + (install "math log" (unary math//log)) + (install "math root2" (unary math//root2)) + (install "math root3" (unary math//root3)) + (install "math ceil" (unary math//ceil)) + (install "math floor" (unary math//floor)) + (install "math round" (unary math//round)) + (install "math atan2" (binary math//atan2)) + (install "math pow" (binary math//pow)) + )) + +(def: io-procs + Bundle + (|> (dict;new text;Hash) + (install "io log" (unary io//log)) + (install "io error" (unary io//error)) + (install "io exit" (unary io//exit)) + (install "io current-time" (nullary io//current-time)))) + +(def: atom-procs + Bundle + (|> (dict;new text;Hash) + (install "atom new" (unary atom//new)) + (install "atom read" (unary atom//read)) + (install "atom compare-and-swap" (trinary atom//compare-and-swap)))) + +(def: process-procs + Bundle + (|> (dict;new text;Hash) + (install "process concurrency-level" (nullary process//concurrency-level)) + (install "process future" (unary process//future)) + (install "process schedule" (binary process//schedule)) + )) + +(def: #export procedures + Bundle + (|> (dict;new text;Hash) + (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 new file mode 100644 index 000000000..c222e42cf --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux @@ -0,0 +1,761 @@ +(;module: + lux + (lux (control [monad #+ do] + ["p" parser "parser/" Monad] + ["ex" exception #+ exception:]) + (data [product] + ["e" error] + [text "text/" Eq] + (text format + ["l" lexer]) + (coll [list "list/" Functor] + [dict #+ Dict])) + [meta #+ with-gensyms "meta/" Monad] + (meta [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + (analysis (procedure ["&;" host])) + ["ls" synthesis])) + ["@" ../common]) + +(do-template [ ] + [(def: + $;Inst + )] + + [L2S (|>. $i;L2I $i;I2S)] + [L2B (|>. $i;L2I $i;I2B)] + [L2C (|>. $i;L2I $i;I2C)] + ) + +(do-template [ ] + [(def: ( inputI) + @;Unary + (if (is $i;NOP ) + (|>. inputI + ($i;unwrap ) + ($i;wrap )) + (|>. inputI + ($i;unwrap ) + + ($i;wrap ))))] + + [convert//double-to-float #$;Double $i;D2F #$;Float] + [convert//double-to-int #$;Double $i;D2I #$;Int] + [convert//double-to-long #$;Double $i;D2L #$;Long] + [convert//float-to-double #$;Float $i;F2D #$;Double] + [convert//float-to-int #$;Float $i;F2I #$;Int] + [convert//float-to-long #$;Float $i;F2L #$;Long] + [convert//int-to-byte #$;Int $i;I2B #$;Byte] + [convert//int-to-char #$;Int $i;I2C #$;Char] + [convert//int-to-double #$;Int $i;I2D #$;Double] + [convert//int-to-float #$;Int $i;I2F #$;Float] + [convert//int-to-long #$;Int $i;I2L #$;Long] + [convert//int-to-short #$;Int $i;I2S #$;Short] + [convert//long-to-double #$;Long $i;L2D #$;Double] + [convert//long-to-float #$;Long $i;L2F #$;Float] + [convert//long-to-int #$;Long $i;L2I #$;Int] + [convert//long-to-short #$;Long L2S #$;Short] + [convert//long-to-byte #$;Long L2B #$;Byte] + [convert//long-to-char #$;Long L2C #$;Char] + [convert//char-to-byte #$;Char $i;I2B #$;Byte] + [convert//char-to-short #$;Char $i;I2S #$;Short] + [convert//char-to-int #$;Char $i;NOP #$;Int] + [convert//char-to-long #$;Char $i;I2L #$;Long] + [convert//byte-to-long #$;Byte $i;I2L #$;Long] + [convert//short-to-long #$;Short $i;I2L #$;Long] + ) + +(def: conversion-procs + @;Bundle + (<| (@;prefix "convert") + (|> (dict;new text;Hash) + (@;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 [ ] + [(def: ( [xI yI]) + @;Binary + (|>. xI ($i;unwrap ) + yI ($i;unwrap ) + ($i;wrap )))] + + [int//+ $i;IADD #$;Int #$;Int #$;Int] + [int//- $i;ISUB #$;Int #$;Int #$;Int] + [int//* $i;IMUL #$;Int #$;Int #$;Int] + [int/// $i;IDIV #$;Int #$;Int #$;Int] + [int//% $i;IREM #$;Int #$;Int #$;Int] + [int//and $i;IAND #$;Int #$;Int #$;Int] + [int//or $i;IOR #$;Int #$;Int #$;Int] + [int//xor $i;IXOR #$;Int #$;Int #$;Int] + [int//shl $i;ISHL #$;Int #$;Int #$;Int] + [int//shr $i;ISHR #$;Int #$;Int #$;Int] + [int//ushr $i;IUSHR #$;Int #$;Int #$;Int] + + [long//+ $i;LADD #$;Long #$;Long #$;Long] + [long//- $i;LSUB #$;Long #$;Long #$;Long] + [long//* $i;LMUL #$;Long #$;Long #$;Long] + [long/// $i;LDIV #$;Long #$;Long #$;Long] + [long//% $i;LREM #$;Long #$;Long #$;Long] + [long//and $i;LAND #$;Long #$;Long #$;Long] + [long//or $i;LOR #$;Long #$;Long #$;Long] + [long//xor $i;LXOR #$;Long #$;Long #$;Long] + [long//shl $i;LSHL #$;Long #$;Int #$;Long] + [long//shr $i;LSHR #$;Long #$;Int #$;Long] + [long//ushr $i;LUSHR #$;Long #$;Int #$;Long] + + [float//+ $i;FADD #$;Float #$;Float #$;Float] + [float//- $i;FSUB #$;Float #$;Float #$;Float] + [float//* $i;FMUL #$;Float #$;Float #$;Float] + [float/// $i;FDIV #$;Float #$;Float #$;Float] + [float//% $i;FREM #$;Float #$;Float #$;Float] + + [double//+ $i;DADD #$;Double #$;Double #$;Double] + [double//- $i;DSUB #$;Double #$;Double #$;Double] + [double//* $i;DMUL #$;Double #$;Double #$;Double] + [double/// $i;DDIV #$;Double #$;Double #$;Double] + [double//% $i;DREM #$;Double #$;Double #$;Double] + ) + +(do-template [ ] + [(def: ( [xI yI]) + @;Binary + (<| $i;with-label (function [@then]) + $i;with-label (function [@end]) + (|>. xI ($i;unwrap ) + yI ($i;unwrap ) + ( @then) + ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) + ($i;GOTO @end) + ($i;label @then) + ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) + ($i;label @end))))] + + [int//= $i;IF_ICMPEQ #$;Int #$;Int #$;Boolean] + [int//< $i;IF_ICMPLT #$;Int #$;Int #$;Boolean] + + [char//= $i;IF_ICMPEQ #$;Char #$;Char #$;Boolean] + [char//< $i;IF_ICMPLT #$;Char #$;Char #$;Boolean] + ) + +(do-template [ ] + [(def: ( [xI yI]) + @;Binary + (<| $i;with-label (function [@then]) + $i;with-label (function [@end]) + (|>. xI ($i;unwrap ) + yI ($i;unwrap ) + + ($i;int ) + ($i;IF_ICMPEQ @then) + ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) + ($i;GOTO @end) + ($i;label @then) + ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) + ($i;label @end))))] + + [long//= $i;LCMP 0 #$;Long #$;Long #$;Boolean] + [long//< $i;LCMP -1 #$;Long #$;Long #$;Boolean] + + [float//= $i;FCMPG 0 #$;Float #$;Float #$;Boolean] + [float//< $i;FCMPG -1 #$;Float #$;Float #$;Boolean] + + [double//= $i;DCMPG 0 #$;Double #$;Double #$;Boolean] + [double//< $i;DCMPG -1 #$;Double #$;Double #$;Boolean] + ) + +(def: int-procs + @;Bundle + (<| (@;prefix "int") + (|> (dict;new text;Hash) + (@;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) + (@;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) + (@;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) + (@;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) + (@;install "=" (@;binary char//=)) + (@;install "<" (@;binary char//<)) + ))) + +(def: (array//length arrayI) + @;Unary + (|>. arrayI + $i;ARRAYLENGTH + $i;I2L + ($i;wrap #$;Long))) + +(def: (array//new proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS)) + (do meta;Monad + [lengthI (generate lengthS) + #let [arrayJT ($t;array level (case class + "boolean" $t;boolean + "byte" $t;byte + "short" $t;short + "int" $t;int + "long" $t;long + "float" $t;float + "double" $t;double + "char" $t;char + _ ($t;class class (list))))]] + (wrap (|>. lengthI + ($i;unwrap #$;Long) + $i;L2I + ($i;array arrayJT)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (array//read proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] idxS arrayS)) + (do meta;Monad + [arrayI (generate arrayS) + idxI (generate idxS) + #let [loadI (case class + "boolean" (|>. $i;BALOAD ($i;wrap #$;Boolean)) + "byte" (|>. $i;BALOAD ($i;wrap #$;Byte)) + "short" (|>. $i;SALOAD ($i;wrap #$;Short)) + "int" (|>. $i;IALOAD ($i;wrap #$;Int)) + "long" (|>. $i;LALOAD ($i;wrap #$;Long)) + "float" (|>. $i;FALOAD ($i;wrap #$;Float)) + "double" (|>. $i;DALOAD ($i;wrap #$;Double)) + "char" (|>. $i;CALOAD ($i;wrap #$;Char)) + _ $i;AALOAD)]] + (wrap (|>. arrayI + idxI + ($i;unwrap #$;Long) + $i;L2I + loadI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (array//write proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] idxS valueS arrayS)) + (do meta;Monad + [arrayI (generate arrayS) + idxI (generate idxS) + valueI (generate valueS) + #let [storeI (case class + "boolean" (|>. ($i;unwrap #$;Boolean) $i;BASTORE) + "byte" (|>. ($i;unwrap #$;Byte) $i;BASTORE) + "short" (|>. ($i;unwrap #$;Short) $i;SASTORE) + "int" (|>. ($i;unwrap #$;Int) $i;IASTORE) + "long" (|>. ($i;unwrap #$;Long) $i;LASTORE) + "float" (|>. ($i;unwrap #$;Float) $i;FASTORE) + "double" (|>. ($i;unwrap #$;Double) $i;DASTORE) + "char" (|>. ($i;unwrap #$;Char) $i;CASTORE) + _ $i;AASTORE)]] + (wrap (|>. arrayI + $i;DUP + idxI + ($i;unwrap #$;Long) + $i;L2I + valueI + storeI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: array-procs + @;Bundle + (<| (@;prefix "array") + (|> (dict;new text;Hash) + (@;install "length" (@;unary array//length)) + (@;install "new" array//new) + (@;install "read" array//read) + (@;install "write" array//write) + ))) + +(def: (object//null _) + @;Nullary + $i;NULL) + +(def: (object//null? objectI) + @;Unary + (<| $i;with-label (function [@then]) + $i;with-label (function [@end]) + (|>. objectI + ($i;IFNULL @then) + ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) + ($i;GOTO @end) + ($i;label @then) + ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) + ($i;label @end)))) + +(def: (object//synchronized [monitorI exprI]) + @;Binary + (|>. monitorI + $i;DUP + $i;MONITORENTER + exprI + $i;SWAP + $i;MONITOREXIT)) + +(def: (object//throw exceptionI) + @;Unary + (|>. exceptionI + $i;ATHROW)) + +(def: (object//class proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)])) + (do meta;Monad + [] + (wrap (|>. ($i;string class) + ($i;INVOKESTATIC "java.lang.Class" "forName" + ($t;method (list ($t;class "java.lang.String" (list))) + (#;Some ($t;class "java.lang.Class" (list))) + (list)) + false)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (object//instance? proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] objectS)) + (do meta;Monad + [objectI (generate objectS)] + (wrap (|>. objectI + ($i;INSTANCEOF class) + ($i;wrap #$;Boolean)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: object-procs + @;Bundle + (<| (@;prefix "object") + (|> (dict;new text;Hash) + (@;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))) + +(def: (static//get proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)])) + (do meta;Monad + [] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. ($i;GETSTATIC class field (#$;Primitive primitive)) + ($i;wrap primitive)))) + + #;None + (wrap ($i;GETSTATIC class field ($t;class unboxed (list)))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (static//put proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS)) + (do meta;Monad + [valueI (generate valueS)] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. valueI + ($i;unwrap primitive) + ($i;PUTSTATIC class field (#$;Primitive primitive)) + ($i;string hostL;unit)))) + + #;None + (wrap (|>. valueI + ($i;CHECKCAST class) + ($i;PUTSTATIC class field ($t;class class (list))) + ($i;string hostL;unit))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (virtual//get proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS)) + (do meta;Monad + [objectI (generate objectS)] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. objectI + ($i;CHECKCAST class) + ($i;GETFIELD class field (#$;Primitive primitive)) + ($i;wrap primitive)))) + + #;None + (wrap (|>. objectI + ($i;CHECKCAST class) + ($i;GETFIELD class field ($t;class unboxed (list))))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (virtual//put proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS)) + (do meta;Monad + [valueI (generate valueS) + objectI (generate objectS)] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. objectI + ($i;CHECKCAST class) + $i;DUP + valueI + ($i;unwrap primitive) + ($i;PUTFIELD class field (#$;Primitive primitive))))) + + #;None + (wrap (|>. objectI + ($i;CHECKCAST class) + $i;DUP + valueI + ($i;CHECKCAST unboxed) + ($i;PUTFIELD class field ($t;class unboxed (list))))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(exception: #export Invalid-Syntax-For-Argument-Generation) + +(def: base-type + (l;Lexer $;Type) + ($_ p;either + (p;after (l;this "boolean") (parser/wrap $t;boolean)) + (p;after (l;this "byte") (parser/wrap $t;byte)) + (p;after (l;this "short") (parser/wrap $t;short)) + (p;after (l;this "int") (parser/wrap $t;int)) + (p;after (l;this "long") (parser/wrap $t;long)) + (p;after (l;this "float") (parser/wrap $t;float)) + (p;after (l;this "double") (parser/wrap $t;double)) + (p;after (l;this "char") (parser/wrap $t;char)) + (parser/map (function [name] + ($t;class name (list))) + (l;many (l;none-of "["))) + )) + +(def: java-type + (l;Lexer $;Type) + (do p;Monad + [raw base-type + nesting (p;some (l;this "[]"))] + (wrap ($t;array (list;size nesting) raw)))) + +(def: (generate-type argD) + (-> Text (Meta $;Type)) + (case (l;run argD java-type) + (#e;Error error) + (&;fail error) + + (#e;Success type) + (meta/wrap type))) + +(def: (prepare-input inputT inputI) + (-> $;Type $;Inst $;Inst) + (case inputT + (#$;Primitive primitive) + (|>. inputI ($i;unwrap primitive)) + + (#$;Generic generic) + (case generic + (^or (#$;Var _) (#$;Wildcard _)) + (|>. inputI ($i;CHECKCAST "java.lang.Object")) + + (#$;Class class-name _) + (|>. inputI ($i;CHECKCAST class-name))) + + _ + (|>. inputI ($i;CHECKCAST ($t;descriptor inputT))))) + +(def: (generate-args generate argsS) + (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) + (Meta (List [$;Type $;Inst]))) + (case argsS + #;Nil + (meta/wrap #;Nil) + + (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail)) + (do meta;Monad + [argT (generate-type argD) + argI (:: @ map (prepare-input argT) (generate argS)) + =tail (generate-args generate tail)] + (wrap (list& [argT argI] =tail))) + + _ + (&;throw Invalid-Syntax-For-Argument-Generation ""))) + +(def: (method-return-type description) + (-> Text (Meta (Maybe $;Type))) + (case description + "void" + (meta/wrap #;None) + + _ + (:: meta;Monad map (|>. #;Some) (generate-type description)))) + +(def: (prepare-return returnT returnI) + (-> (Maybe $;Type) $;Inst $;Inst) + (case returnT + #;None + (|>. returnI + ($i;string hostL;unit)) + + (#;Some type) + (case type + (#$;Primitive primitive) + (|>. returnI ($i;wrap primitive)) + + _ + returnI))) + +(def: (invoke//static proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list& [_ (#;Text class)] [_ (#;Text method)] + [_ (#;Text unboxed)] argsS)) + (do meta;Monad + [argsTI (generate-args generate argsS) + returnT (method-return-type unboxed) + #let [callI (|>. ($i;fuse (list/map product;right argsTI)) + ($i;INVOKESTATIC class method + ($t;method (list/map product;left argsTI) returnT (list)) + false))]] + (wrap (prepare-return returnT callI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(do-template [ ] + [(def: ( proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list& [_ (#;Text class)] [_ (#;Text method)] + [_ (#;Text unboxed)] objectS argsS)) + (do meta;Monad + [objectI (generate objectS) + argsTI (generate-args generate argsS) + returnT (method-return-type unboxed) + #let [callI (|>. objectI + ($i;CHECKCAST class) + ($i;fuse (list/map product;right argsTI)) + ( class method + ($t;method (list/map product;left argsTI) returnT (list)) + ))]] + (wrap (prepare-return returnT callI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))] + + [invoke//virtual $i;INVOKEVIRTUAL false] + [invoke//special $i;INVOKESPECIAL false] + [invoke//interface $i;INVOKEINTERFACE true] + ) + +(def: (invoke//constructor proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list& [_ (#;Text class)] argsS)) + (do meta;Monad + [argsTI (generate-args generate argsS)] + (wrap (|>. ($i;NEW class) + $i;DUP + ($i;fuse (list/map product;right argsTI)) + ($i;INVOKESPECIAL class "" + ($t;method (list/map product;left argsTI) #;None (list)) + false)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: member-procs + @;Bundle + (<| (@;prefix "member") + (|> (dict;new text;Hash) + (dict;merge (<| (@;prefix "static") + (|> (dict;new text;Hash) + (@;install "get" static//get) + (@;install "put" static//put)))) + (dict;merge (<| (@;prefix "virtual") + (|> (dict;new text;Hash) + (@;install "get" virtual//get) + (@;install "put" virtual//put)))) + (dict;merge (<| (@;prefix "invoke") + (|> (dict;new text;Hash) + (@;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) + (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 new file mode 100644 index 000000000..7c42f9f08 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux @@ -0,0 +1,31 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data text/format) + [meta "meta/" Monad]) + (luxc ["&" base] + (host ["$" jvm] + (jvm ["$t" type] + ["$i" inst])) + (lang ["ls" synthesis] + [";L" variable #+ Variable] + (translation [";T" common] + [";T" function])))) + +(def: #export (generate-captured variable) + (-> Variable (Meta $;Inst)) + (do meta;Monad + [function-class commonT;function] + (wrap (|>. ($i;ALOAD +0) + ($i;GETFIELD function-class + (|> variable i.inc (i.* -1) int-to-nat functionT;captured) + commonT;$Object))))) + +(def: #export (generate-variable variable) + (-> Variable (Meta $;Inst)) + (meta/wrap ($i;ALOAD (int-to-nat variable)))) + +(def: #export (generate-definition [def-module def-name]) + (-> Ident (Meta $;Inst)) + (let [bytecode-name (format def-module "/" (&;normalize-name def-name))] + (meta/wrap ($i;GETSTATIC bytecode-name 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 new file mode 100644 index 000000000..e5d237fc7 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux @@ -0,0 +1,608 @@ +(;module: + lux + (lux (control monad) + (data text/format + (coll [list "list/" Functor])) + [math] + [meta] + [host]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + ["ls" synthesis] + (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: #export logI + $;Inst + (let [outI ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) + printI (function [method] ($i;INVOKEVIRTUAL "java.io.PrintStream" method ($t;method (list $Object) #;None (list)) false))] + (|>. outI ($i;string "LOG: ") (printI "print") + outI $i;SWAP (printI "println")))) + +(def: variant-method + $;Method + ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list))) + +(def: variantI + $;Inst + ($i;INVOKESTATIC hostL;runtime-class "variant_make" variant-method false)) + +(def: #export leftI + $;Inst + (|>. ($i;int 0) + $i;NULL + $i;DUP2_X1 + $i;POP2 + variantI)) + +(def: #export rightI + $;Inst + (|>. ($i;int 1) + ($i;string "") + $i;DUP2_X1 + $i;POP2 + variantI)) + +(def: #export someI $;Inst rightI) + +(def: #export noneI + $;Inst + (|>. ($i;int 0) + $i;NULL + ($i;string hostL;unit) + variantI)) + +(def: #export string-concatI + $;Inst + ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)) + +(def: #export partials-field Text "partials") +(def: #export apply-method Text "apply") +(def: #export num-apply-variants Nat +8) + +(def: #export (apply-signature arity) + (-> ls;Arity $;Method) + ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) + +(def: adt-methods + $;Def + (let [store-tagI (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE) + store-flagI (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE) + store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE) + force-textMT ($t;method (list $Object) (#;Some $String) (list))] + (|>. ($d;method #$;Public $;staticM "force_text" force-textMT + (<| $i;with-label (function [@is-null]) + $i;with-label (function [@normal-object]) + $i;with-label (function [@array-loop]) + $i;with-label (function [@within-bounds]) + $i;with-label (function [@is-first]) + $i;with-label (function [@elem-end]) + $i;with-label (function [@fold-end]) + (let [on-normal-objectI (|>. ($i;ALOAD +0) + ($i;INVOKEVIRTUAL "java.lang.Object" "toString" ($t;method (list) (#;Some $String) (list)) false)) + on-null-objectI ($i;string "NULL") + arrayI (|>. ($i;ALOAD +0) + ($i;CHECKCAST ($t;descriptor $Object-Array))) + recurseI ($i;INVOKESTATIC hostL;runtime-class "force_text" force-textMT false) + force-elemI (|>. $i;DUP arrayI $i;SWAP $i;AALOAD recurseI) + swap2 (|>. $i;DUP2_X2 ## X,Y => Y,X,Y + $i;POP2 ## Y,X,Y => Y,X + ) + add-spacingI (|>. ($i;string ", ") $i;SWAP string-concatI) + merge-with-totalI (|>. $i;DUP_X2 $i;POP ## TSIP => TPSI + swap2 ## TPSI => SITP + string-concatI ## SITP => SIT + $i;DUP_X2 $i;POP ## SIT => TSI + ) + foldI (|>. $i;DUP ## TSI => TSII + ($i;IFEQ @is-first) ## TSI + force-elemI add-spacingI merge-with-totalI ($i;GOTO @elem-end) + ($i;label @is-first) ## TSI + force-elemI merge-with-totalI + ($i;label @elem-end) ## TSI + ) + inc-idxI (|>. ($i;int 1) $i;IADD) + on-array-objectI (|>. ($i;string "[") ## T + arrayI $i;ARRAYLENGTH ## TS + ($i;int 0) ## TSI + ($i;label @array-loop) ## TSI + $i;DUP2 + ($i;IF_ICMPGT @within-bounds) ## TSI + $i;POP2 ($i;string "]") string-concatI ($i;GOTO @fold-end) + ($i;label @within-bounds) + foldI inc-idxI ($i;GOTO @array-loop) + ($i;label @fold-end))]) + (|>. ($i;ALOAD +0) + ($i;IFNULL @is-null) + ($i;ALOAD +0) + ($i;INSTANCEOF ($t;descriptor $Object-Array)) + ($i;IFEQ @normal-object) + on-array-objectI $i;ARETURN + ($i;label @normal-object) on-normal-objectI $i;ARETURN + ($i;label @is-null) on-null-objectI $i;ARETURN))) + ($d;method #$;Public $;staticM "variant_make" + ($t;method (list $t;int $Object $Object) + (#;Some $Variant) + (list)) + (|>. ($i;int 3) + ($i;array $Object) + store-tagI + store-flagI + store-valueI + $i;ARETURN))))) + +(def: #export force-textI + $;Inst + ($i;INVOKESTATIC hostL;runtime-class "force_text" ($t;method (list $Object) (#;Some $String) (list)) false)) + +(def: nat-methods + $;Def + (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list)) + less-thanI (function [@where] (|>. ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false) ($i;IFLT @where))) + $BigInteger ($t;class "java.math.BigInteger" (list)) + upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list)) + div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)) + upcastI ($i;INVOKESTATIC hostL;runtime-class "_toUnsignedBigInteger" upcast-method false) + downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)] + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 + (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method + (let [upcastI ($i;INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) + discernI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGE @where))) + prepare-upperI (|>. ($i;LLOAD +0) ($i;int 32) $i;LUSHR + upcastI + ($i;int 32) ($i;INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t;method (list $t;int) (#;Some $BigInteger) (list)) false)) + prepare-lowerI (|>. ($i;LLOAD +0) ($i;int 32) $i;LSHL + ($i;int 32) $i;LUSHR + upcastI)] + (<| $i;with-label (function [@simple]) + (|>. (discernI @simple) + ## else + prepare-upperI + prepare-lowerI + ($i;INVOKEVIRTUAL "java.math.BigInteger" "add" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false) + $i;ARETURN + ## then + ($i;label @simple) + ($i;LLOAD +0) + upcastI + $i;ARETURN)))) + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 + ($d;method #$;Public $;staticM "compare_nat" compare-nat-method + (let [shiftI (|>. ($i;GETSTATIC "java.lang.Long" "MIN_VALUE" $t;long) $i;LADD)] + (|>. ($i;LLOAD +0) shiftI + ($i;LLOAD +2) shiftI + $i;LCMP + $i;IRETURN))) + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 + ($d;method #$;Public $;staticM "div_nat" div-method + (let [is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLT @where))) + is-subject-smallI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGT @where))) + small-division (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LDIV $i;LRETURN) + big-divisionI ($i;INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] + (<| $i;with-label (function [@is-zero]) + $i;with-label (function [@param-is-large]) + $i;with-label (function [@subject-is-small]) + (|>. (is-param-largeI @param-is-large) + ## Param is not too large + (is-subject-smallI @subject-is-small) + ## Param is small, but subject is large + ($i;LLOAD +0) upcastI + ($i;LLOAD +2) upcastI + big-divisionI downcastI $i;LRETURN + ## Both param and subject are small, + ## and can thus be divided normally. + ($i;label @subject-is-small) + small-division + ## Param is too large. Cannot simply divide. + ## Depending on the result of the + ## comparison, a result will be determined. + ($i;label @param-is-large) + ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @is-zero) + ## Greater-than or equals + ($i;long 1) $i;LRETURN + ## Less than + ($i;label @is-zero) + ($i;long 0) $i;LRETURN)))) + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 + ($d;method #$;Public $;staticM "rem_nat" div-method + (let [is-subject-largeI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFLE @where))) + is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLE @where))) + small-remainderI (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LREM $i;LRETURN) + big-remainderI ($i;INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] + (<| $i;with-label (function [@large-number]) + $i;with-label (function [@subject-is-smaller-than-param]) + (|>. (is-subject-largeI @large-number) + (is-param-largeI @large-number) + small-remainderI + + ($i;label @large-number) + ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @subject-is-smaller-than-param) + + ($i;LLOAD +0) upcastI + ($i;LLOAD +2) upcastI + big-remainderI downcastI $i;LRETURN + + ($i;label @subject-is-smaller-than-param) + ($i;LLOAD +0) + $i;LRETURN)))) + ))) + +(def: frac-shiftI $;Inst ($i;double (math;pow 32.0 2.0))) + +(def: frac-methods + $;Def + (|>. ($d;method #$;Public $;staticM "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) + (<| $i;with-label (function [@from]) + $i;with-label (function [@to]) + $i;with-label (function [@handler]) + (|>. ($i;try @from @to @handler "java.lang.Exception") + ($i;label @from) + ($i;ALOAD +0) + ($i;INVOKESTATIC "java.lang.Double" "parseDouble" ($t;method (list $String) (#;Some $t;double) (list)) false) + ($i;wrap #$;Double) + someI + $i;ARETURN + ($i;label @to) + ($i;label @handler) + noneI + $i;ARETURN))) + ($d;method #$;Public $;staticM "frac_to_deg" ($t;method (list $t;double) (#;Some $t;long) (list)) + (let [swap2 (|>. $i;DUP2_X2 $i;POP2) + drop-excessI (|>. ($i;double 1.0) $i;DREM) + shiftI (|>. frac-shiftI $i;DMUL)] + (|>. ($i;DLOAD +0) + ## Get upper half + drop-excessI + shiftI + ## Make a copy, so the lower half can be extracted + $i;DUP2 + ## Get lower half + drop-excessI + shiftI + ## Turn it into a deg + $i;D2L + ## Turn the upper half into deg too + swap2 + $i;D2L + ## Combine both pieces + $i;LADD + ## FINISH + $i;LRETURN + ))) + )) + +(def: deg-bits Nat +64) +(def: deg-method $;Method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))) +(def: clz-method $;Method ($t;method (list $t;long) (#;Some $t;int) (list))) + +(def: deg-methods + $;Def + (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits. + low-half (|>. ($i;int -1) $i;I2L $i;LAND) + high-half (|>. ($i;int 32) $i;LUSHR)] + (|>. ($d;method #$;Public $;staticM "mul_deg" deg-method + ## Based on: http://stackoverflow.com/a/31629280/6823464 + (let [shift-downI (|>. ($i;int 32) $i;LUSHR) + low-leftI (|>. ($i;LLOAD +0) low-half) + high-leftI (|>. ($i;LLOAD +0) high-half) + low-rightI (|>. ($i;LLOAD +2) low-half) + high-rightI (|>. ($i;LLOAD +2) high-half) + bottomI (|>. low-leftI low-rightI $i;LMUL) + middleLI (|>. high-leftI low-rightI $i;LMUL) + middleRI (|>. low-leftI high-rightI $i;LMUL) + middleI (|>. middleLI middleRI $i;LADD) + topI (|>. high-leftI high-rightI $i;LMUL)] + (|>. bottomI shift-downI + middleI $i;LADD shift-downI + topI $i;LADD + $i;LRETURN))) + ($d;method #$;Public $;staticM "count_leading_zeros" clz-method + (let [when-zeroI (function [@where] (|>. ($i;long 0) $i;LCMP ($i;IFEQ @where))) + shift-rightI (function [amount] (|>. ($i;int amount) $i;LUSHR)) + decI (|>. ($i;int 1) $i;ISUB)] + (<| $i;with-label (function [@start]) + $i;with-label (function [@done]) + (|>. ($i;int 64) + ($i;label @start) + ($i;LLOAD +0) (when-zeroI @done) + ($i;LLOAD +0) (shift-rightI 1) ($i;LSTORE +0) + decI + ($i;GOTO @start) + ($i;label @done) + $i;IRETURN)))) + ($d;method #$;Public $;staticM "div_deg" deg-method + (<| $i;with-label (function [@same]) + (let [subjectI ($i;LLOAD +0) + paramI ($i;LLOAD +2) + equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where))) + count-leading-zerosI ($i;INVOKESTATIC hostL;runtime-class "count_leading_zeros" clz-method false) + calc-max-shiftI (|>. subjectI count-leading-zerosI + paramI count-leading-zerosI + ($i;INVOKESTATIC "java.lang.Math" "min" ($t;method (list $t;int $t;int) (#;Some $t;int) (list)) false) + ($i;ISTORE +4)) + shiftI (|>. ($i;ILOAD +4) $i;LSHL) + imprecise-divisionI (|>. subjectI shiftI + paramI shiftI high-half + $i;LDIV) + scale-downI (|>. ($i;int 32) $i;LSHL)] + (|>. subjectI paramI + (equal?I @same) + ## Based on: http://stackoverflow.com/a/8510587/6823464 + ## Shifting the operands as much as possible can help + ## avoid some loss of precision later. + calc-max-shiftI + imprecise-divisionI + scale-downI + $i;LRETURN + ($i;label @same) + ($i;long -1) ## ~= 1.0 Degrees + $i;LRETURN)))) + ($d;method #$;Public $;staticM "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list)) + (let [highI (|>. ($i;LLOAD +0) high-half $i;L2D) + lowI (|>. ($i;LLOAD +0) low-half $i;L2D) + scaleI (|>. frac-shiftI $i;DDIV)] + (|>. highI scaleI + lowI scaleI scaleI + $i;DADD + $i;DRETURN))) + ))) + +(def: pm-methods + $;Def + (let [tuple-sizeI (|>. ($i;ALOAD +0) $i;ARRAYLENGTH) + tuple-elemI (|>. ($i;ALOAD +0) ($i;ILOAD +1) $i;AALOAD) + expected-last-sizeI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD) + tuple-tailI (|>. ($i;ALOAD +0) tuple-sizeI ($i;int 1) $i;ISUB $i;AALOAD ($i;CHECKCAST ($t;descriptor $Tuple)))] + (|>. ($d;method #$;Public $;staticM "pm_fail" ($t;method (list) #;None (list)) + (|>. ($i;NEW "java.lang.IllegalStateException") + $i;DUP + ($i;string "Invalid expression for pattern-matching.") + ($i;INVOKESPECIAL "java.lang.IllegalStateException" "" ($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" "" ($t;method (list $String) #;None (list)) false) + $i;ATHROW)) + ($d;method #$;Public $;staticM "pm_push" ($t;method (list $Stack $Object) (#;Some $Stack) (list)) + (|>. ($i;int 2) + ($i;ANEWARRAY "java.lang.Object") + $i;DUP + ($i;int 0) + ($i;ALOAD +0) + $i;AASTORE + $i;DUP + ($i;int 1) + ($i;ALOAD +1) + $i;AASTORE + $i;ARETURN)) + ($d;method #$;Public $;staticM "pm_pop" ($t;method (list $Stack) (#;Some $Stack) (list)) + (|>. ($i;ALOAD +0) + ($i;int 0) + $i;AALOAD + ($i;CHECKCAST ($t;descriptor $Stack)) + $i;ARETURN)) + ($d;method #$;Public $;staticM "pm_peek" ($t;method (list $Stack) (#;Some $Object) (list)) + (|>. ($i;ALOAD +0) + ($i;int 1) + $i;AALOAD + $i;ARETURN)) + ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Variant $Tag $Flag) (#;Some $Object) (list)) + (<| $i;with-label (function [@begin]) + $i;with-label (function [@just-return]) + $i;with-label (function [@then]) + $i;with-label (function [@further]) + $i;with-label (function [@shorten]) + $i;with-label (function [@wrong]) + (let [variant-partI (: (-> Nat $;Inst) + (function [idx] + (|>. ($i;int (nat-to-int idx)) $i;AALOAD))) + tagI (: $;Inst + (|>. (variant-partI +0) ($i;unwrap #$;Int))) + flagI (variant-partI +1) + datumI (variant-partI +2) + shortenI (|>. ($i;ALOAD +0) tagI ## Get tag + ($i;ILOAD +1) $i;ISUB ## Shorten tag + ($i;ALOAD +0) flagI ## Get flag + ($i;ALOAD +0) datumI ## Get value + variantI ## Build sum + $i;ARETURN) + update-tagI (|>. $i;ISUB ($i;ISTORE +1)) + update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0)) + wrongI (|>. $i;NULL $i;ARETURN) + return-datumI (|>. ($i;ALOAD +0) datumI $i;ARETURN)]) + (|>. ($i;label @begin) + ($i;ILOAD +1) ## tag + ($i;ALOAD +0) tagI ## tag, sumT + $i;DUP2 ($i;IF_ICMPEQ @then) + $i;DUP2 ($i;IF_ICMPGT @further) + $i;DUP2 ($i;IF_ICMPLT @shorten) + ## $i;POP2 + wrongI + ($i;label @then) ## tag, sumT + ($i;ALOAD +2) ## tag, sumT, wants-last? + ($i;ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? + ($i;IF_ACMPEQ @just-return) ## tag, sumT + ($i;label @further) ## tag, sumT + ($i;ALOAD +0) flagI ## tag, sumT, last? + ($i;IFNULL @wrong) ## tag, sumT + update-tagI + update-variantI + ($i;GOTO @begin) + ($i;label @just-return) ## tag, sumT + ## $i;POP2 + return-datumI + ($i;label @shorten) ## tag, sumT + ($i;ALOAD +2) ($i;IFNULL @wrong) + ## $i;POP2 + shortenI + ($i;label @wrong) ## tag, sumT + ## $i;POP2 + wrongI))) + ($d;method #$;Public $;staticM "pm_left" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) + (<| $i;with-label (function [@begin]) + $i;with-label (function [@not-recursive]) + (let [updated-idxI (|>. $i;SWAP $i;ISUB)]) + (|>. ($i;label @begin) + tuple-sizeI + expected-last-sizeI + $i;DUP2 ($i;IF_ICMPGT @not-recursive) + ## Recursive + updated-idxI ($i;ISTORE +1) + tuple-tailI ($i;ASTORE +0) + ($i;GOTO @begin) + ($i;label @not-recursive) + ## $i;POP2 + tuple-elemI + $i;ARETURN))) + ($d;method #$;Public $;staticM "pm_right" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) + (<| $i;with-label (function [@begin]) + $i;with-label (function [@tail]) + $i;with-label (function [@slice]) + (let [updated-idxI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD tuple-sizeI $i;ISUB) + sliceI (|>. ($i;ALOAD +0) ($i;ILOAD +1) tuple-sizeI + ($i;INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t;method (list $Object-Array $t;int $t;int) (#;Some $Object-Array) (list)) false))]) + (|>. ($i;label @begin) + tuple-sizeI + expected-last-sizeI + $i;DUP2 ($i;IF_ICMPEQ @tail) + ($i;IF_ICMPGT @slice) + ## Must recurse + tuple-tailI ($i;ASTORE +0) + updated-idxI ($i;ISTORE +1) + ($i;GOTO @begin) + ($i;label @slice) + sliceI + $i;ARETURN + ($i;label @tail) + ## $i;POP2 + tuple-elemI + $i;ARETURN))) + ))) + +(def: io-methods + $;Def + (let [string-writerI (|>. ($i;NEW "java.io.StringWriter") + $i;DUP + ($i;INVOKESPECIAL "java.io.StringWriter" "" ($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" "" ($t;method (list ($t;class "java.io.Writer" (list)) $t;boolean) #;None (list)) false) + )] + (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list)) + (<| $i;with-label (function [@from]) + $i;with-label (function [@to]) + $i;with-label (function [@handler]) + (|>. ($i;try @from @to @handler "java.lang.Throwable") + ($i;label @from) + ($i;ALOAD +0) + $i;NULL + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) + rightI + $i;ARETURN + ($i;label @to) + ($i;label @handler) + string-writerI ## TW + $i;DUP2 ## TWTW + print-writerI ## TWTP + ($i;INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t;method (list ($t;class "java.io.PrintWriter" (list))) #;None (list)) false) ## TW + ($i;INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t;method (list) (#;Some $String) (list)) false) ## TS + $i;SWAP $i;POP leftI + $i;ARETURN))) + ))) + +(def: generate-runtime + (Meta commonT;Bytecode) + (do meta;Monad + [_ (wrap []) + #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC hostL;runtime-class (list) ["java.lang.Object" (list)] (list) + (|>. adt-methods + nat-methods + frac-methods + deg-methods + pm-methods + io-methods))] + _ (commonT;store-class hostL;runtime-class bytecode)] + (wrap bytecode))) + +(def: generate-function + (Meta commonT;Bytecode) + (do meta;Monad + [_ (wrap []) + #let [applyI (|> (list;n.range +2 num-apply-variants) + (list/map (function [arity] + ($d;method #$;Public $;noneM apply-method (apply-signature arity) + (let [preI (|> (list;n.range +0 (n.dec arity)) + (list/map $i;ALOAD) + $i;fuse)] + (|>. preI + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature (n.dec arity)) false) + ($i;CHECKCAST hostL;function-class) + ($i;ALOAD arity) + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) + $i;ARETURN))))) + (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1))) + $d;fuse) + bytecode ($d;abstract #$;V1.6 #$;Public $;noneC hostL;function-class (list) ["java.lang.Object" (list)] (list) + (|>. ($d;field #$;Public $;finalF partials-field $t;int) + ($d;method #$;Public $;noneM "" ($t;method (list $t;int) #;None (list)) + (|>. ($i;ALOAD +0) + ($i;INVOKESPECIAL "java.lang.Object" "" ($t;method (list) #;None (list)) false) + ($i;ALOAD +0) + ($i;ILOAD +1) + ($i;PUTFIELD hostL;function-class partials-field $t;int) + $i;RETURN)) + applyI))] + _ (commonT;store-class hostL;function-class bytecode)] + (wrap bytecode))) + +(def: #export generate + (Meta [commonT;Bytecode commonT;Bytecode]) + (do meta;Monad + [runtime-bc generate-runtime + function-bc generate-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 new file mode 100644 index 000000000..0234d738c --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/statement.jvm.lux @@ -0,0 +1,82 @@ +(;module: + lux + (lux (control monad + ["ex" exception #+ exception:]) + (data ["e" error] + [maybe] + [text "text/" Monoid] + text/format + (coll [list "list/" Functor Fold])) + [meta] + [host]) + (luxc ["&" base] + ["&;" scope] + ["&;" module] + ["&;" io] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang (translation [";T" eval] + [";T" common])))) + +(exception: #export Invalid-Definition-Value) + +(host;import java.lang.Object + (toString [] String)) + +(host;import java.lang.reflect.Field + (get [#? Object] #try #? Object)) + +(host;import (java.lang.Class c) + (getField [String] #try Field)) + +(def: #export (generate-def def-name valueT valueI metaI metaV) + (-> Text Type $;Inst $;Inst Code (Meta Unit)) + (do meta;Monad + [current-module meta;current-module-name + #let [def-ident [current-module def-name] + normal-name (&;normalize-name def-name) + bytecode-name (format current-module "/" normal-name) + class-name (format current-module "." normal-name) + bytecode ($d;class #$;V1.6 + #$;Public $;finalC + bytecode-name + (list) ["java.lang.Object" (list)] + (list) + (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) commonT;value-field commonT;$Object) + ($d;method #$;Public $;staticM "" ($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 + [field (Class.getField [commonT;value-field] class)] + (Field.get [#;None] field)) + (#e;Success #;None) + (&;throw Invalid-Definition-Value (format current-module ";" def-name)) + + (#e;Success (#;Some valueV)) + (wrap valueV) + + (#e;Error error) + (&;fail error))) + _ (&module;define [current-module def-name] [valueT metaV valueV]) + _ (if (meta;type? metaV) + (case (meta;declared-tags metaV) + #;Nil + (wrap []) + + tags + (&module;declare-tags tags (meta;export? metaV) (:! Type valueV))) + (wrap [])) + #let [_ (log! (format "DEF " current-module ";" def-name))]] + (commonT;record-artifact bytecode-name bytecode))) + +(def: #export (generate-program program-args programI) + (-> Text $;Inst (Meta Unit)) + (do meta;Monad + [] + (&;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 new file mode 100644 index 000000000..c3e07fd55 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/structure.jvm.lux @@ -0,0 +1,59 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data text/format + (coll [list])) + [meta] + [host #+ do-to]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + ["ls" synthesis] + (translation [";T" common]))) + [../runtime]) + +(def: $Object $;Type ($t;class "java.lang.Object" (list))) + +(def: #export (generate-tuple generate members) + (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst)) + (do meta;Monad + [#let [size (list;size members)] + _ (&;assert "Cannot generate tuples with less than 2 elements." + (n.>= +2 size)) + membersI (|> members + list;enumerate + (monad;map @ (function [[idx member]] + (do @ + [memberI (generate member)] + (wrap (|>. $i;DUP + ($i;int (nat-to-int idx)) + memberI + $i;AASTORE))))) + (:: @ map $i;fuse))] + (wrap (|>. ($i;int (nat-to-int size)) + ($i;array $Object) + membersI)))) + +(def: (flagI tail?) + (-> Bool $;Inst) + (if tail? + ($i;string "") + $i;NULL)) + +(def: #export (generate-variant generate tag tail? member) + (-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst)) + (do meta;Monad + [memberI (generate member)] + (wrap (|>. ($i;int (nat-to-int tag)) + (flagI tail?) + memberI + ($i;INVOKESTATIC hostL;runtime-class + "variant_make" + ($t;method (list $t;int $Object $Object) + (#;Some ($t;array +1 $Object)) + (list)) + false))))) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index e660b4158..142e8b566 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -8,7 +8,7 @@ text/format) [io #- run] [cli #+ program: CLI]) - (luxc ["&;" generator])) + (luxc (lang [";L" translation]))) ## (type: Compilation ## {#program &;Path @@ -53,3 +53,5 @@ (#e;Success output) (wrap output)))) + + diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux index 5b6fed8ec..84d912145 100644 --- a/new-luxc/test/test/luxc/common.lux +++ b/new-luxc/test/test/luxc/common.lux @@ -2,8 +2,8 @@ lux (lux [io]) (luxc ["&;" host] - [";G" generator])) + (lang [";L" translation]))) (def: #export (init-compiler _) (-> Top Compiler) - (generatorG;init-compiler (io;run &host;init-host))) + (translationL;init-compiler (io;run &host;init-host))) diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux deleted file mode 100644 index e4201a30b..000000000 --- a/new-luxc/test/test/luxc/generator/case.lux +++ /dev/null @@ -1,101 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - text/format - (coll [list])) - ["r" math/random "r/" Monad] - [meta] - (meta [code]) - test) - (luxc (lang ["ls" synthesis]) - (generator ["@" case] - [";G" expression] - ["@;" eval] - ["@;" runtime] - ["@;" common])) - (test/luxc common)) - -(def: struct-limit Nat +10) - -(def: (tail? size idx) - (-> Nat Nat Bool) - (n.= (n.dec size) idx)) - -(def: gen-case - (r;Random [ls;Synthesis ls;Path]) - (<| r;rec (function [gen-case]) - (`` ($_ r;either - (r/wrap [(' []) (' ("lux case pop"))]) - (~~ (do-template [ ] - [(do r;Monad - [value ] - (wrap [( value) ( value)]))] - - [r;bool code;bool] - [r;nat code;nat] - [r;int code;int] - [r;deg code;deg] - [r;frac code;frac] - [(r;text +5) code;text])) - (do r;Monad - [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2)))) - idx (|> r;nat (:: @ map (n.% size))) - [subS subP] gen-case - #let [caseS (` [(~@ (list;concat (list (list;repeat idx (' [])) - (list subS) - (list;repeat (|> size n.dec (n.- idx)) (' [])))))]) - caseP (if (tail? size idx) - (` ("lux case tuple right" (~ (code;nat idx)) (~ subP))) - (` ("lux case tuple left" (~ (code;nat idx)) (~ subP))))]] - (wrap [caseS caseP])) - (do r;Monad - [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2)))) - idx (|> r;nat (:: @ map (n.% size))) - [subS subP] gen-case - #let [caseS (` ((~ (code;nat idx)) (~ (code;bool (tail? size idx))) (~ subS))) - caseP (if (tail? size idx) - (` ("lux case variant right" (~ (code;nat idx)) (~ subP))) - (` ("lux case variant left" (~ (code;nat idx)) (~ subP))))]] - (wrap [caseS caseP])) - )))) - -(context: "Pattern-matching." - (<| (times +100) - (do @ - [[valueS pathS] gen-case - to-bind r;nat] - ($_ seq - (test "Can generate pattern-matching." - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate-case expressionG;generate - valueS - (` ("lux case alt" - ("lux case seq" (~ pathS) - ("lux case exec" true)) - ("lux case seq" ("lux case bind" +0) - ("lux case exec" false)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (:! Bool valueG) - - (#e;Error error) - false))) - (test "Can bind values." - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate-case expressionG;generate - (code;nat to-bind) - (` ("lux case seq" ("lux case bind" +0) - ("lux case exec" (0)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= to-bind (:! Nat valueG)) - - _ - false))))))) diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux deleted file mode 100644 index 2db2719b7..000000000 --- a/new-luxc/test/test/luxc/generator/function.lux +++ /dev/null @@ -1,99 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [product] - [maybe] - ["e" error] - (coll ["a" array] - [list "list/" Functor])) - ["r" math/random "r/" Monad] - [meta] - (meta [code]) - [host] - test) - (luxc (lang ["ls" synthesis]) - (generator [";G" expression] - ["@;" eval] - ["@;" runtime] - ["@;" common])) - (test/luxc common)) - -(def: arity-limit Nat +10) - -(def: arity - (r;Random ls;Arity) - (|> r;nat (r/map (|>. (n.% arity-limit) (n.max +1))))) - -(def: gen-function - (r;Random [ls;Arity Nat ls;Synthesis]) - (do r;Monad - [arity arity - arg (|> r;nat (:: @ map (n.% arity))) - #let [functionS (` ("lux function" (~ (code;nat arity)) [] - ((~ (code;int (nat-to-int (n.inc arg)))))))]] - (wrap [arity arg functionS]))) - -(context: "Function." - (<| (times +100) - (do @ - [[arity arg functionS] gen-function - cut-off (|> r;nat (:: @ map (n.% arity))) - args (r;list arity r;nat) - #let [arg-value (maybe;assume (list;nth arg args)) - argsS (list/map code;nat args) - last-arg (n.dec arity) - cut-off (|> cut-off (n.min (n.dec last-arg)))]] - ($_ seq - (test "Can read arguments." - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ("lux call" (~ functionS) (~@ argsS))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= arg-value (:! Nat valueG)) - - (#e;Error error) - false))) - (test "Can partially apply functions." - (or (n.= +1 arity) - (|> (do meta;Monad - [#let [partial-arity (n.inc cut-off) - preS (list;take partial-arity argsS) - postS (list;drop partial-arity argsS)] - runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ("lux call" - ("lux call" (~ functionS) (~@ preS)) - (~@ postS))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= arg-value (:! Nat valueG)) - - (#e;Error error) - false)))) - (test "Can read environment." - (or (n.= +1 arity) - (|> (do meta;Monad - [#let [env (|> (list;n.range +0 cut-off) - (list/map (|>. n.inc nat-to-int))) - super-arity (n.inc cut-off) - arg-var (if (n.<= cut-off arg) - (|> arg n.inc nat-to-int (i.* -1)) - (|> arg n.inc (n.- super-arity) nat-to-int)) - sub-arity (|> arity (n.- super-arity)) - functionS (` ("lux function" (~ (code;nat super-arity)) [] - ("lux function" (~ (code;nat sub-arity)) [(~@ (list/map code;int env))] - ((~ (code;int arg-var))))))] - runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ("lux call" (~ functionS) (~@ argsS))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= arg-value (:! Nat valueG)) - - (#e;Error error) - false)))) - )))) diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux deleted file mode 100644 index 1ce93cee9..000000000 --- a/new-luxc/test/test/luxc/generator/primitive.lux +++ /dev/null @@ -1,62 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data text/format - ["e" error] - [bool "B/" Eq] - [text "T/" Eq]) - ["r" math/random] - [meta] - (meta [code]) - test) - (luxc [";L" host] - (lang ["ls" synthesis]) - (generator [";G" expression] - ["@;" runtime] - ["@;" eval] - ["@;" common])) - (test/luxc common)) - -(context: "Primitives." - (<| (times +100) - (do @ - [%bool% r;bool - %nat% r;nat - %int% r;int - %deg% r;deg - %frac% r;frac - %text% (r;text +5)] - (with-expansions - [ (do-template [ ] - [(test (format "Can generate " ".") - (|> (do meta;Monad - [sampleI (expressionG;generate ( ))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! valueG)) - - _ - false)))] - - ["bool" Bool code;bool %bool% B/=] - ["nat" Nat code;nat %nat% n.=] - ["int" Int code;int %int% i.=] - ["deg" Deg code;deg %deg% d.=] - ["frac" Frac code;frac %frac% f.=] - ["text" Text code;text %text% T/=])] - ($_ seq - (test "Can generate unit." - (|> (do meta;Monad - [sampleI (expressionG;generate (' []))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (is hostL;unit (:! Text valueG)) - - _ - false))) - - ))))) diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux deleted file mode 100644 index 0c24a4020..000000000 --- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux +++ /dev/null @@ -1,367 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data text/format - [bit] - ["e" error] - [bool "bool/" Eq] - [text "text/" Eq] - [number "nat/" Interval "int/" Interval "real/" Interval "deg/" Interval] - (coll ["a" array] - [list])) - ["r" math/random] - [meta] - (meta [code]) - [host] - test) - (luxc (lang ["ls" synthesis]) - (generator [";G" expression] - ["@;" eval] - ["@;" runtime] - ["@;" common])) - (test/luxc common)) - -(context: "Bit procedures" - (<| (times +100) - (do @ - [param r;nat - subject r;nat] - (with-expansions [ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (expressionG;generate (` ( (~ (code;nat subject)) - (~ (code;nat param)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= ( param subject) (:! Nat valueG)) - - _ - false)))] - - ["bit and" bit;and] - ["bit or" bit;or] - ["bit xor" bit;xor] - ["bit shift-left" bit;shift-left] - ["bit unsigned-shift-right" bit;shift-right] - )] - ($_ seq - (test "bit count" - (|> (do meta;Monad - [sampleI (expressionG;generate (` ("bit count" (~ (code;nat subject)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= (bit;count subject) (:! Nat valueG)) - - _ - false))) - - - (test "bit shift-right" - (|> (do meta;Monad - [sampleI (expressionG;generate (` ("bit shift-right" - (~ (code;int (nat-to-int subject))) - (~ (code;nat param)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (i.= (bit;signed-shift-right param (nat-to-int subject)) - (:! Int valueG)) - - _ - false))) - ))))) - -(context: "Nat procedures" - (<| (times +100) - (do @ - [param (|> r;nat (r;filter (|>. (n.= +0) not))) - subject r;nat] - (`` ($_ seq - (~~ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (expressionG;generate (` ()))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= (:! Nat valueG)) - - _ - false)))] - - ["nat min" nat/bottom] - ["nat max" nat/top] - )) - (~~ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (expressionG;generate (` ( (~ (code;nat subject)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( subject) (:! valueG)) - - _ - false)))] - - ["nat to-int" Int nat-to-int i.=] - ["nat to-char" Text text;from-code text/=] - )) - (~~ (do-template [ ] - [(test - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ( (~ (code;nat subject)) (~ (code;nat param)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( param subject) (:! valueG)) - - _ - false)))] - - ["nat +" n.+ Nat n.=] - ["nat -" n.- Nat n.=] - ["nat *" n.* Nat n.=] - ["nat /" n./ Nat n.=] - ["nat %" n.% Nat n.=] - ["nat =" n.= Bool bool/=] - ["nat <" n.< Bool bool/=] - )) - ))))) - -(context: "Int procedures" - (<| (times +100) - (do @ - [param (|> r;int (r;filter (|>. (i.= 0) not))) - subject r;int] - (with-expansions [ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (expressionG;generate (` ()))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (i.= (:! Int valueG)) - - _ - false)))] - - ["int min" int/bottom] - ["int max" int/top] - ) - (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (expressionG;generate (` ( (~ (code;int subject)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( subject) (:! valueG)) - - _ - false)))] - - ["int to-nat" Nat int-to-nat n.=] - ["int to-frac" Frac int-to-frac f.=] - ) - (do-template [ ] - [(test - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ( (~ (code;int subject)) (~ (code;int param)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( param subject) (:! valueG)) - - _ - false)))] - - ["int +" i.+ Int i.=] - ["int -" i.- Int i.=] - ["int *" i.* Int i.=] - ["int /" i./ Int i.=] - ["int %" i.% Int i.=] - ["int =" i.= Bool bool/=] - ["int <" i.< Bool bool/=] - )] - ($_ seq - - - - ))))) - -(context: "Frac procedures [Part 1]" - (<| (times +100) - (do @ - [param (|> r;frac (r;filter (|>. (f.= 0.0) not))) - subject r;frac] - (with-expansions [ (do-template [ ] - [(test - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ( (~ (code;frac subject)) (~ (code;frac param)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( param subject) (:! valueG)) - - _ - false)))] - - ["frac +" f.+ Frac f.=] - ["frac -" f.- Frac f.=] - ["frac *" f.* Frac f.=] - ["frac /" f./ Frac f.=] - ["frac %" f.% Frac f.=] - ["frac =" f.= Bool bool/=] - ["frac <" f.< Bool bool/=] - )] - ($_ seq - - ))))) - -(context: "Frac procedures [Part 2]" - (<| (times +100) - (do @ - [param (|> r;frac (r;filter (|>. (f.= 0.0) not))) - subject r;frac] - (with-expansions [ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (expressionG;generate (` ()))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! Frac valueG)) - - _ - false)))] - - ["frac min" (f.= real/bottom)] - ["frac max" (f.= real/top)] - ["frac not-a-number" number;not-a-number?] - ["frac positive-infinity" (f.= number;positive-infinity)] - ["frac negative-infinity" (f.= number;negative-infinity)] - ["frac smallest" (f.= (_lux_proc [ "frac" "smallest-value"] []))] - ) - (do-template [ ] - [(test - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ( (~ (code;frac subject)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( subject) (:! valueG)) - - _ - false)))] - - ["frac to-int" Int frac-to-int i.=] - ["frac to-deg" Deg frac-to-deg d.=] - )] - ($_ seq - - - (test "frac encode|decode" - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ("frac decode" ("frac encode" (~ (code;frac subject))))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success valueG) - [(:! (Maybe Frac) valueG) (#;Some value)]) - (f.= subject value) - - _ - false))) - ))))) - -(def: (above-threshold value) - (-> Deg Deg) - (let [threshold .000000001 #( 1/(2^30) )#] - (if (d.< threshold value) - (d.+ threshold value) - value))) - -(context: "Deg procedures" - (<| (times +100) - (do @ - [param (|> r;deg (:: @ map above-threshold)) - special r;nat - subject (|> r;deg (:: @ map above-threshold))] - (`` ($_ seq - (~~ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (expressionG;generate (` ()))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (d.= (:! Deg valueG)) - - _ - false)))] - - ["deg min" deg/bottom] - ["deg max" deg/top] - )) - (~~ (do-template [ ] - [(test - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ( (~ (code;deg subject)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( subject) (:! valueG)) - - _ - false)))] - - ["deg to-frac" Frac deg-to-frac f.=] - )) - (~~ (do-template [ ] - [(test - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ( (~ (code;deg subject)) (~ (code;deg param)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( param subject) (:! valueG)) - - _ - false)))] - - ["deg +" d.+ Deg d.=] - ["deg -" d.- Deg d.=] - ["deg *" d.* Deg d.=] - ["deg /" d./ Deg d.=] - ["deg %" d.% Deg d.=] - ["deg =" d.= Bool bool/=] - ["deg <" d.< Bool bool/=] - )) - (~~ (do-template [ ] - [(test - (|> (do meta;Monad - [runtime-bytecode @runtime;generate - sampleI (expressionG;generate (` ( (~ (code;deg subject)) (~ (code;nat special)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( special subject) (:! valueG)) - - _ - false)))] - - ["deg scale" d.scale Deg d.=] - ["deg reciprocal" d.reciprocal Deg d.=] - )) - ))))) diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux deleted file mode 100644 index 91b20d3d4..000000000 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ /dev/null @@ -1,614 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [maybe] - ["e" error] - [bit] - [bool "bool/" Eq] - [number "int/" Number Codec] - [text "text/" Eq] - text/format - (coll [list])) - ["r" math/random "r/" Monad] - [meta] - (meta [code]) - [host] - test) - (luxc [";L" host] - (lang ["ls" synthesis]) - (generator [";G" expression] - ["@;" eval] - ["@;" runtime] - ["@;" common])) - (test/luxc common)) - -(context: "Conversions [Part 1]" - (<| (times +100) - (do @ - [int-sample (|> r;int (:: @ map (i.% 128))) - #let [frac-sample (int-to-frac int-sample)]] - (with-expansions [<2step> (do-template [ ] - [(test (format " / " ) - (|> (do meta;Monad - [sampleI (expressionG;generate (|> (~ ( )) (`)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! valueG)) - - (#e;Error error) - false)))] - - ["jvm convert double-to-float" "jvm convert float-to-double" code;frac frac-sample Frac f.=] - ["jvm convert double-to-int" "jvm convert int-to-double" code;frac frac-sample Frac f.=] - ["jvm convert double-to-long" "jvm convert long-to-double" code;frac frac-sample Frac f.=] - - ["jvm convert long-to-float" "jvm convert float-to-long" code;int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-long" code;int int-sample Int i.=] - ["jvm convert long-to-short" "jvm convert short-to-long" code;int int-sample Int i.=] - ["jvm convert long-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=] - )] - ($_ seq - <2step> - ))))) - -(context: "Conversions [Part 2]" - (<| (times +100) - (do @ - [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs))) - #let [frac-sample (int-to-frac int-sample)]] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format " / " " / " ) - (|> (do meta;Monad - [sampleI (expressionG;generate (|> (~ ( )) (`)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! valueG)) - - (#e;Error error) - false)))] - - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-long" code;int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-short" "jvm convert short-to-long" code;int int-sample Int i.=] - ["jvm convert long-to-float" "jvm convert float-to-int" "jvm convert int-to-long" code;int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-float" "jvm convert float-to-long" code;int int-sample Int i.=] - )) - ))))) - -(context: "Conversions [Part 3]" - (<| (times +100) - (do @ - [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs))) - #let [frac-sample (int-to-frac int-sample)]] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format " / " " / " ) - (|> (do meta;Monad - [sampleI (expressionG;generate (|> (~ ( )) (`)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! valueG)) - - (#e;Error error) - false)))] - - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-short" "jvm convert short-to-long" code;int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-int" "jvm convert int-to-long" code;int int-sample Int i.=] - )) - ))))) - -(def: gen-nat - (r;Random Nat) - (|> r;nat - (r/map (n.% +128)) - (r;filter (|>. (n.= +0) not)))) - -(def: gen-int - (r;Random Int) - (|> gen-nat (r/map nat-to-int))) - -(def: gen-frac - (r;Random Frac) - (|> gen-int (r/map int-to-frac))) - -(do-template [ <+> <-> <*> <%> 
 ]
-  [(context: (format "Arithmetic ["  "]")
-     (<| (times +100)
-         (do @
-           [param 
-            #let [subject ( param)]]
-           (with-expansions [ (do-template [ ]
-                                       [(test 
-                                              (|> (do meta;Monad
-                                                    [sampleI (expressionG;generate (` ( ((~ (code;text ))
-                                                                                               (
 (~ ( subject)))
-                                                                                               (
 (~ ( param)))))))]
-                                                    (@eval;eval sampleI))
-                                                  (meta;run (init-compiler []))
-                                                  (case> (#e;Success valueG)
-                                                         ( ( param subject)
-                                                                 (:!  valueG))
-
-                                                         (#e;Error error)
-                                                         false)))]
-
-                                       [(format "jvm "  " +") <+>]
-                                       [(format "jvm "  " -") <->]
-                                       [(format "jvm "  " *") <*>]
-                                       [(format "jvm "  " /") ]
-                                       [(format "jvm "  " %") <%>]
-                                       )]
-             ($_ seq
-                 
-                 )))))]
-
-  ["int" gen-int code;int Int i.= (i.* 10) i.+ i.- i.* i./ i.% "jvm convert long-to-int" "jvm convert int-to-long"]
-  ["long" gen-int code;int Int i.= (i.* 10) i.+ i.- i.* i./ i.% "lux noop" "lux noop"]
-  ["float" gen-frac code;frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% "jvm convert double-to-float" "jvm convert float-to-double"]
-  ["double" gen-frac code;frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% "lux noop" "lux noop"]
-  )
-
-(do-template [  ]
-  [(context: (format "Bit-wise ["  "] { Combiners ]")
-     (<| (times +100)
-         (do @
-           [param gen-nat
-            subject gen-nat]
-           (`` ($_ seq
-                   (~~ (do-template [ ]
-                         [(test 
-                                (|> (do meta;Monad
-                                      [sampleI (expressionG;generate (` ( ((~ (code;text ))
-                                                                                 ( (~ (code;nat subject)))
-                                                                                 ( (~ (code;nat param)))))))]
-                                      (@eval;eval sampleI))
-                                    (meta;run (init-compiler []))
-                                    (case> (#e;Success valueG)
-                                           (n.= ( param subject)
-                                                (:! Nat valueG))
-
-                                           (#e;Error error)
-                                           false)))]
-
-                         [(format "jvm "  " and") bit;and]
-                         [(format "jvm "  " or") bit;or]
-                         [(format "jvm "  " xor") bit;xor]
-                         ))
-                   )))))]
-
-  ["int" "jvm convert int-to-long" "jvm convert long-to-int"]
-  ["long" "lux noop" "lux noop"]
-  )
-
-(do-template [  ]
-  [(context: (format "Bit-wise ["  "] { Shifters }")
-     (<| (times +100)
-         (do @
-           [param gen-nat
-            subject gen-nat
-            #let [shift (n.% +10 param)]]
-           (`` ($_ seq
-                   (~~ (do-template [     
]
-                         [(test 
-                                (|> (do meta;Monad
-                                      [sampleI (expressionG;generate (` ( ((~ (code;text ))
-                                                                                 ( (~ (
 subject)))
-                                                                                 ("jvm convert long-to-int" (~ (code;nat shift)))))))]
-                                      (@eval;eval sampleI))
-                                    (meta;run (init-compiler []))
-                                    (case> (#e;Success valueG)
-                                           ( ( shift ( subject))
-                                                   (:!  valueG))
-
-                                           (#e;Error error)
-                                           false)))]
-
-                         [(format "jvm "  " shl") bit;shift-left Nat n.= id code;nat]
-                         [(format "jvm "  " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int code;int)]
-                         [(format "jvm "  " ushr") bit;shift-right Nat n.= id code;nat]
-                         ))
-                   )))))]
-
-  ["int" "jvm convert int-to-long" "jvm convert long-to-int"]
-  ["long" "lux noop" "lux noop"]
-  )
-
-(do-template [   <=> <<> 
]
-  [(context: (format "Order ["  "]")
-     (<| (times +100)
-         (do @
-           [param 
-            subject ]
-           (with-expansions [ (do-template [ ]
-                                       [(test 
-                                              (|> (do meta;Monad
-                                                    [sampleI (expressionG;generate (` ((~ (code;text ))
-                                                                                       (
 (~ ( subject)))
-                                                                                       (
 (~ ( param))))))]
-                                                    (@eval;eval sampleI))
-                                                  (meta;run (init-compiler []))
-                                                  (case> (#e;Success valueG)
-                                                         (bool/= ( param subject)
-                                                                 (:! Bool valueG))
-
-                                                         (#e;Error error)
-                                                         false)))]
-
-                                       [(format "jvm "  " =") <=>]
-                                       [(format "jvm "  " <") <<>]
-                                       )]
-             ($_ seq
-                 
-                 )))))]
-
-  ["int" gen-int code;int i.= i.< "jvm convert long-to-int"]
-  ["long" gen-int code;int i.= i.< "lux noop"]
-  ["float" gen-frac code;frac f.= f.< "jvm convert double-to-float"]
-  ["double" gen-frac code;frac f.= f.< "lux noop"]
-  ["char" gen-int code;int i.= i.< "jvm convert long-to-char"]
-  )
-
-(def: (jvm//array//new dimension class size)
-  (-> Nat Text Nat ls;Synthesis)
-  (` ("jvm array new" (~ (code;nat dimension)) (~ (code;text class)) (~ (code;nat size)))))
-
-(def: (jvm//array//write class idx inputS arrayS)
-  (-> Text Nat ls;Synthesis ls;Synthesis ls;Synthesis)
-  (` ("jvm array write" (~ (code;text class)) (~ (code;nat idx)) (~ inputS) (~ arrayS))))
-
-(def: (jvm//array//read class idx arrayS)
-  (-> Text Nat ls;Synthesis ls;Synthesis)
-  (` ("jvm array read" (~ (code;text class)) (~ (code;nat idx)) (~ arrayS))))
-
-(context: "Array [Part 1]"
-  (<| (times +100)
-      (do @
-        [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
-         idx (|> r;nat (:: @ map (n.% size)))
-         valueZ r;bool
-         valueB gen-int
-         valueS gen-int
-         valueI gen-int
-         valueL r;int
-         valueF gen-frac
-         valueD r;frac
-         valueC gen-int]
-        (with-expansions [ (do-template [     ]
-                                    [(test 
-                                           (|> (do meta;Monad
-                                                 [sampleI (expressionG;generate (|> (jvm//array//new +0  size)
-                                                                                    (jvm//array//write  idx )
-                                                                                    (jvm//array//read  idx)
-                                                                                    (~)
-                                                                                    
-                                                                                    (`)))]
-                                                 (@eval;eval sampleI))
-                                               (meta;run (init-compiler []))
-                                               (case> (#e;Success outputZ)
-                                                      (  (:!  outputZ))
-
-                                                      (#e;Error error)
-                                                      false)))]
-
-                                    ["boolean" Bool valueZ bool/= (code;bool valueZ)
-                                     "lux noop"]
-                                    ["byte" Int valueB i.= (|> (code;int valueB) (~) "jvm convert long-to-byte" (`))
-                                     "jvm convert byte-to-long"]
-                                    ["short" Int valueS i.= (|> (code;int valueS) (~) "jvm convert long-to-short" (`))
-                                     "jvm convert short-to-long"]
-                                    ["int" Int valueI i.= (|> (code;int valueI) (~) "jvm convert long-to-int" (`))
-                                     "jvm convert int-to-long"]
-                                    ["long" Int valueL i.= (code;int valueL)
-                                     "lux noop"]
-                                    ["float" Frac valueF f.= (|> (code;frac valueF) (~) "jvm convert double-to-float" (`))
-                                     "jvm convert float-to-double"]
-                                    ["double" Frac valueD f.= (code;frac valueD)
-                                     "lux noop"]
-                                    )]
-          ($_ seq
-              
-              )))))
-
-(context: "Array [Part 2]"
-  (<| (times +100)
-      (do @
-        [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
-         idx (|> r;nat (:: @ map (n.% size)))
-         valueZ r;bool
-         valueB gen-int
-         valueS gen-int
-         valueI gen-int
-         valueL r;int
-         valueF gen-frac
-         valueD r;frac
-         valueC gen-int]
-        (with-expansions [ (do-template [     ]
-                                    [(test 
-                                           (|> (do meta;Monad
-                                                 [sampleI (expressionG;generate (|> (jvm//array//new +0  size)
-                                                                                    (jvm//array//write  idx )
-                                                                                    (jvm//array//read  idx)
-                                                                                    (~)
-                                                                                    
-                                                                                    (`)))]
-                                                 (@eval;eval sampleI))
-                                               (meta;run (init-compiler []))
-                                               (case> (#e;Success outputG)
-                                                      (  (:!  outputG))
-
-                                                      (#e;Error error)
-                                                      false)))]
-
-                                    ["char" Int valueC i.=
-                                     (|> (code;int valueC) (~) "jvm convert long-to-int" "jvm convert int-to-char" (`))
-                                     "jvm convert char-to-long"]
-                                    ["java.lang.Long" Int valueL i.=
-                                     (code;int valueL)
-                                     "lux noop"]
-                                    )]
-          ($_ seq
-              
-              (test "java.lang.Double (level 1)"
-                    (|> (do meta;Monad
-                          [#let [inner (|> ("jvm array new" +0 "java.lang.Double" (~ (code;nat size)))
-                                           ("jvm array write" "java.lang.Double" (~ (code;nat idx)) (~ (code;frac valueD)))
-                                           (`))]
-                           sampleI (expressionG;generate (|> ("jvm array new" +1 "java.lang.Double" (~ (code;nat size)))
-                                                             ("jvm array write" "#Array" (~ (code;nat idx)) (~ inner))
-                                                             ("jvm array read" "#Array" (~ (code;nat idx)))
-                                                             ("jvm array read" "java.lang.Double" (~ (code;nat idx)))
-                                                             (`)))]
-                          (@eval;eval sampleI))
-                        (meta;run (init-compiler []))
-                        (case> (#e;Success outputG)
-                               (f.= valueD (:! Frac outputG))
-
-                               (#e;Error error)
-                               false)))
-              (test "jvm array length"
-                    (|> (do meta;Monad
-                          [sampleI (expressionG;generate (` ("jvm array length" ("jvm array new" +0 "java.lang.Object" (~ (code;nat size))))))]
-                          (@eval;eval sampleI))
-                        (meta;run (init-compiler []))
-                        (case> (#e;Success outputG)
-                               (n.= size (:! Nat outputG))
-
-                               (#e;Error error)
-                               false)))
-              )))))
-
-(host;import java.lang.Class
-  (getName [] String))
-
-(def: classes
-  (List Text)
-  (list "java.lang.Object" "java.lang.Class"
-        "java.lang.String" "java.lang.Number"))
-
-(def: instances
-  (List [Text (r;Random ls;Synthesis)])
-  (let [gen-boolean (|> r;bool (:: r;Functor map code;bool))
-        gen-integer (|> r;int (:: r;Functor map code;int))
-        gen-double (|> r;frac (:: r;Functor map code;frac))
-        gen-string (|> (r;text +5) (:: r;Functor map code;text))]
-    (list ["java.lang.Boolean" gen-boolean]
-          ["java.lang.Long" gen-integer]
-          ["java.lang.Double" gen-double]
-          ["java.lang.String" gen-string]
-          ["java.lang.Object" (r;either (r;either gen-boolean
-                                                  gen-integer)
-                                        (r;either gen-double
-                                                  gen-string))])))
-
-(context: "Object."
-  (<| (times +100)
-      (do @
-        [#let [num-classes (list;size classes)]
-         #let [num-instances (list;size instances)]
-         class-idx (|> r;nat (:: @ map (n.% num-classes)))
-         instance-idx (|> r;nat (:: @ map (n.% num-instances)))
-         exception-message (r;text +5)
-         #let [class (maybe;assume (list;nth class-idx classes))
-               [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))
-               exception-message$ (` ["java.lang.String" (~ (code;text exception-message))])]
-         sample r;int
-         monitor r;int
-         instance instance-gen]
-        ($_ seq
-            (test "jvm object null"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm object null?" ("jvm object null"))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (:! Bool outputG)
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm object null?"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm object null?" (~ (code;int sample)))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (not (:! Bool outputG))
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm object synchronized"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm object synchronized" (~ (code;int monitor)) (~ (code;int sample)))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (i.= sample (:! Int outputG))
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm object throw"
-                  (|> (do meta;Monad
-                        [_ @runtime;generate
-                         sampleI (expressionG;generate (` ("lux try" ("lux function" +1 []
-                                                                      ("jvm object throw" ("jvm member invoke constructor"
-                                                                                           "java.lang.Throwable"
-                                                                                           (~ exception-message$)))))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (case (:! (e;Error Top) outputG)
-                               (#e;Error error)
-                               (text;contains? exception-message error)
-
-                               (#e;Success outputG)
-                               false)
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm object class"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm object class" (~ (code;text class)))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (|> outputG (:! Class) (Class.getName []) (text/= class))
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm object instance?"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm object instance?" (~ (code;text instance-class)) (~ instance))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (:! Bool outputG)
-
-                             (#e;Error error)
-                             false)))
-            ))))
-
-(host;import java.util.GregorianCalendar
-  (#static AD int))
-
-(context: "Member [Field]"
-  (<| (times +100)
-      (do @
-        [sample-short (|> r;int (:: @ map (|>. int/abs (i.% 100))))
-         sample-string (r;text +5)
-         other-sample-string (r;text +5)
-         #let [shortS (` ["short" ("jvm convert long-to-short" (~ (code;int sample-short)))])
-               stringS (` ["java.lang.String" (~ (code;text sample-string))])
-               type-codeS (` ["org.omg.CORBA.TypeCode" ("jvm object null")])
-               idl-typeS (` ["org.omg.CORBA.IDLType" ("jvm object null")])
-               value-memberS (` ("jvm member invoke constructor"
-                                 "org.omg.CORBA.ValueMember"
-                                 (~ stringS) (~ stringS) (~ stringS) (~ stringS)
-                                 (~ type-codeS) (~ idl-typeS) (~ shortS)))]]
-        ($_ seq
-            (test "jvm member static get"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm convert int-to-long" ("jvm member static get" "java.util.GregorianCalendar" "AD" "int"))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (i.= GregorianCalendar.AD (:! Int outputG))
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm member static put"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm member static put" "java.awt.datatransfer.DataFlavor" "allHtmlFlavor" "java.awt.datatransfer.DataFlavor"
-                                                           ("jvm member static get" "java.awt.datatransfer.DataFlavor" "allHtmlFlavor" "java.awt.datatransfer.DataFlavor"))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (is hostL;unit (:! Text outputG))
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm member virtual get"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm member virtual get" "org.omg.CORBA.ValueMember" "name" "java.lang.String" (~ value-memberS))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (text/= sample-string (:! Text outputG))
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm member virtual put"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm member virtual get" "org.omg.CORBA.ValueMember" "name" "java.lang.String"
-                                                           ("jvm member virtual put" "org.omg.CORBA.ValueMember" "name" "java.lang.String"
-                                                            (~ (code;text other-sample-string)) (~ value-memberS)))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (text/= other-sample-string (:! Text outputG))
-
-                             (#e;Error error)
-                             false)))
-            ))))
-
-(host;import java.lang.Object)
-
-(host;import (java.util.ArrayList a))
-
-(context: "Member [Method]"
-  (<| (times +100)
-      (do @
-        [sample (|> r;int (:: @ map (|>. int/abs (i.% 100))))
-         #let [object-longS (` ["java.lang.Object" (~ (code;int sample))])
-               intS (` ["int" ("jvm convert long-to-int" (~ (code;int sample)))])
-               coded-intS (` ["java.lang.String" (~ (code;text (int/encode sample)))])
-               array-listS (` ("jvm member invoke constructor" "java.util.ArrayList" (~ intS)))]]
-        ($_ seq
-            (test "jvm member invoke static"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm member invoke static" "java.lang.Long" "decode" "java.lang.Long" (~ coded-intS))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (i.= sample (:! Int outputG))
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm member invoke virtual"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm member invoke virtual" "java.lang.Object" "equals" "boolean"
-                                                           (~ (code;int sample)) (~ object-longS))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (:! Bool outputG)
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm member invoke interface"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate (` ("jvm member invoke interface" "java.util.Collection" "add" "boolean"
-                                                           (~ array-listS) (~ object-longS))))]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (:! Bool outputG)
-
-                             (#e;Error error)
-                             false)))
-            (test "jvm member invoke constructor"
-                  (|> (do meta;Monad
-                        [sampleI (expressionG;generate array-listS)]
-                        (@eval;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (host;instance? ArrayList (:! Object outputG))
-
-                             (#e;Error error)
-                             false)))
-            ))))
diff --git a/new-luxc/test/test/luxc/generator/reference.lux b/new-luxc/test/test/luxc/generator/reference.lux
deleted file mode 100644
index dd522839b..000000000
--- a/new-luxc/test/test/luxc/generator/reference.lux
+++ /dev/null
@@ -1,80 +0,0 @@
-(;module:
-  lux
-  (lux [io]
-       (control [monad #+ do]
-                pipe)
-       (data ["e" error]
-             [text])
-       ["r" math/random]
-       [meta]
-       (meta [code])
-       test)
-  (luxc (host ["$" jvm]
-              (jvm ["$i" inst]))
-        (lang ["ls" synthesis])
-        ["_;" module]
-        (generator [";G" statement]
-                   [";G" eval]
-                   [";G" expression]
-                   [";G" case]
-                   [";G" runtime]))
-  (test/luxc common))
-
-(def: nilI $;Inst runtimeG;noneI)
-
-(def: cursorI
-  $;Inst
-  (|>. ($i;int 3)
-       ($i;array runtimeG;$Tuple)
-       $i;DUP ($i;int 0) ($i;string "") $i;AASTORE
-       $i;DUP ($i;int 1) ($i;long 0) ($i;wrap #$;Long) $i;AASTORE
-       $i;DUP ($i;int 2) ($i;long 0) ($i;wrap #$;Long) $i;AASTORE))
-
-(def: empty-metaI
-  (|>. ($i;int 2)
-       ($i;array runtimeG;$Tuple)
-       $i;DUP ($i;int 0) cursorI $i;AASTORE
-       $i;DUP ($i;int 1) nilI $i;AASTORE))
-
-(context: "Definitions."
-  (<| (times +100)
-      (do @
-        [module-name (|> (r;text +5) (r;filter (|>. (text;contains? "/") not)))
-         def-name (r;text +5)
-         def-value r;int
-         #let [valueI (|>. ($i;long def-value) ($i;wrap #$;Long))]]
-        ($_ seq
-            (test "Can refer to definitions."
-                  (|> (do meta;Monad
-                        [_ (_module;with-module +0 module-name
-                             (statementG;generate-def def-name Int valueI empty-metaI (' {})))
-                         sampleI (expressionG;generate (code;symbol [module-name def-name]))]
-                        (evalG;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success valueG)
-                             (i.= def-value (:! Int valueG))
-
-                             (#e;Error error)
-                             false)))
-            ))))
-
-(context: "Variables."
-  (<| (times +100)
-      (do @
-        [register (|> r;nat (:: @ map (n.% +100)))
-         value r;int]
-        ($_ seq
-            (test "Can refer to local variables/registers."
-                  (|> (do meta;Monad
-                        [sampleI (caseG;generate-let expressionG;generate
-                                                     register
-                                                     (code;int value)
-                                                     (` ((~ (code;int (nat-to-int register))))))]
-                        (evalG;eval sampleI))
-                      (meta;run (init-compiler []))
-                      (case> (#e;Success outputG)
-                             (i.= value (:! Int outputG))
-
-                             (#e;Error error)
-                             false)))
-            ))))
diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux
deleted file mode 100644
index 7c342dbc4..000000000
--- a/new-luxc/test/test/luxc/generator/structure.lux
+++ /dev/null
@@ -1,110 +0,0 @@
-(;module:
-  lux
-  (lux [io]
-       (control [monad #+ do]
-                pipe)
-       (data ["e" error]
-             [maybe]
-             [bool "bool/" Eq]
-             [text "text/" Eq]
-             text/format
-             (coll [array]
-                   [list]))
-       ["r" math/random "r/" Monad]
-       [meta]
-       (meta [code])
-       [host]
-       test)
-  (luxc [";L" host]
-        (lang ["ls" synthesis])
-        (generator [";G" expression]
-                   ["@;" eval]
-                   ["@;" runtime]
-                   ["@;" common]))
-  (test/luxc common))
-
-(host;import java.lang.Integer)
-
-(def: gen-primitive
-  (r;Random ls;Synthesis)
-  (r;either (r;either (r;either (r/wrap (' []))
-                                (r/map code;bool r;bool))
-                      (r;either (r/map code;nat r;nat)
-                                (r/map code;int r;int)))
-            (r;either (r;either (r/map code;deg r;deg)
-                                (r/map code;frac r;frac))
-                      (r/map code;text (r;text +5)))))
-
-(def: (corresponds? [prediction sample])
-  (-> [ls;Synthesis Top] Bool)
-  (case prediction
-    [_ (#;Tuple #;Nil)]
-    (is hostL;unit (:! Text sample))
-
-    (^template [  ]
-      [_ ( prediction')]
-      (case (host;try ( prediction' (:!  sample)))
-        (#e;Success result)
-        result
-
-        (#e;Error error)
-        false))
-    ([#;Bool Bool bool/=]
-     [#;Nat  Nat n.=]
-     [#;Int  Int i.=]
-     [#;Deg  Deg d.=]
-     [#;Frac Frac f.=]
-     [#;Text Text text/=])
-
-    _
-    false
-    ))
-
-(context: "Tuples."
-  (<| (times +100)
-      (do @
-        [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
-         members (r;list size gen-primitive)]
-        (test "Can generate tuple."
-              (|> (do meta;Monad
-                    [sampleI (expressionG;generate (code;tuple members))]
-                    (@eval;eval sampleI))
-                  (meta;run (init-compiler []))
-                  (case> (#e;Success valueG)
-                         (let [valueG (:! (Array Top) valueG)]
-                           (and (n.= size (array;size valueG))
-                                (list;every? corresponds? (list;zip2 members (array;to-list valueG)))))
-
-                         _
-                         false))))))
-
-(context: "Variants."
-  (<| (times +100)
-      (do @
-        [num-tags (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
-         tag (|> r;nat (:: @ map (n.% num-tags)))
-         #let [last? (n.= (n.dec num-tags) tag)]
-         member gen-primitive]
-        (test "Can generate variant."
-              (|> (do meta;Monad
-                    [runtime-bytecode @runtime;generate
-                     sampleI (expressionG;generate (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ member))))]
-                    (@eval;eval sampleI))
-                  (meta;run (init-compiler []))
-                  (case> (#e;Success valueG)
-                         (let [valueG (:! (Array Top) valueG)]
-                           (and (n.= +3 (array;size valueG))
-                                (let [_tag (:! Integer (maybe;assume (array;read +0 valueG)))
-                                      _last? (array;read +1 valueG)
-                                      _value (:! Top (maybe;assume (array;read +2 valueG)))]
-                                  (and (n.= tag (|> _tag host;i2l int-to-nat))
-                                       (case _last?
-                                         (#;Some _last?')
-                                         (and last? (text/= "" (:! Text _last?')))
-
-                                         #;None
-                                         (not last?))
-                                       (corresponds? [member _value])))))
-
-                         _
-                         false))))))
diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
index 333a60353..cda281e04 100644
--- a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
@@ -25,8 +25,8 @@
               (analysis [";A" expression]
                         ["@;" common]
                         ["@" procedure]
-                        (procedure ["@;" host])))
-        (generator ["@;" runtime]))
+                        (procedure ["@;" host]))
+              (translation ["@;" runtime])))
   (../.. common)
   (test/luxc common))
 
diff --git a/new-luxc/test/test/luxc/lang/analysis/type.lux b/new-luxc/test/test/luxc/lang/analysis/type.lux
index 649c33fef..78107ecb6 100644
--- a/new-luxc/test/test/luxc/lang/analysis/type.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/type.lux
@@ -21,8 +21,8 @@
         (lang ["~" analysis]
               (analysis [";A" expression]
                         ["@" type]
-                        ["@;" common]))
-        (generator ["@;" runtime])
+                        ["@;" common])
+              (translation ["@;" runtime]))
         [eval])
   (.. common)
   (test/luxc common))
diff --git a/new-luxc/test/test/luxc/lang/translation/case.lux b/new-luxc/test/test/luxc/lang/translation/case.lux
new file mode 100644
index 000000000..3a8608ea7
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/case.lux
@@ -0,0 +1,101 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data ["e" error]
+             text/format
+             (coll [list]))
+       ["r" math/random "r/" Monad]
+       [meta]
+       (meta [code])
+       test)
+  (luxc (lang ["ls" synthesis]
+              (translation ["@" case]
+                           [";T" expression]
+                           ["@;" eval]
+                           ["@;" runtime]
+                           ["@;" common])))
+  (test/luxc common))
+
+(def: struct-limit Nat +10)
+
+(def: (tail? size idx)
+  (-> Nat Nat Bool)
+  (n.= (n.dec size) idx))
+
+(def: gen-case
+  (r;Random [ls;Synthesis ls;Path])
+  (<| r;rec (function [gen-case])
+      (`` ($_ r;either
+              (r/wrap [(' []) (' ("lux case pop"))])
+              (~~ (do-template [ ]
+                    [(do r;Monad
+                       [value ]
+                       (wrap [( value) ( value)]))]
+
+                    [r;bool code;bool]
+                    [r;nat code;nat]
+                    [r;int code;int]
+                    [r;deg code;deg]
+                    [r;frac code;frac]
+                    [(r;text +5) code;text]))
+              (do r;Monad
+                [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
+                 idx (|> r;nat (:: @ map (n.% size)))
+                 [subS subP] gen-case
+                 #let [caseS (` [(~@ (list;concat (list (list;repeat idx (' []))
+                                                        (list subS)
+                                                        (list;repeat (|> size n.dec (n.- idx)) (' [])))))])
+                       caseP (if (tail? size idx)
+                               (` ("lux case tuple right" (~ (code;nat idx)) (~ subP)))
+                               (` ("lux case tuple left" (~ (code;nat idx)) (~ subP))))]]
+                (wrap [caseS caseP]))
+              (do r;Monad
+                [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
+                 idx (|> r;nat (:: @ map (n.% size)))
+                 [subS subP] gen-case
+                 #let [caseS (` ((~ (code;nat idx)) (~ (code;bool (tail? size idx))) (~ subS)))
+                       caseP (if (tail? size idx)
+                               (` ("lux case variant right" (~ (code;nat idx)) (~ subP)))
+                               (` ("lux case variant left" (~ (code;nat idx)) (~ subP))))]]
+                (wrap [caseS caseP]))
+              ))))
+
+(context: "Pattern-matching."
+  (<| (times +100)
+      (do @
+        [[valueS pathS] gen-case
+         to-bind r;nat]
+        ($_ seq
+            (test "Can generate pattern-matching."
+                  (|> (do meta;Monad
+                        [runtime-bytecode @runtime;generate
+                         sampleI (@;generate-case expressionT;generate
+                                                  valueS
+                                                  (` ("lux case alt"
+                                                      ("lux case seq" (~ pathS)
+                                                       ("lux case exec" true))
+                                                      ("lux case seq" ("lux case bind" +0)
+                                                       ("lux case exec" false)))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success valueT)
+                             (:! Bool valueT)
+
+                             (#e;Error error)
+                             false)))
+            (test "Can bind values."
+                  (|> (do meta;Monad
+                        [runtime-bytecode @runtime;generate
+                         sampleI (@;generate-case expressionT;generate
+                                                  (code;nat to-bind)
+                                                  (` ("lux case seq" ("lux case bind" +0)
+                                                      ("lux case exec" (0)))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success valueT)
+                             (n.= to-bind (:! Nat valueT))
+
+                             _
+                             false)))))))
diff --git a/new-luxc/test/test/luxc/lang/translation/function.lux b/new-luxc/test/test/luxc/lang/translation/function.lux
new file mode 100644
index 000000000..1896adff3
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/function.lux
@@ -0,0 +1,99 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data [product]
+             [maybe]
+             ["e" error]
+             (coll ["a" array]
+                   [list "list/" Functor]))
+       ["r" math/random "r/" Monad]
+       [meta]
+       (meta [code])
+       [host]
+       test)
+  (luxc (lang ["ls" synthesis]
+              (translation [";T" expression]
+                           ["@;" eval]
+                           ["@;" runtime]
+                           ["@;" common])))
+  (test/luxc common))
+
+(def: arity-limit Nat +10)
+
+(def: arity
+  (r;Random ls;Arity)
+  (|> r;nat (r/map (|>. (n.% arity-limit) (n.max +1)))))
+
+(def: gen-function
+  (r;Random [ls;Arity Nat ls;Synthesis])
+  (do r;Monad
+    [arity arity
+     arg (|> r;nat (:: @ map (n.% arity)))
+     #let [functionS (` ("lux function" (~ (code;nat arity)) []
+                         ((~ (code;int (nat-to-int (n.inc arg)))))))]]
+    (wrap [arity arg functionS])))
+
+(context: "Function."
+  (<| (times +100)
+      (do @
+        [[arity arg functionS] gen-function
+         cut-off (|> r;nat (:: @ map (n.% arity)))
+         args (r;list arity r;nat)
+         #let [arg-value (maybe;assume (list;nth arg args))
+               argsS (list/map code;nat args)
+               last-arg (n.dec arity)
+               cut-off (|> cut-off (n.min (n.dec last-arg)))]]
+        ($_ seq
+            (test "Can read arguments."
+                  (|> (do meta;Monad
+                        [runtime-bytecode @runtime;generate
+                         sampleI (expressionT;generate (` ("lux call" (~ functionS) (~@ argsS))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success valueT)
+                             (n.= arg-value (:! Nat valueT))
+
+                             (#e;Error error)
+                             false)))
+            (test "Can partially apply functions."
+                  (or (n.= +1 arity)
+                      (|> (do meta;Monad
+                            [#let [partial-arity (n.inc cut-off)
+                                   preS (list;take partial-arity argsS)
+                                   postS (list;drop partial-arity argsS)]
+                             runtime-bytecode @runtime;generate
+                             sampleI (expressionT;generate (` ("lux call"
+                                                               ("lux call" (~ functionS) (~@ preS))
+                                                               (~@ postS))))]
+                            (@eval;eval sampleI))
+                          (meta;run (init-compiler []))
+                          (case> (#e;Success valueT)
+                                 (n.= arg-value (:! Nat valueT))
+
+                                 (#e;Error error)
+                                 false))))
+            (test "Can read environment."
+                  (or (n.= +1 arity)
+                      (|> (do meta;Monad
+                            [#let [env (|> (list;n.range +0 cut-off)
+                                           (list/map (|>. n.inc nat-to-int)))
+                                   super-arity (n.inc cut-off)
+                                   arg-var (if (n.<= cut-off arg)
+                                             (|> arg n.inc nat-to-int (i.* -1))
+                                             (|> arg n.inc (n.- super-arity) nat-to-int))
+                                   sub-arity (|> arity (n.- super-arity))
+                                   functionS (` ("lux function" (~ (code;nat super-arity)) []
+                                                 ("lux function" (~ (code;nat sub-arity)) [(~@ (list/map code;int env))]
+                                                  ((~ (code;int arg-var))))))]
+                             runtime-bytecode @runtime;generate
+                             sampleI (expressionT;generate (` ("lux call" (~ functionS) (~@ argsS))))]
+                            (@eval;eval sampleI))
+                          (meta;run (init-compiler []))
+                          (case> (#e;Success valueT)
+                                 (n.= arg-value (:! Nat valueT))
+
+                                 (#e;Error error)
+                                 false))))
+            ))))
diff --git a/new-luxc/test/test/luxc/lang/translation/primitive.lux b/new-luxc/test/test/luxc/lang/translation/primitive.lux
new file mode 100644
index 000000000..8604ed369
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/primitive.lux
@@ -0,0 +1,62 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data text/format
+             ["e" error]
+             [bool "B/" Eq]
+             [text "T/" Eq])
+       ["r" math/random]
+       [meta]
+       (meta [code])
+       test)
+  (luxc [";L" host]
+        (lang ["ls" synthesis]
+              (translation [";T" expression]
+                           ["@;" runtime]
+                           ["@;" eval]
+                           ["@;" common])))
+  (test/luxc common))
+
+(context: "Primitives."
+  (<| (times +100)
+      (do @
+        [%bool% r;bool
+         %nat% r;nat
+         %int% r;int
+         %deg% r;deg
+         %frac% r;frac
+         %text% (r;text +5)]
+        (with-expansions
+          [ (do-template [    ]
+                     [(test (format "Can generate "  ".")
+                            (|> (do meta;Monad
+                                  [sampleI (expressionT;generate ( ))]
+                                  (@eval;eval sampleI))
+                                (meta;run (init-compiler []))
+                                (case> (#e;Success valueT)
+                                       (  (:!  valueT))
+
+                                       _
+                                       false)))]
+
+                     ["bool" Bool code;bool %bool% B/=]
+                     ["nat"  Nat  code;nat  %nat%  n.=]
+                     ["int"  Int  code;int  %int%  i.=]
+                     ["deg"  Deg  code;deg  %deg%  d.=]
+                     ["frac" Frac code;frac %frac% f.=]
+                     ["text" Text code;text %text% T/=])]
+          ($_ seq
+              (test "Can generate unit."
+                    (|> (do meta;Monad
+                          [sampleI (expressionT;generate (' []))]
+                          (@eval;eval sampleI))
+                        (meta;run (init-compiler []))
+                        (case> (#e;Success valueT)
+                               (is hostL;unit (:! Text valueT))
+
+                               _
+                               false)))
+              
+              )))))
diff --git a/new-luxc/test/test/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/test/test/luxc/lang/translation/procedure/common.jvm.lux
new file mode 100644
index 000000000..8c44007d0
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/procedure/common.jvm.lux
@@ -0,0 +1,367 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data text/format
+             [bit]
+             ["e" error]
+             [bool "bool/" Eq]
+             [text "text/" Eq]
+             [number "nat/" Interval "int/" Interval "real/" Interval "deg/" Interval]
+             (coll ["a" array]
+                   [list]))
+       ["r" math/random]
+       [meta]
+       (meta [code])
+       [host]
+       test)
+  (luxc (lang ["ls" synthesis]
+              (translation [";T" expression]
+                           ["@;" eval]
+                           ["@;" runtime]
+                           ["@;" common])))
+  (test/luxc common))
+
+(context: "Bit procedures"
+  (<| (times +100)
+      (do @
+        [param r;nat
+         subject r;nat]
+        (with-expansions [ (do-template [ ]
+                                     [(test 
+                                            (|> (do meta;Monad
+                                                  [sampleI (expressionT;generate (` ( (~ (code;nat subject))
+                                                                                            (~ (code;nat param)))))]
+                                                  (@eval;eval sampleI))
+                                                (meta;run (init-compiler []))
+                                                (case> (#e;Success valueT)
+                                                       (n.= ( param subject) (:! Nat valueT))
+
+                                                       _
+                                                       false)))]
+
+                                     ["bit and"                  bit;and]
+                                     ["bit or"                   bit;or]
+                                     ["bit xor"                  bit;xor]
+                                     ["bit shift-left"           bit;shift-left]
+                                     ["bit unsigned-shift-right" bit;shift-right]
+                                     )]
+          ($_ seq
+              (test "bit count"
+                    (|> (do meta;Monad
+                          [sampleI (expressionT;generate (` ("bit count" (~ (code;nat subject)))))]
+                          (@eval;eval sampleI))
+                        (meta;run (init-compiler []))
+                        (case> (#e;Success valueT)
+                               (n.= (bit;count subject) (:! Nat valueT))
+
+                               _
+                               false)))
+
+              
+              (test "bit shift-right"
+                    (|> (do meta;Monad
+                          [sampleI (expressionT;generate (` ("bit shift-right"
+                                                             (~ (code;int (nat-to-int subject)))
+                                                             (~ (code;nat param)))))]
+                          (@eval;eval sampleI))
+                        (meta;run (init-compiler []))
+                        (case> (#e;Success valueT)
+                               (i.= (bit;signed-shift-right param (nat-to-int subject))
+                                    (:! Int valueT))
+
+                               _
+                               false)))
+              )))))
+
+(context: "Nat procedures"
+  (<| (times +100)
+      (do @
+        [param (|> r;nat (r;filter (|>. (n.= +0) not)))
+         subject r;nat]
+        (`` ($_ seq
+                (~~ (do-template [ ]
+                      [(test 
+                             (|> (do meta;Monad
+                                   [sampleI (expressionT;generate (` ()))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueT)
+                                        (n.=  (:! Nat valueT))
+
+                                        _
+                                        false)))]
+
+                      ["nat min" nat/bottom]
+                      ["nat max" nat/top]
+                      ))
+                (~~ (do-template [   ]
+                      [(test 
+                             (|> (do meta;Monad
+                                   [sampleI (expressionT;generate (` ( (~ (code;nat subject)))))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueT)
+                                        ( ( subject) (:!  valueT))
+
+                                        _
+                                        false)))]
+
+                      ["nat to-int"  Int  nat-to-int     i.=]
+                      ["nat to-char" Text text;from-code text/=]
+                      ))
+                (~~ (do-template [   ]
+                      [(test 
+                             (|> (do meta;Monad
+                                   [runtime-bytecode @runtime;generate
+                                    sampleI (expressionT;generate (` ( (~ (code;nat subject)) (~ (code;nat param)))))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueT)
+                                        ( ( param subject) (:!  valueT))
+
+                                        _
+                                        false)))]
+
+                      ["nat +" n.+ Nat  n.=]
+                      ["nat -" n.- Nat  n.=]
+                      ["nat *" n.* Nat  n.=]
+                      ["nat /" n./ Nat  n.=]
+                      ["nat %" n.% Nat  n.=]
+                      ["nat =" n.= Bool bool/=]
+                      ["nat <" n.< Bool bool/=]
+                      ))
+                )))))
+
+(context: "Int procedures"
+  (<| (times +100)
+      (do @
+        [param (|> r;int (r;filter (|>. (i.= 0) not)))
+         subject r;int]
+        (with-expansions [ (do-template [ ]
+                                      [(test 
+                                             (|> (do meta;Monad
+                                                   [sampleI (expressionT;generate (` ()))]
+                                                   (@eval;eval sampleI))
+                                                 (meta;run (init-compiler []))
+                                                 (case> (#e;Success valueT)
+                                                        (i.=  (:! Int valueT))
+
+                                                        _
+                                                        false)))]
+
+                                      ["int min" int/bottom]
+                                      ["int max" int/top]
+                                      )
+                           (do-template [   ]
+                                    [(test 
+                                           (|> (do meta;Monad
+                                                 [sampleI (expressionT;generate (` ( (~ (code;int subject)))))]
+                                                 (@eval;eval sampleI))
+                                               (meta;run (init-compiler []))
+                                               (case> (#e;Success valueT)
+                                                      ( ( subject) (:!  valueT))
+
+                                                      _
+                                                      false)))]
+
+                                    ["int to-nat"  Nat  int-to-nat  n.=]
+                                    ["int to-frac" Frac int-to-frac f.=]
+                                    )
+                           (do-template [   ]
+                                     [(test 
+                                            (|> (do meta;Monad
+                                                  [runtime-bytecode @runtime;generate
+                                                   sampleI (expressionT;generate (` ( (~ (code;int subject)) (~ (code;int param)))))]
+                                                  (@eval;eval sampleI))
+                                                (meta;run (init-compiler []))
+                                                (case> (#e;Success valueT)
+                                                       ( ( param subject) (:!  valueT))
+
+                                                       _
+                                                       false)))]
+
+                                     ["int +" i.+ Int  i.=]
+                                     ["int -" i.- Int  i.=]
+                                     ["int *" i.* Int  i.=]
+                                     ["int /" i./ Int  i.=]
+                                     ["int %" i.% Int  i.=]
+                                     ["int =" i.= Bool bool/=]
+                                     ["int <" i.< Bool bool/=]
+                                     )]
+          ($_ seq
+              
+              
+              
+              )))))
+
+(context: "Frac procedures [Part 1]"
+  (<| (times +100)
+      (do @
+        [param (|> r;frac (r;filter (|>. (f.= 0.0) not)))
+         subject r;frac]
+        (with-expansions [ (do-template [   ]
+                                     [(test 
+                                            (|> (do meta;Monad
+                                                  [runtime-bytecode @runtime;generate
+                                                   sampleI (expressionT;generate (` ( (~ (code;frac subject)) (~ (code;frac param)))))]
+                                                  (@eval;eval sampleI))
+                                                (meta;run (init-compiler []))
+                                                (case> (#e;Success valueT)
+                                                       ( ( param subject) (:!  valueT))
+
+                                                       _
+                                                       false)))]
+
+                                     ["frac +" f.+ Frac f.=]
+                                     ["frac -" f.- Frac f.=]
+                                     ["frac *" f.* Frac f.=]
+                                     ["frac /" f./ Frac f.=]
+                                     ["frac %" f.% Frac f.=]
+                                     ["frac =" f.= Bool bool/=]
+                                     ["frac <" f.< Bool bool/=]
+                                     )]
+          ($_ seq
+              
+              )))))
+
+(context: "Frac procedures [Part 2]"
+  (<| (times +100)
+      (do @
+        [param (|> r;frac (r;filter (|>. (f.= 0.0) not)))
+         subject r;frac]
+        (with-expansions [ (do-template [ ]
+                                      [(test 
+                                             (|> (do meta;Monad
+                                                   [sampleI (expressionT;generate (` ()))]
+                                                   (@eval;eval sampleI))
+                                                 (meta;run (init-compiler []))
+                                                 (case> (#e;Success valueT)
+                                                        ( (:! Frac valueT))
+
+                                                        _
+                                                        false)))]
+
+                                      ["frac min" (f.= real/bottom)]
+                                      ["frac max" (f.= real/top)]
+                                      ["frac not-a-number" number;not-a-number?]
+                                      ["frac positive-infinity" (f.= number;positive-infinity)]
+                                      ["frac negative-infinity" (f.= number;negative-infinity)]
+                                      ["frac smallest" (f.= (_lux_proc [ "frac" "smallest-value"] []))]
+                                      )
+                           (do-template [   ]
+                                    [(test 
+                                           (|> (do meta;Monad
+                                                 [runtime-bytecode @runtime;generate
+                                                  sampleI (expressionT;generate (` ( (~ (code;frac subject)))))]
+                                                 (@eval;eval sampleI))
+                                               (meta;run (init-compiler []))
+                                               (case> (#e;Success valueT)
+                                                      ( ( subject) (:!  valueT))
+
+                                                      _
+                                                      false)))]
+
+                                    ["frac to-int" Int frac-to-int i.=]
+                                    ["frac to-deg" Deg frac-to-deg d.=]
+                                    )]
+          ($_ seq
+              
+              
+              (test "frac encode|decode"
+                    (|> (do meta;Monad
+                          [runtime-bytecode @runtime;generate
+                           sampleI (expressionT;generate (` ("frac decode" ("frac encode" (~ (code;frac subject))))))]
+                          (@eval;eval sampleI))
+                        (meta;run (init-compiler []))
+                        (case> (^multi (#e;Success valueT)
+                                       [(:! (Maybe Frac) valueT) (#;Some value)])
+                               (f.= subject value)
+
+                               _
+                               false)))
+              )))))
+
+(def: (above-threshold value)
+  (-> Deg Deg)
+  (let [threshold .000000001 #( 1/(2^30) )#]
+    (if (d.< threshold value)
+      (d.+ threshold value)
+      value)))
+
+(context: "Deg procedures"
+  (<| (times +100)
+      (do @
+        [param (|> r;deg (:: @ map above-threshold))
+         special r;nat
+         subject (|> r;deg (:: @ map above-threshold))]
+        (`` ($_ seq
+                (~~ (do-template [ ]
+                      [(test 
+                             (|> (do meta;Monad
+                                   [sampleI (expressionT;generate (` ()))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueT)
+                                        (d.=  (:! Deg valueT))
+
+                                        _
+                                        false)))]
+
+                      ["deg min" deg/bottom]
+                      ["deg max" deg/top]
+                      ))
+                (~~ (do-template [   ]
+                      [(test 
+                             (|> (do meta;Monad
+                                   [runtime-bytecode @runtime;generate
+                                    sampleI (expressionT;generate (` ( (~ (code;deg subject)))))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueT)
+                                        ( ( subject) (:!  valueT))
+
+                                        _
+                                        false)))]
+
+                      ["deg to-frac" Frac deg-to-frac f.=]
+                      ))
+                (~~ (do-template [   ]
+                      [(test 
+                             (|> (do meta;Monad
+                                   [runtime-bytecode @runtime;generate
+                                    sampleI (expressionT;generate (` ( (~ (code;deg subject)) (~ (code;deg param)))))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueT)
+                                        ( ( param subject) (:!  valueT))
+
+                                        _
+                                        false)))]
+
+                      ["deg +" d.+ Deg  d.=]
+                      ["deg -" d.- Deg  d.=]
+                      ["deg *" d.* Deg  d.=]
+                      ["deg /" d./ Deg  d.=]
+                      ["deg %" d.% Deg  d.=]
+                      ["deg =" d.= Bool bool/=]
+                      ["deg <" d.< Bool bool/=]
+                      ))
+                (~~ (do-template [   ]
+                      [(test 
+                             (|> (do meta;Monad
+                                   [runtime-bytecode @runtime;generate
+                                    sampleI (expressionT;generate (` ( (~ (code;deg subject)) (~ (code;nat special)))))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueT)
+                                        ( ( special subject) (:!  valueT))
+
+                                        _
+                                        false)))]
+
+                      ["deg scale"      d.scale      Deg d.=]
+                      ["deg reciprocal" d.reciprocal Deg d.=]
+                      ))
+                )))))
diff --git a/new-luxc/test/test/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/translation/procedure/host.jvm.lux
new file mode 100644
index 000000000..35453c44b
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/procedure/host.jvm.lux
@@ -0,0 +1,614 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data [maybe]
+             ["e" error]
+             [bit]
+             [bool "bool/" Eq]
+             [number "int/" Number Codec]
+             [text "text/" Eq]
+             text/format
+             (coll [list]))
+       ["r" math/random "r/" Monad]
+       [meta]
+       (meta [code])
+       [host]
+       test)
+  (luxc [";L" host]
+        (lang ["ls" synthesis]
+              (translation [";T" expression]
+                           ["@;" eval]
+                           ["@;" runtime]
+                           ["@;" common])))
+  (test/luxc common))
+
+(context: "Conversions [Part 1]"
+  (<| (times +100)
+      (do @
+        [int-sample (|> r;int (:: @ map (i.% 128)))
+         #let [frac-sample (int-to-frac int-sample)]]
+        (with-expansions [<2step> (do-template [     ]
+                                    [(test (format  " / " )
+                                           (|> (do meta;Monad
+                                                 [sampleI (expressionT;generate (|> (~ ( ))   (`)))]
+                                                 (@eval;eval sampleI))
+                                               (meta;run (init-compiler []))
+                                               (case> (#e;Success valueT)
+                                                      (  (:!  valueT))
+
+                                                      (#e;Error error)
+                                                      false)))]
+
+                                    ["jvm convert double-to-float" "jvm convert float-to-double" code;frac frac-sample Frac f.=]
+                                    ["jvm convert double-to-int"   "jvm convert int-to-double" code;frac frac-sample Frac f.=]
+                                    ["jvm convert double-to-long"  "jvm convert long-to-double" code;frac frac-sample Frac f.=]
+
+                                    ["jvm convert long-to-float" "jvm convert float-to-long" code;int int-sample Int i.=]
+                                    ["jvm convert long-to-int" "jvm convert int-to-long" code;int int-sample Int i.=]
+                                    ["jvm convert long-to-short" "jvm convert short-to-long" code;int int-sample Int i.=]
+                                    ["jvm convert long-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=]
+                                    )]
+          ($_ seq
+              <2step>
+              )))))
+
+(context: "Conversions [Part 2]"
+  (<| (times +100)
+      (do @
+        [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs)))
+         #let [frac-sample (int-to-frac int-sample)]]
+        (`` ($_ seq
+                (~~ (do-template [      ]
+                      [(test (format  " / "  " / " )
+                             (|> (do meta;Monad
+                                   [sampleI (expressionT;generate (|> (~ ( ))    (`)))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueT)
+                                        (  (:!  valueT))
+
+                                        (#e;Error error)
+                                        false)))]
+
+                      ["jvm convert long-to-int"   "jvm convert int-to-char"  "jvm convert char-to-long"  code;int int-sample Int i.=]
+                      ["jvm convert long-to-int"   "jvm convert int-to-byte"  "jvm convert byte-to-long"  code;int int-sample Int i.=]
+                      ["jvm convert long-to-int"   "jvm convert int-to-short" "jvm convert short-to-long" code;int int-sample Int i.=]
+                      ["jvm convert long-to-float" "jvm convert float-to-int" "jvm convert int-to-long"   code;int int-sample Int i.=]
+                      ["jvm convert long-to-int"   "jvm convert int-to-float" "jvm convert float-to-long" code;int int-sample Int i.=]
+                      ))
+                )))))
+
+(context: "Conversions [Part 3]"
+  (<| (times +100)
+      (do @
+        [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs)))
+         #let [frac-sample (int-to-frac int-sample)]]
+        (`` ($_ seq
+                (~~ (do-template [       ]
+                      [(test (format  " / "  " / " )
+                             (|> (do meta;Monad
+                                   [sampleI (expressionT;generate (|> (~ ( ))     (`)))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueT)
+                                        (  (:!  valueT))
+
+                                        (#e;Error error)
+                                        false)))]
+
+                      ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=]
+                      ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-short" "jvm convert short-to-long" code;int int-sample Int i.=]
+                      ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-int" "jvm convert int-to-long" code;int int-sample Int i.=]
+                      ))
+                )))))
+
+(def: gen-nat
+  (r;Random Nat)
+  (|> r;nat
+      (r/map (n.% +128))
+      (r;filter (|>. (n.= +0) not))))
+
+(def: gen-int
+  (r;Random Int)
+  (|> gen-nat (r/map nat-to-int)))
+
+(def: gen-frac
+  (r;Random Frac)
+  (|> gen-int (r/map int-to-frac)))
+
+(do-template [      <+> <-> <*>  <%> 
 ]
+  [(context: (format "Arithmetic ["  "]")
+     (<| (times +100)
+         (do @
+           [param 
+            #let [subject ( param)]]
+           (with-expansions [ (do-template [ ]
+                                       [(test 
+                                              (|> (do meta;Monad
+                                                    [sampleI (expressionT;generate (` ( ((~ (code;text ))
+                                                                                               (
 (~ ( subject)))
+                                                                                               (
 (~ ( param)))))))]
+                                                    (@eval;eval sampleI))
+                                                  (meta;run (init-compiler []))
+                                                  (case> (#e;Success valueT)
+                                                         ( ( param subject)
+                                                                 (:!  valueT))
+
+                                                         (#e;Error error)
+                                                         false)))]
+
+                                       [(format "jvm "  " +") <+>]
+                                       [(format "jvm "  " -") <->]
+                                       [(format "jvm "  " *") <*>]
+                                       [(format "jvm "  " /") ]
+                                       [(format "jvm "  " %") <%>]
+                                       )]
+             ($_ seq
+                 
+                 )))))]
+
+  ["int" gen-int code;int Int i.= (i.* 10) i.+ i.- i.* i./ i.% "jvm convert long-to-int" "jvm convert int-to-long"]
+  ["long" gen-int code;int Int i.= (i.* 10) i.+ i.- i.* i./ i.% "lux noop" "lux noop"]
+  ["float" gen-frac code;frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% "jvm convert double-to-float" "jvm convert float-to-double"]
+  ["double" gen-frac code;frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% "lux noop" "lux noop"]
+  )
+
+(do-template [  ]
+  [(context: (format "Bit-wise ["  "] { Combiners ]")
+     (<| (times +100)
+         (do @
+           [param gen-nat
+            subject gen-nat]
+           (`` ($_ seq
+                   (~~ (do-template [ ]
+                         [(test 
+                                (|> (do meta;Monad
+                                      [sampleI (expressionT;generate (` ( ((~ (code;text ))
+                                                                                 ( (~ (code;nat subject)))
+                                                                                 ( (~ (code;nat param)))))))]
+                                      (@eval;eval sampleI))
+                                    (meta;run (init-compiler []))
+                                    (case> (#e;Success valueT)
+                                           (n.= ( param subject)
+                                                (:! Nat valueT))
+
+                                           (#e;Error error)
+                                           false)))]
+
+                         [(format "jvm "  " and") bit;and]
+                         [(format "jvm "  " or") bit;or]
+                         [(format "jvm "  " xor") bit;xor]
+                         ))
+                   )))))]
+
+  ["int" "jvm convert int-to-long" "jvm convert long-to-int"]
+  ["long" "lux noop" "lux noop"]
+  )
+
+(do-template [  ]
+  [(context: (format "Bit-wise ["  "] { Shifters }")
+     (<| (times +100)
+         (do @
+           [param gen-nat
+            subject gen-nat
+            #let [shift (n.% +10 param)]]
+           (`` ($_ seq
+                   (~~ (do-template [     
]
+                         [(test 
+                                (|> (do meta;Monad
+                                      [sampleI (expressionT;generate (` ( ((~ (code;text ))
+                                                                                 ( (~ (
 subject)))
+                                                                                 ("jvm convert long-to-int" (~ (code;nat shift)))))))]
+                                      (@eval;eval sampleI))
+                                    (meta;run (init-compiler []))
+                                    (case> (#e;Success valueT)
+                                           ( ( shift ( subject))
+                                                   (:!  valueT))
+
+                                           (#e;Error error)
+                                           false)))]
+
+                         [(format "jvm "  " shl") bit;shift-left Nat n.= id code;nat]
+                         [(format "jvm "  " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int code;int)]
+                         [(format "jvm "  " ushr") bit;shift-right Nat n.= id code;nat]
+                         ))
+                   )))))]
+
+  ["int" "jvm convert int-to-long" "jvm convert long-to-int"]
+  ["long" "lux noop" "lux noop"]
+  )
+
+(do-template [   <=> <<> 
]
+  [(context: (format "Order ["  "]")
+     (<| (times +100)
+         (do @
+           [param 
+            subject ]
+           (with-expansions [ (do-template [ ]
+                                       [(test 
+                                              (|> (do meta;Monad
+                                                    [sampleI (expressionT;generate (` ((~ (code;text ))
+                                                                                       (
 (~ ( subject)))
+                                                                                       (
 (~ ( param))))))]
+                                                    (@eval;eval sampleI))
+                                                  (meta;run (init-compiler []))
+                                                  (case> (#e;Success valueT)
+                                                         (bool/= ( param subject)
+                                                                 (:! Bool valueT))
+
+                                                         (#e;Error error)
+                                                         false)))]
+
+                                       [(format "jvm "  " =") <=>]
+                                       [(format "jvm "  " <") <<>]
+                                       )]
+             ($_ seq
+                 
+                 )))))]
+
+  ["int" gen-int code;int i.= i.< "jvm convert long-to-int"]
+  ["long" gen-int code;int i.= i.< "lux noop"]
+  ["float" gen-frac code;frac f.= f.< "jvm convert double-to-float"]
+  ["double" gen-frac code;frac f.= f.< "lux noop"]
+  ["char" gen-int code;int i.= i.< "jvm convert long-to-char"]
+  )
+
+(def: (jvm//array//new dimension class size)
+  (-> Nat Text Nat ls;Synthesis)
+  (` ("jvm array new" (~ (code;nat dimension)) (~ (code;text class)) (~ (code;nat size)))))
+
+(def: (jvm//array//write class idx inputS arrayS)
+  (-> Text Nat ls;Synthesis ls;Synthesis ls;Synthesis)
+  (` ("jvm array write" (~ (code;text class)) (~ (code;nat idx)) (~ inputS) (~ arrayS))))
+
+(def: (jvm//array//read class idx arrayS)
+  (-> Text Nat ls;Synthesis ls;Synthesis)
+  (` ("jvm array read" (~ (code;text class)) (~ (code;nat idx)) (~ arrayS))))
+
+(context: "Array [Part 1]"
+  (<| (times +100)
+      (do @
+        [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
+         idx (|> r;nat (:: @ map (n.% size)))
+         valueZ r;bool
+         valueB gen-int
+         valueS gen-int
+         valueI gen-int
+         valueL r;int
+         valueF gen-frac
+         valueD r;frac
+         valueC gen-int]
+        (with-expansions [ (do-template [     ]
+                                    [(test 
+                                           (|> (do meta;Monad
+                                                 [sampleI (expressionT;generate (|> (jvm//array//new +0  size)
+                                                                                    (jvm//array//write  idx )
+                                                                                    (jvm//array//read  idx)
+                                                                                    (~)
+                                                                                    
+                                                                                    (`)))]
+                                                 (@eval;eval sampleI))
+                                               (meta;run (init-compiler []))
+                                               (case> (#e;Success outputZ)
+                                                      (  (:!  outputZ))
+
+                                                      (#e;Error error)
+                                                      false)))]
+
+                                    ["boolean" Bool valueZ bool/= (code;bool valueZ)
+                                     "lux noop"]
+                                    ["byte" Int valueB i.= (|> (code;int valueB) (~) "jvm convert long-to-byte" (`))
+                                     "jvm convert byte-to-long"]
+                                    ["short" Int valueS i.= (|> (code;int valueS) (~) "jvm convert long-to-short" (`))
+                                     "jvm convert short-to-long"]
+                                    ["int" Int valueI i.= (|> (code;int valueI) (~) "jvm convert long-to-int" (`))
+                                     "jvm convert int-to-long"]
+                                    ["long" Int valueL i.= (code;int valueL)
+                                     "lux noop"]
+                                    ["float" Frac valueF f.= (|> (code;frac valueF) (~) "jvm convert double-to-float" (`))
+                                     "jvm convert float-to-double"]
+                                    ["double" Frac valueD f.= (code;frac valueD)
+                                     "lux noop"]
+                                    )]
+          ($_ seq
+              
+              )))))
+
+(context: "Array [Part 2]"
+  (<| (times +100)
+      (do @
+        [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
+         idx (|> r;nat (:: @ map (n.% size)))
+         valueZ r;bool
+         valueB gen-int
+         valueS gen-int
+         valueI gen-int
+         valueL r;int
+         valueF gen-frac
+         valueD r;frac
+         valueC gen-int]
+        (with-expansions [ (do-template [     ]
+                                    [(test 
+                                           (|> (do meta;Monad
+                                                 [sampleI (expressionT;generate (|> (jvm//array//new +0  size)
+                                                                                    (jvm//array//write  idx )
+                                                                                    (jvm//array//read  idx)
+                                                                                    (~)
+                                                                                    
+                                                                                    (`)))]
+                                                 (@eval;eval sampleI))
+                                               (meta;run (init-compiler []))
+                                               (case> (#e;Success outputT)
+                                                      (  (:!  outputT))
+
+                                                      (#e;Error error)
+                                                      false)))]
+
+                                    ["char" Int valueC i.=
+                                     (|> (code;int valueC) (~) "jvm convert long-to-int" "jvm convert int-to-char" (`))
+                                     "jvm convert char-to-long"]
+                                    ["java.lang.Long" Int valueL i.=
+                                     (code;int valueL)
+                                     "lux noop"]
+                                    )]
+          ($_ seq
+              
+              (test "java.lang.Double (level 1)"
+                    (|> (do meta;Monad
+                          [#let [inner (|> ("jvm array new" +0 "java.lang.Double" (~ (code;nat size)))
+                                           ("jvm array write" "java.lang.Double" (~ (code;nat idx)) (~ (code;frac valueD)))
+                                           (`))]
+                           sampleI (expressionT;generate (|> ("jvm array new" +1 "java.lang.Double" (~ (code;nat size)))
+                                                             ("jvm array write" "#Array" (~ (code;nat idx)) (~ inner))
+                                                             ("jvm array read" "#Array" (~ (code;nat idx)))
+                                                             ("jvm array read" "java.lang.Double" (~ (code;nat idx)))
+                                                             (`)))]
+                          (@eval;eval sampleI))
+                        (meta;run (init-compiler []))
+                        (case> (#e;Success outputT)
+                               (f.= valueD (:! Frac outputT))
+
+                               (#e;Error error)
+                               false)))
+              (test "jvm array length"
+                    (|> (do meta;Monad
+                          [sampleI (expressionT;generate (` ("jvm array length" ("jvm array new" +0 "java.lang.Object" (~ (code;nat size))))))]
+                          (@eval;eval sampleI))
+                        (meta;run (init-compiler []))
+                        (case> (#e;Success outputT)
+                               (n.= size (:! Nat outputT))
+
+                               (#e;Error error)
+                               false)))
+              )))))
+
+(host;import java.lang.Class
+  (getName [] String))
+
+(def: classes
+  (List Text)
+  (list "java.lang.Object" "java.lang.Class"
+        "java.lang.String" "java.lang.Number"))
+
+(def: instances
+  (List [Text (r;Random ls;Synthesis)])
+  (let [gen-boolean (|> r;bool (:: r;Functor map code;bool))
+        gen-integer (|> r;int (:: r;Functor map code;int))
+        gen-double (|> r;frac (:: r;Functor map code;frac))
+        gen-string (|> (r;text +5) (:: r;Functor map code;text))]
+    (list ["java.lang.Boolean" gen-boolean]
+          ["java.lang.Long" gen-integer]
+          ["java.lang.Double" gen-double]
+          ["java.lang.String" gen-string]
+          ["java.lang.Object" (r;either (r;either gen-boolean
+                                                  gen-integer)
+                                        (r;either gen-double
+                                                  gen-string))])))
+
+(context: "Object."
+  (<| (times +100)
+      (do @
+        [#let [num-classes (list;size classes)]
+         #let [num-instances (list;size instances)]
+         class-idx (|> r;nat (:: @ map (n.% num-classes)))
+         instance-idx (|> r;nat (:: @ map (n.% num-instances)))
+         exception-message (r;text +5)
+         #let [class (maybe;assume (list;nth class-idx classes))
+               [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))
+               exception-message$ (` ["java.lang.String" (~ (code;text exception-message))])]
+         sample r;int
+         monitor r;int
+         instance instance-gen]
+        ($_ seq
+            (test "jvm object null"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm object null?" ("jvm object null"))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (:! Bool outputT)
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm object null?"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm object null?" (~ (code;int sample)))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (not (:! Bool outputT))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm object synchronized"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm object synchronized" (~ (code;int monitor)) (~ (code;int sample)))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (i.= sample (:! Int outputT))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm object throw"
+                  (|> (do meta;Monad
+                        [_ @runtime;generate
+                         sampleI (expressionT;generate (` ("lux try" ("lux function" +1 []
+                                                                      ("jvm object throw" ("jvm member invoke constructor"
+                                                                                           "java.lang.Throwable"
+                                                                                           (~ exception-message$)))))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (case (:! (e;Error Top) outputT)
+                               (#e;Error error)
+                               (text;contains? exception-message error)
+
+                               (#e;Success outputT)
+                               false)
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm object class"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm object class" (~ (code;text class)))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (|> outputT (:! Class) (Class.getName []) (text/= class))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm object instance?"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm object instance?" (~ (code;text instance-class)) (~ instance))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (:! Bool outputT)
+
+                             (#e;Error error)
+                             false)))
+            ))))
+
+(host;import java.util.GregorianCalendar
+  (#static AD int))
+
+(context: "Member [Field]"
+  (<| (times +100)
+      (do @
+        [sample-short (|> r;int (:: @ map (|>. int/abs (i.% 100))))
+         sample-string (r;text +5)
+         other-sample-string (r;text +5)
+         #let [shortS (` ["short" ("jvm convert long-to-short" (~ (code;int sample-short)))])
+               stringS (` ["java.lang.String" (~ (code;text sample-string))])
+               type-codeS (` ["org.omg.CORBA.TypeCode" ("jvm object null")])
+               idl-typeS (` ["org.omg.CORBA.IDLType" ("jvm object null")])
+               value-memberS (` ("jvm member invoke constructor"
+                                 "org.omg.CORBA.ValueMember"
+                                 (~ stringS) (~ stringS) (~ stringS) (~ stringS)
+                                 (~ type-codeS) (~ idl-typeS) (~ shortS)))]]
+        ($_ seq
+            (test "jvm member static get"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm convert int-to-long" ("jvm member static get" "java.util.GregorianCalendar" "AD" "int"))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (i.= GregorianCalendar.AD (:! Int outputT))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member static put"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm member static put" "java.awt.datatransfer.DataFlavor" "allHtmlFlavor" "java.awt.datatransfer.DataFlavor"
+                                                           ("jvm member static get" "java.awt.datatransfer.DataFlavor" "allHtmlFlavor" "java.awt.datatransfer.DataFlavor"))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (is hostL;unit (:! Text outputT))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member virtual get"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm member virtual get" "org.omg.CORBA.ValueMember" "name" "java.lang.String" (~ value-memberS))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (text/= sample-string (:! Text outputT))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member virtual put"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm member virtual get" "org.omg.CORBA.ValueMember" "name" "java.lang.String"
+                                                           ("jvm member virtual put" "org.omg.CORBA.ValueMember" "name" "java.lang.String"
+                                                            (~ (code;text other-sample-string)) (~ value-memberS)))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (text/= other-sample-string (:! Text outputT))
+
+                             (#e;Error error)
+                             false)))
+            ))))
+
+(host;import java.lang.Object)
+
+(host;import (java.util.ArrayList a))
+
+(context: "Member [Method]"
+  (<| (times +100)
+      (do @
+        [sample (|> r;int (:: @ map (|>. int/abs (i.% 100))))
+         #let [object-longS (` ["java.lang.Object" (~ (code;int sample))])
+               intS (` ["int" ("jvm convert long-to-int" (~ (code;int sample)))])
+               coded-intS (` ["java.lang.String" (~ (code;text (int/encode sample)))])
+               array-listS (` ("jvm member invoke constructor" "java.util.ArrayList" (~ intS)))]]
+        ($_ seq
+            (test "jvm member invoke static"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm member invoke static" "java.lang.Long" "decode" "java.lang.Long" (~ coded-intS))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (i.= sample (:! Int outputT))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member invoke virtual"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm member invoke virtual" "java.lang.Object" "equals" "boolean"
+                                                           (~ (code;int sample)) (~ object-longS))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (:! Bool outputT)
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member invoke interface"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate (` ("jvm member invoke interface" "java.util.Collection" "add" "boolean"
+                                                           (~ array-listS) (~ object-longS))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (:! Bool outputT)
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member invoke constructor"
+                  (|> (do meta;Monad
+                        [sampleI (expressionT;generate array-listS)]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (host;instance? ArrayList (:! Object outputT))
+
+                             (#e;Error error)
+                             false)))
+            ))))
diff --git a/new-luxc/test/test/luxc/lang/translation/reference.lux b/new-luxc/test/test/luxc/lang/translation/reference.lux
new file mode 100644
index 000000000..0bc2bb325
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/reference.lux
@@ -0,0 +1,80 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data ["e" error]
+             [text])
+       ["r" math/random]
+       [meta]
+       (meta [code])
+       test)
+  (luxc (host ["$" jvm]
+              (jvm ["$i" inst]))
+        (lang ["ls" synthesis]
+              (translation [";T" statement]
+                           [";T" eval]
+                           [";T" expression]
+                           [";T" case]
+                           [";T" runtime]))
+        ["_;" module])
+  (test/luxc common))
+
+(def: nilI $;Inst runtimeT;noneI)
+
+(def: cursorI
+  $;Inst
+  (|>. ($i;int 3)
+       ($i;array runtimeT;$Tuple)
+       $i;DUP ($i;int 0) ($i;string "") $i;AASTORE
+       $i;DUP ($i;int 1) ($i;long 0) ($i;wrap #$;Long) $i;AASTORE
+       $i;DUP ($i;int 2) ($i;long 0) ($i;wrap #$;Long) $i;AASTORE))
+
+(def: empty-metaI
+  (|>. ($i;int 2)
+       ($i;array runtimeT;$Tuple)
+       $i;DUP ($i;int 0) cursorI $i;AASTORE
+       $i;DUP ($i;int 1) nilI $i;AASTORE))
+
+(context: "Definitions."
+  (<| (times +100)
+      (do @
+        [module-name (|> (r;text +5) (r;filter (|>. (text;contains? "/") not)))
+         def-name (r;text +5)
+         def-value r;int
+         #let [valueI (|>. ($i;long def-value) ($i;wrap #$;Long))]]
+        ($_ seq
+            (test "Can refer to definitions."
+                  (|> (do meta;Monad
+                        [_ (_module;with-module +0 module-name
+                             (statementT;generate-def def-name Int valueI empty-metaI (' {})))
+                         sampleI (expressionT;generate (code;symbol [module-name def-name]))]
+                        (evalT;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success valueT)
+                             (i.= def-value (:! Int valueT))
+
+                             (#e;Error error)
+                             false)))
+            ))))
+
+(context: "Variables."
+  (<| (times +100)
+      (do @
+        [register (|> r;nat (:: @ map (n.% +100)))
+         value r;int]
+        ($_ seq
+            (test "Can refer to local variables/registers."
+                  (|> (do meta;Monad
+                        [sampleI (caseT;generate-let expressionT;generate
+                                                     register
+                                                     (code;int value)
+                                                     (` ((~ (code;int (nat-to-int register))))))]
+                        (evalT;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputT)
+                             (i.= value (:! Int outputT))
+
+                             (#e;Error error)
+                             false)))
+            ))))
diff --git a/new-luxc/test/test/luxc/lang/translation/structure.lux b/new-luxc/test/test/luxc/lang/translation/structure.lux
new file mode 100644
index 000000000..a8f74ec6a
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/structure.lux
@@ -0,0 +1,110 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do]
+                pipe)
+       (data ["e" error]
+             [maybe]
+             [bool "bool/" Eq]
+             [text "text/" Eq]
+             text/format
+             (coll [array]
+                   [list]))
+       ["r" math/random "r/" Monad]
+       [meta]
+       (meta [code])
+       [host]
+       test)
+  (luxc [";L" host]
+        (lang ["ls" synthesis]
+              (translation [";T" expression]
+                           ["@;" eval]
+                           ["@;" runtime]
+                           ["@;" common])))
+  (test/luxc common))
+
+(host;import java.lang.Integer)
+
+(def: gen-primitive
+  (r;Random ls;Synthesis)
+  (r;either (r;either (r;either (r/wrap (' []))
+                                (r/map code;bool r;bool))
+                      (r;either (r/map code;nat r;nat)
+                                (r/map code;int r;int)))
+            (r;either (r;either (r/map code;deg r;deg)
+                                (r/map code;frac r;frac))
+                      (r/map code;text (r;text +5)))))
+
+(def: (corresponds? [prediction sample])
+  (-> [ls;Synthesis Top] Bool)
+  (case prediction
+    [_ (#;Tuple #;Nil)]
+    (is hostL;unit (:! Text sample))
+
+    (^template [  ]
+      [_ ( prediction')]
+      (case (host;try ( prediction' (:!  sample)))
+        (#e;Success result)
+        result
+
+        (#e;Error error)
+        false))
+    ([#;Bool Bool bool/=]
+     [#;Nat  Nat n.=]
+     [#;Int  Int i.=]
+     [#;Deg  Deg d.=]
+     [#;Frac Frac f.=]
+     [#;Text Text text/=])
+
+    _
+    false
+    ))
+
+(context: "Tuples."
+  (<| (times +100)
+      (do @
+        [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
+         members (r;list size gen-primitive)]
+        (test "Can generate tuple."
+              (|> (do meta;Monad
+                    [sampleI (expressionT;generate (code;tuple members))]
+                    (@eval;eval sampleI))
+                  (meta;run (init-compiler []))
+                  (case> (#e;Success valueT)
+                         (let [valueT (:! (Array Top) valueT)]
+                           (and (n.= size (array;size valueT))
+                                (list;every? corresponds? (list;zip2 members (array;to-list valueT)))))
+
+                         _
+                         false))))))
+
+(context: "Variants."
+  (<| (times +100)
+      (do @
+        [num-tags (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
+         tag (|> r;nat (:: @ map (n.% num-tags)))
+         #let [last? (n.= (n.dec num-tags) tag)]
+         member gen-primitive]
+        (test "Can generate variant."
+              (|> (do meta;Monad
+                    [runtime-bytecode @runtime;generate
+                     sampleI (expressionT;generate (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ member))))]
+                    (@eval;eval sampleI))
+                  (meta;run (init-compiler []))
+                  (case> (#e;Success valueT)
+                         (let [valueT (:! (Array Top) valueT)]
+                           (and (n.= +3 (array;size valueT))
+                                (let [_tag (:! Integer (maybe;assume (array;read +0 valueT)))
+                                      _last? (array;read +1 valueT)
+                                      _value (:! Top (maybe;assume (array;read +2 valueT)))]
+                                  (and (n.= tag (|> _tag host;i2l int-to-nat))
+                                       (case _last?
+                                         (#;Some _last?')
+                                         (and last? (text/= "" (:! Text _last?')))
+
+                                         #;None
+                                         (not last?))
+                                       (corresponds? [member _value])))))
+
+                         _
+                         false))))))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index 5ec79d1e5..88d89ad90 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -19,14 +19,14 @@
                                (case ["_;S" special])
                                ["_;S" function]
                                ["_;S" procedure]
-                               ["_;S" loop]))
-              (generator ["_;G" primitive]
-                         ["_;G" structure]
-                         ["_;G" case]
-                         ["_;G" function]
-                         ["_;G" reference]
-                         (procedure ["_;G" common]
-                                    ["_;G" host]))
+                               ["_;S" loop])
+                    (translation ["_;T" primitive]
+                                 ["_;T" structure]
+                                 ["_;T" case]
+                                 ["_;T" function]
+                                 ["_;T" reference]
+                                 (procedure ["_;T" common]
+                                            ["_;T" host])))
               )))
 
 (program: args
-- 
cgit v1.2.3