diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation')
5 files changed, 87 insertions, 40 deletions
diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux index 3e05ba334..7821db70d 100644 --- a/new-luxc/source/luxc/lang/translation/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux @@ -204,6 +204,7 @@ (<| $i;with-label (function [@else]) $i;with-label (function [@end]) (|>. testI + ($i;unwrap #$;Boolean) ($i;IFEQ @else) thenI ($i;GOTO @end) diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux index f9825614a..baafc233a 100644 --- a/new-luxc/source/luxc/lang/translation/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux @@ -9,7 +9,8 @@ (coll [dict #+ Dict])) [host] (world [blob #+ Blob])) - (luxc (host ["$" jvm] + (luxc (lang [";L" variable #+ Register]) + (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])))) @@ -17,6 +18,8 @@ (host;import org.objectweb.asm.Opcodes (#static V1_6 int)) +(host;import org.objectweb.asm.Label) + (host;import java.lang.Object) (host;import (java.lang.Class a)) @@ -34,7 +37,8 @@ {#loader ClassLoader #store Class-Store #artifacts Artifacts - #context [Text Nat]}) + #context [Text Nat] + #anchor (Maybe [Label Register])}) (exception: Unknown-Class) (exception: Class-Already-Stored) diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux index eceaecd9d..bbf295d18 100644 --- a/new-luxc/source/luxc/lang/translation/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux @@ -267,42 +267,42 @@ $i;ARETURN )))) -(def: #export (with-function class env arity bodyI) - (-> Text (List Variable) ls;Arity $;Inst - (Meta [$;Def $;Inst])) - (do meta;Monad<Meta> - [@begin $i;make-label - #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 (translate-function translate env arity body) +(def: #export (with-function @begin class env arity bodyI) + (-> $;Label Text (List Variable) ls;Arity $;Inst + [$;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) + (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)] + [functionD instanceI])) + +(def: #export (translate-function translate env arity bodyS) (-> (-> ls;Synthesis (Meta $;Inst)) (List Variable) ls;Arity ls;Synthesis (Meta $;Inst)) (do meta;Monad<Meta> - [[context bodyI] (hostL;with-sub-context - (translate body)) - #let [function-class (&;normalize-name context)] - [functionD instanceI] (with-function function-class env arity bodyI) + [@begin $i;make-label + [function-class bodyI] (hostL;with-sub-context + (hostL;with-anchor [@begin +1] + (translate bodyS))) + #let [[functionD instanceI] (with-function @begin function-class env arity bodyI)] _ (commonT;store-class function-class ($d;class #$;V1.6 #$;Public $;finalC function-class (list) @@ -332,3 +332,28 @@ $i;fuse)]] (wrap (|>. functionI applyI)))) + +(def: #export (translate-recur translate argsS) + (-> (-> ls;Synthesis (Meta $;Inst)) + (List ls;Synthesis) + (Meta $;Inst)) + (do meta;Monad<Meta> + [[@begin offset] hostL;anchor + argsI (monad;map @ (function [[register argS]] + (let [register' (n.+ offset register)] + (: (Meta $;Inst) + (case argS + (^multi (^code ((~ [_ (#;Int var)]))) + (i.= (variableL;local register') + var)) + (wrap id) + + _ + (do @ + [argI (translate argS)] + (wrap (|>. argI + ($i;ASTORE register')))))))) + (list;zip2 (list;n.range +0 (n.dec (list;size argsS))) + argsS))] + (wrap (|>. ($i;fuse argsI) + ($i;GOTO @begin))))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux index 7c049a99f..77ce7f6fa 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -18,7 +18,8 @@ (lang ["la" analysis] ["ls" synthesis] (translation [";T" runtime] - [";T" case])))) + [";T" case] + [";T" function])))) (host;import java.lang.Long (#static MIN_VALUE Long) @@ -32,11 +33,11 @@ (#static NEGATIVE_INFINITY Double)) ## [Types] -(type: #export Generator +(type: #export Translator (-> ls;Synthesis (Meta $;Inst))) (type: #export Proc - (-> Generator (List ls;Synthesis) (Meta $;Inst))) + (-> Translator (List ls;Synthesis) (Meta $;Inst))) (type: #export Bundle (Dict Text Proc)) @@ -48,6 +49,7 @@ (type: #export Unary (-> (Vector +1 $;Inst) $;Inst)) (type: #export Binary (-> (Vector +2 $;Inst) $;Inst)) (type: #export Trinary (-> (Vector +3 $;Inst) $;Inst)) +(type: #export Variadic (-> (List $;Inst) $;Inst)) ## [Utils] (def: $Object $;Type ($t;class "java.lang.Object" (list))) @@ -100,6 +102,14 @@ (arity: binary +2) (arity: trinary +3) +(def: #export (variadic proc) + (-> Variadic (-> Text Proc)) + (function [proc-name] + (function [translate inputsS] + (do meta;Monad<Meta> + [inputsI (monad;map @ translate inputsS)] + (wrap (proc inputsI)))))) + ## [Instructions] (def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long))) (def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I)) @@ -150,6 +160,12 @@ Unary valueI) +(def: lux//recur + (-> Text Proc) + (function [proc-name] + (function [translate inputsS] + (functionT;translate-recur translate inputsS)))) + ## [[Bits]] (do-template [<name> <op>] [(def: (<name> [inputI maskI]) @@ -363,7 +379,7 @@ [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") + [text//concat ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false) id] [text//contains? ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") @@ -544,6 +560,7 @@ (install "is" (binary lux//is)) (install "try" (unary lux//try)) (install "if" (trinary lux//if)) + (install "recur" lux//recur) )) (def: bit-procs @@ -630,7 +647,7 @@ (|> (dict;new text;Hash<Text>) (install "text =" (binary text//eq)) (install "text <" (binary text//lt)) - (install "text append" (binary text//append)) + (install "text concat" (binary text//concat)) (install "text index" (trinary text//index)) (install "text size" (unary text//size)) (install "text hash" (unary text//hash)) diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux index c9243cae3..3e835f8e1 100644 --- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux @@ -19,7 +19,7 @@ (do meta;Monad<Meta> [function-class hostL;context] (wrap (|>. ($i;ALOAD +0) - ($i;GETFIELD (&;normalize-name function-class) + ($i;GETFIELD function-class (|> variable i.inc (i.* -1) int-to-nat functionT;captured) commonT;$Object))))) |