aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/generator/case.jvm.lux18
-rw-r--r--new-luxc/source/luxc/generator/common.jvm.lux57
-rw-r--r--new-luxc/source/luxc/generator/eval.jvm.lux5
-rw-r--r--new-luxc/source/luxc/generator/expr.jvm.lux15
-rw-r--r--new-luxc/source/luxc/generator/function.jvm.lux341
-rw-r--r--new-luxc/source/luxc/generator/host/jvm.lux8
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/def.lux17
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux2
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux38
-rw-r--r--new-luxc/source/luxc/generator/reference.jvm.lux26
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux79
-rw-r--r--new-luxc/source/luxc/generator/structure.jvm.lux2
-rw-r--r--new-luxc/source/luxc/host.jvm.lux13
-rw-r--r--new-luxc/source/luxc/lang/synthesis.lux2
-rw-r--r--new-luxc/source/luxc/synthesizer.lux12
-rw-r--r--new-luxc/source/luxc/synthesizer/loop.lux10
-rw-r--r--new-luxc/test/test/luxc/common.lux5
-rw-r--r--new-luxc/test/test/luxc/generator/function.lux96
-rw-r--r--new-luxc/test/test/luxc/synthesizer/function.lux2
-rw-r--r--new-luxc/test/test/luxc/synthesizer/loop.lux2
-rw-r--r--new-luxc/test/tests.lux3
21 files changed, 667 insertions, 86 deletions
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux
index 1f351325e..88b3dd5d3 100644
--- a/new-luxc/source/luxc/generator/case.jvm.lux
+++ b/new-luxc/source/luxc/generator/case.jvm.lux
@@ -3,10 +3,10 @@
(lux (control [monad #+ do])
[macro "lux/" Monad<Lux>])
(luxc (lang ["ls" synthesis])
- (generator (host ["$" jvm]
+ (generator [expr]
+ (host ["$" jvm]
(jvm ["$t" type]
- ["$i" inst]))
- [expr]))
+ ["$i" inst]))))
[../runtime])
(def: $Object $;Type ($t;class "java.lang.Object" (list)))
@@ -24,7 +24,7 @@
(def: peekI
$;Inst
(|>. $i;DUP
- ($i;INVOKESTATIC ../runtime;runtime-name
+ ($i;INVOKESTATIC ../runtime;runtime-class
"pm_peek"
($t;method (list ../runtime;$Stack)
(#;Some $Object)
@@ -33,7 +33,7 @@
(def: popI
$;Inst
- (|>. ($i;INVOKESTATIC ../runtime;runtime-name
+ (|>. ($i;INVOKESTATIC ../runtime;runtime-class
"pm_pop"
($t;method (list ../runtime;$Stack)
(#;Some ../runtime;$Stack)
@@ -42,7 +42,7 @@
(def: pushI
$;Inst
- (|>. ($i;INVOKESTATIC ../runtime;runtime-name
+ (|>. ($i;INVOKESTATIC ../runtime;runtime-class
"pm_push"
($t;method (list ../runtime;$Stack $Object)
(#;Some ../runtime;$Stack)
@@ -124,7 +124,7 @@
(|>. peekI
($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
($i;int (nat-to-int idx))
- ($i;INVOKESTATIC ../runtime;runtime-name
+ ($i;INVOKESTATIC ../runtime;runtime-class
(if tail? "pm_right" "pm_left")
($t;method (list ../runtime;$Tuple $t;int)
(#;Some $Object)
@@ -151,7 +151,7 @@
($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
($i;int (nat-to-int idx))
flagI
- ($i;INVOKESTATIC ../runtime;runtime-name "pm_variant"
+ ($i;INVOKESTATIC ../runtime;runtime-class "pm_variant"
($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
(#;Some ../runtime;$Datum)
(list))
@@ -193,7 +193,7 @@
(wrap (|>. pathI
($i;label @else)
$i;POP
- ($i;INVOKESTATIC ../runtime;runtime-name
+ ($i;INVOKESTATIC ../runtime;runtime-class
"pm_fail"
($t;method (list) #;None (list))
false)
diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux
index 095f41945..1f04f5798 100644
--- a/new-luxc/source/luxc/generator/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/common.jvm.lux
@@ -1,17 +1,16 @@
(;module:
- lux
- (lux [io]
+ [lux #- function]
+ (lux (control ["ex" exception #+ exception:])
+ [io]
(concurrency ["A" atom])
(data ["R" result]
- (coll ["d" dict])
- text/format)
+ (coll ["d" dict]))
[host])
(luxc (generator (host ["$" jvm]
(jvm ["$t" type]
["$d" def]
["$i" inst])))))
-## [Host]
(host;import org.objectweb.asm.Opcodes
(#static V1_6 int))
@@ -22,33 +21,69 @@
(host;import java.lang.ClassLoader
(loadClass [String] (Class Object)))
-## [Types]
(type: #export Bytecode host;Byte-Array)
(type: #export Class-Store (A;Atom (d;Dict Text Bytecode)))
(type: #export Host
{#loader ClassLoader
- #store Class-Store})
+ #store Class-Store
+ #function-class (Maybe Text)})
+
+(exception: Unknown-Class)
+(exception: Class-Already-Stored)
+(exception: No-Function-Being-Compiled)
(def: #export (store-class name byte-code)
(-> Text Bytecode (Lux Unit))
- (function [compiler]
+ (;function [compiler]
(let [store (|> (get@ #;host compiler)
(:! Host)
(get@ #store))]
(if (d;contains? name (|> store A;get io;run))
- (#R;Error (format "Cannot store class that already exists: " name))
+ (ex;throw Class-Already-Stored name)
(#R;Success [compiler (io;run (A;update (d;put name byte-code) store))])
))))
(def: #export (load-class name)
(-> Text (Lux (Class Object)))
- (function [compiler]
+ (;function [compiler]
(let [host (:! Host (get@ #;host compiler))
store (|> host (get@ #store) A;get io;run)]
(if (d;contains? name store)
(#R;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
- (#R;Error (format "Unknown class: " name))))))
+ (ex;throw Unknown-Class name)))))
+
+(def: #export (with-function class expr)
+ (All [a] (-> Text (Lux a) (Lux 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))
+ (#R;Success [compiler' output])
+ (#R;Success [(update@ #;host
+ (|>. (:! Host)
+ (set@ #function-class old-function-class)
+ (:! Void))
+ compiler')
+ output])
+
+ (#R;Error error)
+ (#R;Error error)))))
+
+(def: #export function
+ (Lux Text)
+ (;function [compiler]
+ (let [host (:! Host (get@ #;host compiler))]
+ (case (get@ #function-class host)
+ #;None
+ (ex;throw No-Function-Being-Compiled "")
+
+ (#;Some function-class)
+ (#R;Success [compiler function-class])))))
(def: #export bytecode-version Int Opcodes.V1_6)
diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux
index e6650953f..818c03b66 100644
--- a/new-luxc/source/luxc/generator/eval.jvm.lux
+++ b/new-luxc/source/luxc/generator/eval.jvm.lux
@@ -71,10 +71,9 @@
(host;null)
"java/lang/Object"
(host;null)]))
- ($d;field #$;Public {#$;staticF true #$;finalF true #$;transientF false #$;volatileF false}
+ ($d;field #$;Public $;staticF
eval-field $Object)
- ($d;method #$;Public
- {#$;staticM true #$;finalM false #$;synchronizedM false}
+ ($d;method #$;Public ($_ $;++M $;staticM $;strictM)
"<clinit>"
($t;method (list) #;None (list))
(|>. valueI
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index 0bdebe555..6b6c68fde 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -1,16 +1,20 @@
(;module:
lux
(lux (control monad)
+ (data text/format)
[macro #+ Monad<Lux> "Lux/" Monad<Lux>])
(luxc ["&" base]
(lang ["ls" synthesis])
["&;" analyser]
["&;" synthesizer]
+ (synthesizer [";S" function])
(generator ["&;" common]
["&;" primitive]
["&;" structure]
["&;" eval]
["&;" procedure]
+ ["&;" function]
+ ["&;" reference]
(host ["$" jvm]))))
(def: #export (generate synthesis)
@@ -35,6 +39,17 @@
(#ls;Tuple members)
(&structure;generate-tuple generate members)
+ (#ls;Variable var)
+ (if (functionS;captured? var)
+ (&reference;generate-captured var)
+ (&reference;generate-variable var))
+
+ (#ls;Function arity env body)
+ (&function;generate-function generate env arity body)
+
+ (#ls;Call args function)
+ (&function;generate-call generate function args)
+
(#ls;Procedure name args)
(&procedure;generate-procedure generate name args)
diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux
new file mode 100644
index 000000000..135daf47e
--- /dev/null
+++ b/new-luxc/source/luxc/generator/function.jvm.lux
@@ -0,0 +1,341 @@
+(;module:
+ lux
+ (lux (control [monad #+ do])
+ (data text/format
+ (coll [list "L/" Functor<List> Monoid<List>]))
+ [macro])
+ (luxc ["&" base]
+ (lang ["la" analysis]
+ ["ls" synthesis])
+ ["&;" analyser]
+ ["&;" synthesizer]
+ (synthesizer [function])
+ (generator ["&;" common]
+ ["&;" runtime]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst])))))
+
+
+(def: arity-field Text "arity")
+(def: $Object $;Type ($t;class "java.lang.Object" (list)))
+
+(do-template [<name> <prefix>]
+ [(def: #export (<name> idx)
+ (-> Nat Text)
+ (|> idx nat-to-int %i (format <prefix>)))]
+
+ [captured "c"]
+ [partial "p"]
+ )
+
+(def: (poly-arg? arity)
+ (-> ls;Arity Bool)
+ (n.> +1 arity))
+
+(def: (reset-method class)
+ (-> Text $;Method)
+ ($t;method (list) (#;Some ($t;class class (list))) (list)))
+
+(def: (captured-args env)
+ (-> (List ls;Variable) (List $;Type))
+ (list;repeat (list;size env) $Object))
+
+(def: (init-method env arity)
+ (-> (List ls;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 &runtime;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)))
+ (L/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 &runtime;function-class)
+ (inputsI start max-args)
+ ($i;INVOKEVIRTUAL &runtime;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 ls;Variable) $;Def)
+ (|> (list;enumerate env)
+ (L/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))
+ (L/map (function [idx]
+ ($d;field #$;Private $;finalF (partial idx) $Object)))
+ $d;fuse)
+ id))
+
+(def: (instance class arity env)
+ (-> Text ls;Arity (List ls;Variable) $;Inst)
+ (let [captureI (|> env
+ (L/map (function [source]
+ (if (function;captured? source)
+ ($i;GETFIELD class (captured (function;captured-idx source)) $Object)
+ ($i;ALOAD (int-to-nat source)))))
+ $i;fuse)
+ argsI (if (poly-arg? arity)
+ (|> (nullsI (n.dec arity))
+ (list ($i;int 0))
+ $i;fuse)
+ id)]
+ (|>. ($i;NEW class)
+ $i;DUP
+ captureI
+ argsI
+ ($i;INVOKESPECIAL class "<init>" (init-method env arity) false))))
+
+(def: (with-reset class arity env)
+ (-> Text ls;Arity (List ls;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)))
+ (L/map (function [source]
+ (|>. ($i;ALOAD +0)
+ ($i;GETFIELD class (captured source) $Object))))
+ $i;fuse)
+ argsI (|> (nullsI (n.dec arity))
+ (list ($i;int 0))
+ $i;fuse)]
+ (|>. ($i;NEW class)
+ $i;DUP
+ captureI
+ argsI
+ ($i;INVOKESPECIAL class "<init>" (init-method env arity) false)
+ $i;ARETURN))
+ (|>. ($i;ALOAD +0)
+ $i;ARETURN))))
+
+(def: (with-implementation arity @begin bodyI)
+ (-> Nat $;Label $;Inst $;Def)
+ ($d;method #$;Public $;strictM "impl" (implementation-method arity)
+ (|>. ($i;label @begin)
+ bodyI
+ $i;ARETURN)))
+
+(def: function-init-method
+ $;Method
+ ($t;method (list $t;int) #;None (list)))
+
+(def: (function-init arity env-size)
+ (-> ls;Arity Nat $;Inst)
+ (if (n.= +1 arity)
+ (|>. ($i;int 0)
+ ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false))
+ (|>. ($i;ILOAD (n.inc env-size))
+ ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false))))
+
+(def: (with-init class env arity)
+ (-> Text (List ls;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)))
+ (L/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))
+ (L/map (function [idx]
+ (let [register (offset-partial idx)]
+ (|>. ($i;ALOAD +0)
+ ($i;ALOAD (n.inc register))
+ ($i;PUTFIELD class (partial idx) $Object)))))
+ $i;fuse)
+ id)]
+ ($d;method #$;Public $;noneM "<init>" (init-method env arity)
+ (|>. ($i;ALOAD +0)
+ (function-init arity env-size)
+ store-capturedI
+ store-partialI
+ $i;RETURN))))
+
+(def: (when test f)
+ (All [a] (-> Bool (-> a a) (-> a a)))
+ (function [value]
+ (if test
+ (f value)
+ value)))
+
+(def: (with-apply class env function-arity @begin bodyI apply-arity)
+ (-> Text (List ls;Variable) ls;Arity $;Label $;Inst ls;Arity
+ $;Def)
+ (let [num-partials (n.dec function-arity)
+ @default ($;new-label [])
+ @labels (L/map $;new-label (list;repeat num-partials []))
+ arity-over-extent (|> (nat-to-int function-arity) (i.- (nat-to-int apply-arity)))
+ casesI (|> (L/append @labels (list @default))
+ (list;zip2 (list;n.range +0 num-partials))
+ (L/map (function [[stage @label]]
+ (let [load-partialsI (if (n.> +0 stage)
+ (|> (list;n.range +0 (n.dec stage))
+ (L/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)))
+ (L/map (|>. captured (load-fieldI class)))
+ $i;fuse)]
+ (|>. ($i;label @label)
+ ($i;NEW class)
+ $i;DUP
+ load-capturedI
+ get-amount-of-partialsI
+ (inc-intI apply-arity)
+ load-partialsI
+ (inputsI +1 apply-arity)
+ (nullsI (|> num-partials (n.- apply-arity) (n.- stage)))
+ ($i;INVOKESPECIAL class "<init>" (init-method env function-arity) false)
+ $i;ARETURN))
+ ))))
+ $i;fuse)]
+ ($d;method #$;Public $;noneM &runtime;apply-method (&runtime;apply-signature apply-arity)
+ (|>. get-amount-of-partialsI
+ ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int)
+ @default @labels)
+ casesI
+ ($i;INVOKESTATIC &runtime;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 (Lux $;Inst))
+ Text (List ls;Variable) ls;Arity ls;Synthesis
+ (Lux [$;Def $;Inst]))
+ (do macro;Monad<Lux>
+ [@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)
+ (L/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 (Lux $;Inst))
+ (List ls;Variable) ls;Arity ls;Synthesis
+ (Lux $;Inst))
+ (do macro;Monad<Lux>
+ [function-class (:: @ map %code (macro;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 &runtime;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 (Lux $;Inst))
+ ls;Synthesis (List ls;Synthesis)
+ (Lux $;Inst))
+ (do macro;Monad<Lux>
+ [functionI (generate functionS)
+ argsI (monad;map @ generate argsS)
+ #let [applyI (|> (segment &runtime;num-apply-variants argsI)
+ (L/map (function [chunkI+]
+ (|>. ($i;CHECKCAST &runtime;function-class)
+ ($i;fuse chunkI+)
+ ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false))))
+ $i;fuse)]]
+ (wrap (|>. functionI
+ applyI))))
diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux
index 4b4b1d38e..149fbf123 100644
--- a/new-luxc/source/luxc/generator/host/jvm.lux
+++ b/new-luxc/source/luxc/generator/host/jvm.lux
@@ -117,10 +117,14 @@
## Configs
(config: Class-Config noneC ++C [finalC])
-(config: Method-Config noneM ++M [staticM finalM synchronizedM])
-(config: Field-Config noneF ++F [staticF finalF transientF volatileF])
+(config: Method-Config noneM ++M [finalM staticM synchronizedM strictM])
+(config: Field-Config noneF ++F [finalF staticF transientF volatileF])
## Labels
(def: #export new-label
(-> Unit Label)
org.objectweb.asm.Label.new)
+
+(def: #export (simple-class name)
+ (-> Text Class)
+ [name (list)])
diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux
index bb1d2cd94..18cd4f945 100644
--- a/new-luxc/source/luxc/generator/host/jvm/def.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/def.lux
@@ -50,6 +50,7 @@
(host;import org.objectweb.asm.ClassWriter
(#static COMPUTE_MAXS int)
+ (#static COMPUTE_FRAMES int)
(new [int])
(visit [int int String String String (Array String)] void)
(visitEnd [] void)
@@ -100,10 +101,10 @@
(def: (method-flags config)
(-> $;Method-Config Int)
($_ i.+
- Opcodes.ACC_STRICT
(if (get@ #$;staticM config) Opcodes.ACC_STATIC 0)
(if (get@ #$;finalM config) Opcodes.ACC_FINAL 0)
- (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0)))
+ (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0)
+ (if (get@ #$;strictM config) Opcodes.ACC_STRICT 0)))
(def: (field-flags config)
(-> $;Field-Config Int)
@@ -145,12 +146,18 @@
(L/map (|>. class-to-type $t;signature))
(text;join-with "")))))
+(def: class-computes
+ Int
+ ($_ i.+
+ ClassWriter.COMPUTE_MAXS
+ ClassWriter.COMPUTE_FRAMES))
+
(do-template [<name> <flag>]
[(def: #export (<name> version visibility config name parameters super interfaces
definitions)
(-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def
host;Byte-Array)
- (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
+ (let [writer (|> (do-to (ClassWriter.new class-computes)
(ClassWriter.visit [(version-flag version)
($_ i.+
Opcodes.ACC_SUPER
@@ -177,7 +184,7 @@
definitions)
(-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def
host;Byte-Array)
- (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
+ (let [writer (|> (do-to (ClassWriter.new class-computes)
(ClassWriter.visit [(version-flag version)
($_ i.+
Opcodes.ACC_SUPER
@@ -277,4 +284,4 @@
singleton
(#;Cons head tail)
- (. head (fuse tail))))
+ (. (fuse tail) head)))
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index 0f947925c..02027294a 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -353,4 +353,4 @@
singleton
(#;Cons head tail)
- (. head (fuse tail))))
+ (. (fuse tail) head)))
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index d04a91141..9f8afdbb2 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -56,7 +56,7 @@
(def: $Object-Array $;Type ($t;array +1 $Object))
(def: $String $;Type ($t;class "java.lang.String" (list)))
(def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list)))
-(def: $Function $;Type ($t;class &runtime;function-name (list)))
+(def: $Function $;Type ($t;class &runtime;function-class (list)))
(def: (install name unnamed)
(-> Text (-> Text Proc)
@@ -135,8 +135,8 @@
(def: (lux//try riskyI)
Unary
(|>. riskyI
- ($i;CHECKCAST &runtime;function-name)
- ($i;INVOKESTATIC &runtime;runtime-name "try" try-method false)))
+ ($i;CHECKCAST &runtime;function-class)
+ ($i;INVOKESTATIC &runtime;runtime-class "try" try-method false)))
## [[Bits]]
(do-template [<name> <op>]
@@ -256,9 +256,9 @@
[nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
[nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
[nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-name "div_nat" nat-method false)]
+ ($i;INVOKESTATIC &runtime;runtime-class "div_nat" nat-method false)]
[nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-name "rem_nat" nat-method false)]
+ ($i;INVOKESTATIC &runtime;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]
@@ -269,9 +269,9 @@
[deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
[deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
[deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-name "mul_deg" deg-method false)]
+ ($i;INVOKESTATIC &runtime;runtime-class "mul_deg" deg-method false)]
[deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-name "div_deg" deg-method false)]
+ ($i;INVOKESTATIC &runtime;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]
@@ -289,10 +289,10 @@
[<eq> 0]
[<lt> -1])]
- [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
+ [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)]
[int//eq int//lt ($i;unwrap #$;Long) $i;LCMP]
[frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG]
- [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
+ [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)]
)
(do-template [<name> <prepare> <transform>]
@@ -310,15 +310,15 @@
[frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)]
[frac//to-deg ($i;unwrap #$;Double)
- (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "frac_to_deg"
+ (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "frac_to_deg"
($t;method (list $t;double) (#;Some $t;long) (list)) false))]
[frac//encode ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)]
[frac//decode ($i;CHECKCAST "java.lang.String")
- ($i;INVOKESTATIC &runtime;runtime-name "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
+ ($i;INVOKESTATIC &runtime;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
[deg//to-frac ($i;unwrap #$;Long)
- (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-name "deg_to_frac"
+ (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-class "deg_to_frac"
($t;method (list $t;long) (#;Some $t;double) (list)) false))]
)
@@ -358,7 +358,7 @@
($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false)
($i;wrap #$;Boolean)]
[text//char ($i;CHECKCAST "java.lang.String") jvm-intI
- ($i;INVOKESTATIC &runtime;runtime-name "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
+ ($i;INVOKESTATIC &runtime;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
lux-intI]
)
@@ -371,7 +371,7 @@
<op>))]
[text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI
- ($i;INVOKESTATIC &runtime;runtime-name "text_clip"
+ ($i;INVOKESTATIC &runtime;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)]
@@ -508,20 +508,20 @@
## [[Processes]]
(def: (process//concurrency-level [])
Nullary
- (|>. ($i;GETSTATIC &runtime;runtime-name "concurrency_level" $t;int)
+ (|>. ($i;GETSTATIC &runtime;runtime-class "concurrency_level" $t;int)
lux-intI))
(def: (process//future procedureI)
Unary
- (|>. procedureI ($i;CHECKCAST &runtime;function-name)
- ($i;INVOKESTATIC &runtime;runtime-name "future"
+ (|>. procedureI ($i;CHECKCAST &runtime;function-class)
+ ($i;INVOKESTATIC &runtime;runtime-class "future"
($t;method (list $Function) (#;Some $Object) (list)) false)))
(def: (process//schedule [millisecondsI procedureI])
Binary
(|>. millisecondsI ($i;unwrap #$;Long)
- procedureI ($i;CHECKCAST &runtime;function-name)
- ($i;INVOKESTATIC &runtime;runtime-name "schedule"
+ procedureI ($i;CHECKCAST &runtime;function-class)
+ ($i;INVOKESTATIC &runtime;runtime-class "schedule"
($t;method (list $t;long $Function) (#;Some $Object) (list)) false)))
## [Bundles]
diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux
new file mode 100644
index 000000000..28c936036
--- /dev/null
+++ b/new-luxc/source/luxc/generator/reference.jvm.lux
@@ -0,0 +1,26 @@
+(;module:
+ lux
+ (lux (control [monad #+ do])
+ (data text/format)
+ [macro "lux/" Monad<Lux>])
+ (luxc (lang ["ls" synthesis])
+ (generator [";G" common]
+ [";G" function]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$i" inst])))))
+
+(def: $Object $;Type ($t;class "java.lang.Object" (list)))
+
+(def: #export (generate-captured variable)
+ (-> ls;Variable (Lux $;Inst))
+ (do macro;Monad<Lux>
+ [function-class commonG;function]
+ (wrap (|>. ($i;ALOAD +0)
+ ($i;GETFIELD function-class
+ (|> variable i.inc (i.* -1) int-to-nat functionG;captured)
+ $Object)))))
+
+(def: #export (generate-variable variable)
+ (-> ls;Variable (Lux $;Inst))
+ (lux/wrap ($i;ALOAD (int-to-nat variable))))
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index 68e18deaa..69f90cea0 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -2,7 +2,8 @@
lux
(lux (control monad)
(data ["R" result]
- text/format)
+ text/format
+ (coll [list "L/" Functor<List>]))
[math]
[macro #+ Monad<Lux> "Lux/" Monad<Lux>]
[host #+ do-to])
@@ -40,8 +41,8 @@
(visitEnd [] void)
(toByteArray [] Byte-Array))
-(def: #export runtime-name Text "LuxRuntime")
-(def: #export function-name Text "LuxFunction")
+(def: #export runtime-class Text "LuxRuntime")
+(def: #export function-class Text "LuxFunction")
(def: #export unit Text "\u0000")
(def: $Object $;Type ($t;class "java.lang.Object" (list)))
@@ -54,7 +55,7 @@
(def: #export $Flag $;Type $Object)
(def: #export $Datum $;Type $Object)
-(def: logI
+(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))]
@@ -67,7 +68,7 @@
(def: variant-makeI
$;Inst
- ($i;INVOKESTATIC runtime-name "variant_make" variant-method false))
+ ($i;INVOKESTATIC runtime-class "variant_make" variant-method false))
(def: #export someI
$;Inst
@@ -102,11 +103,11 @@
(def: nat-methods
$;Def
(let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list))
- less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-name "compare_nat" compare-nat-method false) ($i;IFLT @where)))
+ less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-class "compare_nat" compare-nat-method false) ($i;IFLT @where)))
$BigInteger ($t;class "java.math.BigInteger" (list))
upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list))
div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))
- upcastI ($i;INVOKESTATIC runtime-name "_toUnsignedBigInteger" upcast-method false)
+ upcastI ($i;INVOKESTATIC 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
@@ -279,7 +280,7 @@
(let [subjectI ($i;LLOAD +0)
paramI ($i;LLOAD +2)
equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where)))
- count-leading-zerosI ($i;INVOKESTATIC runtime-name "count_leading_zeros" clz-method false)
+ count-leading-zerosI ($i;INVOKESTATIC 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)
@@ -323,6 +324,12 @@
($i;string "Invalid expression for pattern-matching.")
($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false)
$i;ATHROW))
+ ($d;method #$;Public $;staticM "apply_fail" ($t;method (list) #;None (list))
+ (|>. ($i;NEW "java.lang.IllegalStateException")
+ $i;DUP
+ ($i;string "Error while applying function.")
+ ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false)
+ $i;ATHROW))
($d;method #$;Public $;staticM "pm_push" ($t;method (list $Stack $Object) (#;Some $Stack) (list))
(|>. ($i;int 2)
($i;ANEWARRAY "java.lang.Object")
@@ -439,15 +446,65 @@
$i;ARETURN)))
)))
-(def: #export generate
+(def: generate-runtime
(Lux &common;Bytecode)
(do Monad<Lux>
[_ (wrap [])
- #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list)
+ #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list)
(|>. adt-methods
nat-methods
frac-methods
deg-methods
pm-methods))]
- _ (&common;store-class runtime-name bytecode)]
+ _ (&common;store-class runtime-class bytecode)]
(wrap bytecode)))
+
+(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: generate-function
+ (Lux &common;Bytecode)
+ (do Monad<Lux>
+ [_ (wrap [])
+ #let [applyI (|> (list;n.range +2 num-apply-variants)
+ (L/map (function [arity]
+ ($d;method #$;Public $;noneM apply-method (apply-signature arity)
+ (let [preI (|> (list;n.range +0 (n.dec arity))
+ (L/map $i;ALOAD)
+ $i;fuse)]
+ (|>. preI
+ ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false)
+ ($i;CHECKCAST function-class)
+ ($i;ALOAD arity)
+ ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+ $i;ARETURN)))))
+ (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1))
+ ## ($d;method #$;Public $;noneM apply-method (apply-signature +1)
+ ## (|>. $i;NULL
+ ## $i;ARETURN))
+ )
+ $d;fuse)
+ bytecode ($d;abstract #$;V1.6 #$;Public $;noneC function-class (list) ["java.lang.Object" (list)] (list)
+ (|>. ($d;field #$;Public $;finalF partials-field $t;int)
+ ($d;method #$;Public $;noneM "<init>" ($t;method (list $t;int) #;None (list))
+ (|>. ($i;ALOAD +0)
+ ($i;INVOKESPECIAL "java.lang.Object" "<init>" ($t;method (list) #;None (list)) false)
+ ($i;ALOAD +0)
+ ($i;ILOAD +1)
+ ($i;PUTFIELD function-class partials-field $t;int)
+ $i;RETURN))
+ applyI))]
+ _ (&common;store-class function-class bytecode)]
+ (wrap bytecode)))
+
+(def: #export generate
+ (Lux Unit)
+ (do Monad<Lux>
+ [_ generate-runtime
+ _ generate-function]
+ (wrap [])))
diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux
index 9adff1a55..a89f3083f 100644
--- a/new-luxc/source/luxc/generator/structure.jvm.lux
+++ b/new-luxc/source/luxc/generator/structure.jvm.lux
@@ -51,7 +51,7 @@
(wrap (|>. ($i;int (nat-to-int tag))
(flagI tail?)
memberI
- ($i;INVOKESTATIC ../runtime;runtime-name
+ ($i;INVOKESTATIC ../runtime;runtime-class
"variant_make"
($t;method (list $t;int $Object $Object)
(#;Some ($t;array +1 $Object))
diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux
index e22ab4fd1..75cfbec0c 100644
--- a/new-luxc/source/luxc/host.jvm.lux
+++ b/new-luxc/source/luxc/host.jvm.lux
@@ -78,9 +78,10 @@
#;None
(error! (format "Class not found: " class-name))))))
-(def: #export (init-host _)
- (-> Top &&common;Host)
- (let [store (: &&common;Class-Store
- (A;atom (d;new text;Hash<Text>)))]
- {#&&common;loader (memory-class-loader store)
- #&&common;store store}))
+(def: #export init-host
+ (io;IO &&common;Host)
+ (io;io (let [store (: &&common;Class-Store
+ (A;atom (d;new text;Hash<Text>)))]
+ {#&&common;loader (memory-class-loader store)
+ #&&common;store store
+ #&&common;function-class #;None})))
diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux
index e8f186944..dab2d84e6 100644
--- a/new-luxc/source/luxc/lang/synthesis.lux
+++ b/new-luxc/source/luxc/lang/synthesis.lux
@@ -32,7 +32,7 @@
(#Tuple (List Synthesis))
(#Case Synthesis (Path' Synthesis))
(#Function Arity (List Variable) Synthesis)
- (#Call Synthesis (List Synthesis))
+ (#Call (List Synthesis) Synthesis)
(#Recur (List Synthesis))
(#Procedure Text (List Synthesis))
(#Variable Variable)
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
index 9cfcc020e..7bee8fe58 100644
--- a/new-luxc/source/luxc/synthesizer.lux
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -54,9 +54,9 @@
(#;Local register)
(if (&&function;nested? outer-arity)
(if (n.= +0 register)
- (<| (#ls;Call (#ls;Variable 0))
- (L/map (|>. &&function;to-local #ls;Variable))
- (list;n.range +1 (n.dec outer-arity)))
+ (#ls;Call (|> (list;n.range +1 (n.dec outer-arity))
+ (L/map (|>. &&function;to-local #ls;Variable)))
+ (#ls;Variable 0))
(#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register))))
(#ls;Variable (&&function;to-local register)))
@@ -136,11 +136,11 @@
(#ls;Loop register-offset argsS
(&&loop;adjust _env register-offset _bodyS)))
- (#ls;Call funcS' argsS')
- (#ls;Call funcS' (L/append argsS' argsS))
+ (#ls;Call argsS' funcS')
+ (#ls;Call (L/append argsS' argsS) funcS')
_
- (#ls;Call funcS argsS)))
+ (#ls;Call argsS funcS)))
(#la;Procedure name args)
(#ls;Procedure name (L/map (recur +0 resolver num-locals) args))
diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux
index 06b1d1bb0..9f4d09a49 100644
--- a/new-luxc/source/luxc/synthesizer/loop.lux
+++ b/new-luxc/source/luxc/synthesizer/loop.lux
@@ -32,7 +32,7 @@
(#ls;Function arity environment bodyS)
(list;any? &&function;self? environment)
- (#ls;Call funcS argsS)
+ (#ls;Call argsS funcS)
(or (contains-self-reference? funcS)
(list;any? contains-self-reference? argsS))
@@ -81,11 +81,11 @@
_
pathS))))
- (^multi (#ls;Call (#ls;Variable 0) argsS)
+ (^multi (#ls;Call argsS (#ls;Variable 0))
(n.= arity (list;size argsS)))
(#ls;Recur argsS)
- (#ls;Call (#ls;Variable var) argsS)
+ (#ls;Call argsS (#ls;Variable var))
exprS
(#ls;Let register inputS bodyS)
@@ -136,8 +136,8 @@
(L/map resolve-captured scope)
(recur bodyS))
- (#ls;Call funcS argsS)
- (#ls;Call (recur funcS) (L/map recur argsS))
+ (#ls;Call argsS funcS)
+ (#ls;Call (L/map recur argsS) (recur funcS))
(#ls;Recur argsS)
(#ls;Recur (L/map recur argsS))
diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux
index 161675075..7c1444e01 100644
--- a/new-luxc/test/test/luxc/common.lux
+++ b/new-luxc/test/test/luxc/common.lux
@@ -4,7 +4,8 @@
["r" math/random "r/" Monad<Random>]
(data ["R" result])
[macro]
- (macro [code]))
+ (macro [code])
+ [io])
(luxc ["&" base]
[analyser]
["&;" host]))
@@ -32,4 +33,4 @@
#;expected #;None
#;seed +0
#;scope-type-vars (list)
- #;host (:! Void (&host;init-host []))})
+ #;host (:! Void (io;run &host;init-host))})
diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux
new file mode 100644
index 000000000..76ab600fe
--- /dev/null
+++ b/new-luxc/test/test/luxc/generator/function.lux
@@ -0,0 +1,96 @@
+(;module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data text/format
+ [product]
+ ["R" result]
+ [bool "B/" Eq<Bool>]
+ [text "T/" Eq<Text>]
+ (coll ["a" array]
+ [list "L/" Functor<List>]
+ ["S" set]))
+ ["r" math/random "r/" Monad<Random>]
+ [macro #+ Monad<Lux>]
+ (macro [code])
+ [host]
+ test)
+ (luxc (lang ["ls" synthesis])
+ [analyser]
+ [synthesizer]
+ (generator ["@;" expr]
+ ["@;" 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<Random>
+ [arity arity
+ arg (|> r;nat (:: @ map (n.% arity)))
+ #let [functionS (#ls;Function arity (list) (#ls;Variable (nat-to-int (n.inc arg))))]]
+ (wrap [arity arg functionS])))
+
+(context: "Function."
+ [[arity arg functionS] gen-function
+ cut-off (|> r;nat (:: @ map (n.% arity)))
+ args (r;list arity r;nat)
+ #let [arg-value (assume (list;nth arg args))
+ argsS (L/map (|>. #ls;Nat) args)
+ last-arg (n.dec arity)
+ cut-off (|> cut-off (n.min (n.dec last-arg)))]]
+ ($_ seq
+ (test "Can read arguments."
+ (|> (do Monad<Lux>
+ [runtime-bytecode @runtime;generate]
+ (@eval;eval (@expr;generate (#ls;Call argsS functionS))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success valueG)
+ (n.= arg-value (:! Nat valueG))
+
+ (#R;Error error)
+ false)))
+ (test "Can partially apply functions."
+ (or (n.= +1 arity)
+ (|> (do Monad<Lux>
+ [#let [partial-arity (n.inc cut-off)
+ preS (list;take partial-arity argsS)
+ postS (list;drop partial-arity argsS)]
+ runtime-bytecode @runtime;generate]
+ (@eval;eval (@expr;generate (|> functionS (#ls;Call preS) (#ls;Call postS)))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success valueG)
+ (n.= arg-value (:! Nat valueG))
+
+ (#R;Error error)
+ false))))
+ (test "Can read environment."
+ (or (n.= +1 arity)
+ (|> (do Monad<Lux>
+ [#let [env (|> (list;n.range +0 cut-off)
+ (L/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 (<| (#ls;Function super-arity (list))
+ (#ls;Function sub-arity env)
+ (#ls;Variable arg-var))]
+ runtime-bytecode @runtime;generate]
+ (@eval;eval (@expr;generate (#ls;Call argsS functionS))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success valueG)
+ (n.= arg-value (:! Nat valueG))
+
+ (#R;Error error)
+ false))))
+ ))
diff --git a/new-luxc/test/test/luxc/synthesizer/function.lux b/new-luxc/test/test/luxc/synthesizer/function.lux
index 7257307dc..6791eceb4 100644
--- a/new-luxc/test/test/luxc/synthesizer/function.lux
+++ b/new-luxc/test/test/luxc/synthesizer/function.lux
@@ -142,7 +142,7 @@
($_ seq
(test "Can synthesize function application."
(|> (synthesizer;synthesize (la;apply argsA funcA))
- (case> (#ls;Call funcS argsS)
+ (case> (#ls;Call argsS funcS)
(and (corresponds? funcA funcS)
(list;every? (product;uncurry corresponds?)
(list;zip2 argsA argsS)))
diff --git a/new-luxc/test/test/luxc/synthesizer/loop.lux b/new-luxc/test/test/luxc/synthesizer/loop.lux
index 45b86ede6..849df78d4 100644
--- a/new-luxc/test/test/luxc/synthesizer/loop.lux
+++ b/new-luxc/test/test/luxc/synthesizer/loop.lux
@@ -157,7 +157,7 @@
(and (n.= arity (list;size _inits))
(not (&&loop;contains-self-reference? _body)))
- (#ls;Call (#ls;Function _arity _env _bodyS) argsS)
+ (#ls;Call argsS (#ls;Function _arity _env _bodyS))
(&&loop;contains-self-reference? _bodyS)
_
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index d07822069..30fab3878 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -21,11 +21,10 @@
(generator ["_;G" primitive]
["_;G" structure]
["_;G" case]
+ ["_;G" function]
(procedure ["_;G" common]))
))
- ## (luxc (generator ["_;G" function]))
)
-## [Program]
(program: args
(test;run))