aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation/function.jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/function.jvm.lux')
-rw-r--r--new-luxc/source/luxc/lang/translation/function.jvm.lux376
1 files changed, 188 insertions, 188 deletions
diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux
index ab3382952..3070800fe 100644
--- a/new-luxc/source/luxc/lang/translation/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux
@@ -1,4 +1,4 @@
-(;module:
+(.module:
lux
(lux (control [monad #+ do])
(data [text]
@@ -6,320 +6,320 @@
(coll [list "list/" Functor<List> Monoid<List>]))
[macro])
(luxc ["&" lang]
- (lang [";L" host]
+ (lang [".L" host]
(host ["$" jvm]
(jvm ["$t" type]
["$d" def]
["$i" inst]))
["la" analysis]
["ls" synthesis]
- (translation [";T" common]
- [";T" runtime]
- [";T" reference])
- [";L" variable #+ Variable])))
+ (translation [".T" common]
+ [".T" runtime]
+ [".T" reference])
+ [".L" variable #+ Variable])))
(def: arity-field Text "arity")
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
+(def: $Object $.Type ($t.class "java.lang.Object" (list)))
(def: (poly-arg? arity)
- (-> ls;Arity Bool)
- (n.> +1 arity))
+ (-> ls.Arity Bool)
+ (n/> +1 arity))
(def: (reset-method class)
- (-> Text $;Method)
- ($t;method (list) (#;Some ($t;class class (list))) (list)))
+ (-> Text $.Method)
+ ($t.method (list) (#.Some ($t.class class (list))) (list)))
(def: (captured-args env)
- (-> (List Variable) (List $;Type))
- (list;repeat (list;size env) $Object))
+ (-> (List Variable) (List $.Type))
+ (list.repeat (list.size env) $Object))
(def: (init-method env arity)
- (-> (List Variable) ls;Arity $;Method)
+ (-> (List Variable) ls.Arity $.Method)
(if (poly-arg? arity)
- ($t;method (list;concat (list (captured-args env)
- (list $t;int)
- (list;repeat (n.dec arity) $Object)))
- #;None
+ ($t.method (list.concat (list (captured-args env)
+ (list $t.int)
+ (list.repeat (n/dec arity) $Object)))
+ #.None
(list))
- ($t;method (captured-args env) #;None (list))))
+ ($t.method (captured-args env) #.None (list))))
(def: (implementation-method arity)
- ($t;method (list;repeat arity $Object) (#;Some $Object) (list)))
+ ($t.method (list.repeat arity $Object) (#.Some $Object) (list)))
(def: get-amount-of-partialsI
- $;Inst
- (|>. ($i;ALOAD +0)
- ($i;GETFIELD hostL;function-class runtimeT;partials-field $t;int)))
+ $.Inst
+ (|>> ($i.ALOAD +0)
+ ($i.GETFIELD hostL.function-class runtimeT.partials-field $t.int)))
(def: (load-fieldI class field)
- (-> Text Text $;Inst)
- (|>. ($i;ALOAD +0)
- ($i;GETFIELD class field $Object)))
+ (-> Text Text $.Inst)
+ (|>> ($i.ALOAD +0)
+ ($i.GETFIELD class field $Object)))
(def: (inputsI start amount)
- (-> $;Register Nat $;Inst)
- (|> (list;n.range start (n.+ start (n.dec amount)))
- (list/map $i;ALOAD)
- $i;fuse))
+ (-> $.Register Nat $.Inst)
+ (|> (list.n/range start (n/+ start (n/dec amount)))
+ (list/map $i.ALOAD)
+ $i.fuse))
(def: (applysI start amount)
- (-> $;Register Nat $;Inst)
- (let [max-args (n.min amount runtimeT;num-apply-variants)
- later-applysI (if (n.> runtimeT;num-apply-variants amount)
- (applysI (n.+ runtimeT;num-apply-variants start) (n.- runtimeT;num-apply-variants amount))
+ (-> $.Register Nat $.Inst)
+ (let [max-args (n/min amount runtimeT.num-apply-variants)
+ later-applysI (if (n/> runtimeT.num-apply-variants amount)
+ (applysI (n/+ runtimeT.num-apply-variants start) (n/- runtimeT.num-apply-variants amount))
id)]
- (|>. ($i;CHECKCAST hostL;function-class)
+ (|>> ($i.CHECKCAST hostL.function-class)
(inputsI start max-args)
- ($i;INVOKEVIRTUAL hostL;function-class runtimeT;apply-method (runtimeT;apply-signature max-args) false)
+ ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature max-args) false)
later-applysI)))
(def: (inc-intI by)
- (-> Nat $;Inst)
- (|>. ($i;int (nat-to-int by))
- $i;IADD))
+ (-> Nat $.Inst)
+ (|>> ($i.int (nat-to-int by))
+ $i.IADD))
(def: (nullsI amount)
- (-> Nat $;Inst)
- (|> $i;NULL
- (list;repeat amount)
- $i;fuse))
+ (-> Nat $.Inst)
+ (|> $i.NULL
+ (list.repeat amount)
+ $i.fuse))
(def: (with-captured env)
- (-> (List Variable) $;Def)
- (|> (list;enumerate env)
+ (-> (List Variable) $.Def)
+ (|> (list.enumerate env)
(list/map (function [[env-idx env-source]]
- ($d;field #$;Private $;finalF (referenceT;captured env-idx) $Object)))
- $d;fuse))
+ ($d.field #$.Private $.finalF (referenceT.captured env-idx) $Object)))
+ $d.fuse))
(def: (with-partial arity)
- (-> ls;Arity $;Def)
+ (-> ls.Arity $.Def)
(if (poly-arg? arity)
- (|> (list;n.range +0 (n.- +2 arity))
+ (|> (list.n/range +0 (n/- +2 arity))
(list/map (function [idx]
- ($d;field #$;Private $;finalF (referenceT;partial idx) $Object)))
- $d;fuse)
+ ($d.field #$.Private $.finalF (referenceT.partial idx) $Object)))
+ $d.fuse)
id))
(def: (instance class arity env)
- (-> Text ls;Arity (List Variable) (Meta $;Inst))
- (do macro;Monad<Meta>
- [captureI+ (monad;map @ referenceT;translate-variable env)
+ (-> Text ls.Arity (List Variable) (Meta $.Inst))
+ (do macro.Monad<Meta>
+ [captureI+ (monad.map @ referenceT.translate-variable env)
#let [argsI (if (poly-arg? arity)
- (|> (nullsI (n.dec arity))
- (list ($i;int 0))
- $i;fuse)
+ (|> (nullsI (n/dec arity))
+ (list ($i.int 0))
+ $i.fuse)
id)]]
- (wrap (|>. ($i;NEW class)
- $i;DUP
- ($i;fuse captureI+)
+ (wrap (|>> ($i.NEW class)
+ $i.DUP
+ ($i.fuse captureI+)
argsI
- ($i;INVOKESPECIAL class "<init>" (init-method env arity) false)))))
+ ($i.INVOKESPECIAL class "<init>" (init-method env arity) false)))))
(def: (with-reset class arity env)
- (-> Text ls;Arity (List Variable) $;Def)
- ($d;method #$;Public $;noneM "reset" (reset-method class)
+ (-> Text ls.Arity (List Variable) $.Def)
+ ($d.method #$.Public $.noneM "reset" (reset-method class)
(if (poly-arg? arity)
- (let [env-size (list;size env)
+ (let [env-size (list.size env)
captureI (|> (case env-size
+0 (list)
- _ (list;n.range +0 (n.dec env-size)))
+ _ (list.n/range +0 (n/dec env-size)))
(list/map (function [source]
- (|>. ($i;ALOAD +0)
- ($i;GETFIELD class (referenceT;captured source) $Object))))
- $i;fuse)
- argsI (|> (nullsI (n.dec arity))
- (list ($i;int 0))
- $i;fuse)]
- (|>. ($i;NEW class)
- $i;DUP
+ (|>> ($i.ALOAD +0)
+ ($i.GETFIELD class (referenceT.captured source) $Object))))
+ $i.fuse)
+ argsI (|> (nullsI (n/dec arity))
+ (list ($i.int 0))
+ $i.fuse)]
+ (|>> ($i.NEW class)
+ $i.DUP
captureI
argsI
- ($i;INVOKESPECIAL class "<init>" (init-method env arity) false)
- $i;ARETURN))
- (|>. ($i;ALOAD +0)
- $i;ARETURN))))
+ ($i.INVOKESPECIAL class "<init>" (init-method env arity) false)
+ $i.ARETURN))
+ (|>> ($i.ALOAD +0)
+ $i.ARETURN))))
(def: (with-implementation arity @begin bodyI)
- (-> Nat $;Label $;Inst $;Def)
- ($d;method #$;Public $;strictM "impl" (implementation-method arity)
- (|>. ($i;label @begin)
+ (-> Nat $.Label $.Inst $.Def)
+ ($d.method #$.Public $.strictM "impl" (implementation-method arity)
+ (|>> ($i.label @begin)
bodyI
- $i;ARETURN)))
+ $i.ARETURN)))
(def: function-init-method
- $;Method
- ($t;method (list $t;int) #;None (list)))
+ $.Method
+ ($t.method (list $t.int) #.None (list)))
(def: (function-init arity env-size)
- (-> ls;Arity Nat $;Inst)
- (if (n.= +1 arity)
- (|>. ($i;int 0)
- ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false))
- (|>. ($i;ILOAD (n.inc env-size))
- ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false))))
+ (-> ls.Arity Nat $.Inst)
+ (if (n/= +1 arity)
+ (|>> ($i.int 0)
+ ($i.INVOKESPECIAL hostL.function-class "<init>" function-init-method false))
+ (|>> ($i.ILOAD (n/inc env-size))
+ ($i.INVOKESPECIAL hostL.function-class "<init>" function-init-method false))))
(def: (with-init class env arity)
- (-> Text (List Variable) ls;Arity $;Def)
- (let [env-size (list;size env)
+ (-> Text (List Variable) ls.Arity $.Def)
+ (let [env-size (list.size env)
offset-partial (: (-> Nat Nat)
- (|>. n.inc (n.+ env-size)))
+ (|>> n/inc (n/+ env-size)))
store-capturedI (|> (case env-size
+0 (list)
- _ (list;n.range +0 (n.dec env-size)))
+ _ (list.n/range +0 (n/dec env-size)))
(list/map (function [register]
- (|>. ($i;ALOAD +0)
- ($i;ALOAD (n.inc register))
- ($i;PUTFIELD class (referenceT;captured register) $Object))))
- $i;fuse)
+ (|>> ($i.ALOAD +0)
+ ($i.ALOAD (n/inc register))
+ ($i.PUTFIELD class (referenceT.captured register) $Object))))
+ $i.fuse)
store-partialI (if (poly-arg? arity)
- (|> (list;n.range +0 (n.- +2 arity))
+ (|> (list.n/range +0 (n/- +2 arity))
(list/map (function [idx]
(let [register (offset-partial idx)]
- (|>. ($i;ALOAD +0)
- ($i;ALOAD (n.inc register))
- ($i;PUTFIELD class (referenceT;partial idx) $Object)))))
- $i;fuse)
+ (|>> ($i.ALOAD +0)
+ ($i.ALOAD (n/inc register))
+ ($i.PUTFIELD class (referenceT.partial idx) $Object)))))
+ $i.fuse)
id)]
- ($d;method #$;Public $;noneM "<init>" (init-method env arity)
- (|>. ($i;ALOAD +0)
+ ($d.method #$.Public $.noneM "<init>" (init-method env arity)
+ (|>> ($i.ALOAD +0)
(function-init arity env-size)
store-capturedI
store-partialI
- $i;RETURN))))
+ $i.RETURN))))
(def: (with-apply class env function-arity @begin bodyI apply-arity)
- (-> Text (List Variable) ls;Arity $;Label $;Inst ls;Arity
- $;Def)
- (let [num-partials (n.dec function-arity)
- @default ($;new-label [])
- @labels (list/map $;new-label (list;repeat num-partials []))
- arity-over-extent (|> (nat-to-int function-arity) (i.- (nat-to-int apply-arity)))
+ (-> Text (List Variable) ls.Arity $.Label $.Inst ls.Arity
+ $.Def)
+ (let [num-partials (n/dec function-arity)
+ @default ($.new-label [])
+ @labels (list/map $.new-label (list.repeat num-partials []))
+ arity-over-extent (|> (nat-to-int function-arity) (i/- (nat-to-int apply-arity)))
casesI (|> (list/compose @labels (list @default))
- (list;zip2 (list;n.range +0 num-partials))
+ (list.zip2 (list.n/range +0 num-partials))
(list/map (function [[stage @label]]
- (let [load-partialsI (if (n.> +0 stage)
- (|> (list;n.range +0 (n.dec stage))
- (list/map (|>. referenceT;partial (load-fieldI class)))
- $i;fuse)
+ (let [load-partialsI (if (n/> +0 stage)
+ (|> (list.n/range +0 (n/dec stage))
+ (list/map (|>> referenceT.partial (load-fieldI class)))
+ $i.fuse)
id)]
- (cond (i.= arity-over-extent (nat-to-int stage))
- (|>. ($i;label @label)
- ($i;ALOAD +0)
- (when (n.> +0 stage)
- ($i;INVOKEVIRTUAL class "reset" (reset-method class) false))
+ (cond (i/= arity-over-extent (nat-to-int stage))
+ (|>> ($i.label @label)
+ ($i.ALOAD +0)
+ (when (n/> +0 stage)
+ ($i.INVOKEVIRTUAL class "reset" (reset-method class) false))
load-partialsI
(inputsI +1 apply-arity)
- ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
- $i;ARETURN)
+ ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
+ $i.ARETURN)
- (i.> arity-over-extent (nat-to-int stage))
- (let [args-to-completion (|> function-arity (n.- stage))
- args-left (|> apply-arity (n.- args-to-completion))]
- (|>. ($i;label @label)
- ($i;ALOAD +0)
- ($i;INVOKEVIRTUAL class "reset" (reset-method class) false)
+ (i/> arity-over-extent (nat-to-int stage))
+ (let [args-to-completion (|> function-arity (n/- stage))
+ args-left (|> apply-arity (n/- args-to-completion))]
+ (|>> ($i.label @label)
+ ($i.ALOAD +0)
+ ($i.INVOKEVIRTUAL class "reset" (reset-method class) false)
load-partialsI
(inputsI +1 args-to-completion)
- ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
- (applysI (n.inc args-to-completion) args-left)
- $i;ARETURN))
+ ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
+ (applysI (n/inc args-to-completion) args-left)
+ $i.ARETURN))
- ## (i.< arity-over-extent (nat-to-int stage))
- (let [env-size (list;size env)
+ ## (i/< arity-over-extent (nat-to-int stage))
+ (let [env-size (list.size env)
load-capturedI (|> (case env-size
+0 (list)
- _ (list;n.range +0 (n.dec env-size)))
- (list/map (|>. referenceT;captured (load-fieldI class)))
- $i;fuse)]
- (|>. ($i;label @label)
- ($i;NEW class)
- $i;DUP
+ _ (list.n/range +0 (n/dec env-size)))
+ (list/map (|>> referenceT.captured (load-fieldI class)))
+ $i.fuse)]
+ (|>> ($i.label @label)
+ ($i.NEW class)
+ $i.DUP
load-capturedI
get-amount-of-partialsI
(inc-intI apply-arity)
load-partialsI
(inputsI +1 apply-arity)
- (nullsI (|> num-partials (n.- apply-arity) (n.- stage)))
- ($i;INVOKESPECIAL class "<init>" (init-method env function-arity) false)
- $i;ARETURN))
+ (nullsI (|> num-partials (n/- apply-arity) (n/- stage)))
+ ($i.INVOKESPECIAL class "<init>" (init-method env function-arity) false)
+ $i.ARETURN))
))))
- $i;fuse)]
- ($d;method #$;Public $;noneM runtimeT;apply-method (runtimeT;apply-signature apply-arity)
- (|>. get-amount-of-partialsI
- ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int)
+ $i.fuse)]
+ ($d.method #$.Public $.noneM runtimeT.apply-method (runtimeT.apply-signature apply-arity)
+ (|>> get-amount-of-partialsI
+ ($i.TABLESWITCH 0 (|> num-partials n/dec nat-to-int)
@default @labels)
casesI
- ($i;INVOKESTATIC hostL;runtime-class "apply_fail" ($t;method (list) #;None (list)) false)
- $i;NULL
- $i;ARETURN
+ ($i.INVOKESTATIC hostL.runtime-class "apply_fail" ($t.method (list) #.None (list)) false)
+ $i.NULL
+ $i.ARETURN
))))
(def: #export (with-function @begin class env arity bodyI)
- (-> $;Label Text (List Variable) ls;Arity $;Inst
- (Meta [$;Def $;Inst]))
- (let [env-size (list;size env)
- applyD (: $;Def
+ (-> $.Label Text (List Variable) ls.Arity $.Inst
+ (Meta [$.Def $.Inst]))
+ (let [env-size (list.size env)
+ applyD (: $.Def
(if (poly-arg? arity)
- (|> (n.min arity runtimeT;num-apply-variants)
- (list;n.range +1)
+ (|> (n/min arity runtimeT.num-apply-variants)
+ (list.n/range +1)
(list/map (with-apply class env arity @begin bodyI))
(list& (with-implementation arity @begin bodyI))
- $d;fuse)
- ($d;method #$;Public $;strictM runtimeT;apply-method (runtimeT;apply-signature +1)
- (|>. ($i;label @begin)
+ $d.fuse)
+ ($d.method #$.Public $.strictM runtimeT.apply-method (runtimeT.apply-signature +1)
+ (|>> ($i.label @begin)
bodyI
- $i;ARETURN))))
- functionD (: $;Def
- (|>. ($d;int-field #$;Public ($_ $;++F $;staticF $;finalF) arity-field (nat-to-int arity))
+ $i.ARETURN))))
+ functionD (: $.Def
+ (|>> ($d.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (nat-to-int arity))
(with-captured env)
(with-partial arity)
(with-init class env arity)
(with-reset class arity env)
applyD
))]
- (do macro;Monad<Meta>
+ (do macro.Monad<Meta>
[instanceI (instance class arity env)]
(wrap [functionD instanceI]))))
(def: #export (translate-function translate env arity bodyS)
- (-> (-> ls;Synthesis (Meta $;Inst))
- (List Variable) ls;Arity ls;Synthesis
- (Meta $;Inst))
- (do macro;Monad<Meta>
- [@begin $i;make-label
- [function-class bodyI] (hostL;with-sub-context
- (hostL;with-anchor [@begin +1]
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ (List Variable) ls.Arity ls.Synthesis
+ (Meta $.Inst))
+ (do macro.Monad<Meta>
+ [@begin $i.make-label
+ [function-class bodyI] (hostL.with-sub-context
+ (hostL.with-anchor [@begin +1]
(translate bodyS)))
- this-module macro;current-module-name
- #let [function-class (format (text;replace-all "/" "." this-module) "." function-class)]
+ this-module macro.current-module-name
+ #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)]
[functionD instanceI] (with-function @begin function-class env arity bodyI)
- _ (commonT;store-class function-class
- ($d;class #$;V1.6 #$;Public $;finalC
+ _ (commonT.store-class function-class
+ ($d.class #$.V1_6 #$.Public $.finalC
function-class (list)
- ($;simple-class hostL;function-class) (list)
+ ($.simple-class hostL.function-class) (list)
functionD))]
(wrap instanceI)))
(def: (segment size elems)
(All [a] (-> Nat (List a) (List (List a))))
- (let [[pre post] (list;split size elems)]
- (if (list;empty? post)
+ (let [[pre post] (list.split size elems)]
+ (if (list.empty? post)
(list pre)
(list& pre (segment size post)))))
(def: #export (translate-call translate functionS argsS)
- (-> (-> ls;Synthesis (Meta $;Inst))
- ls;Synthesis (List ls;Synthesis)
- (Meta $;Inst))
- (do macro;Monad<Meta>
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ ls.Synthesis (List ls.Synthesis)
+ (Meta $.Inst))
+ (do macro.Monad<Meta>
[functionI (translate functionS)
- argsI (monad;map @ translate argsS)
- #let [applyI (|> (segment runtimeT;num-apply-variants argsI)
+ argsI (monad.map @ translate argsS)
+ #let [applyI (|> (segment runtimeT.num-apply-variants argsI)
(list/map (function [chunkI+]
- (|>. ($i;CHECKCAST hostL;function-class)
- ($i;fuse chunkI+)
- ($i;INVOKEVIRTUAL hostL;function-class runtimeT;apply-method (runtimeT;apply-signature (list;size chunkI+)) false))))
- $i;fuse)]]
- (wrap (|>. functionI
+ (|>> ($i.CHECKCAST hostL.function-class)
+ ($i.fuse chunkI+)
+ ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature (list.size chunkI+)) false))))
+ $i.fuse)]]
+ (wrap (|>> functionI
applyI))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 04:30:19 +0000