diff options
Diffstat (limited to 'new-luxc/source/luxc/lang')
4 files changed, 101 insertions, 47 deletions
diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux index ea6d371fa..0247b3d7f 100644 --- a/new-luxc/source/luxc/lang/translation/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux @@ -321,28 +321,3 @@ $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/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/loop.jvm.lux new file mode 100644 index 000000000..d9216f1a7 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/loop.jvm.lux @@ -0,0 +1,62 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor<List> Monoid<List>])) + [meta]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + ["ls" synthesis] + (translation [";T" common] + [";T" runtime] + [";T" reference]) + [";L" variable #+ Variable]))) + +(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))))) + +(def: #export (translate-loop translate offset initsS+ bodyS) + (-> (-> ls;Synthesis (Meta $;Inst)) + Nat (List ls;Synthesis) ls;Synthesis + (Meta $;Inst)) + (do meta;Monad<Meta> + [@begin $i;make-label + initsI+ (monad;map @ translate initsS+) + bodyI (hostL;with-anchor [@begin offset] + (translate bodyS)) + #let [initializationI (|> (list;enumerate initsI+) + (list/map (function [[register initI]] + (|>. initI + ($i;ASTORE (|> register n.inc (n.+ offset)))))) + $i;fuse)]] + (wrap (|>. initializationI + ($i;label @begin) + bodyI)))) 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 77ce7f6fa..2cdf65e32 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -1,7 +1,10 @@ (;module: lux - (lux (control [monad #+ do]) - (data [text] + (lux (control [monad #+ do] + ["p" parser] + ["ex" exception #+ exception:]) + (data ["e" error] + [text] text/format (coll [list "list/" Functor<List>] [dict #+ Dict])) @@ -19,7 +22,8 @@ ["ls" synthesis] (translation [";T" runtime] [";T" case] - [";T" function])))) + [";T" function] + [";T" loop])))) (host;import java.lang.Long (#static MIN_VALUE Long) @@ -160,11 +164,29 @@ Unary valueI) +(exception: #export Wrong-Syntax) +(def: #export (wrong-syntax procedure args) + (-> Text (List ls;Synthesis) Text) + (format "Procedure: " procedure "\n" + "Arguments: " (%code (code;tuple args)))) + +(def: lux//loop + (-> Text Proc) + (function [proc-name] + (function [translate inputsS] + (case (s;run inputsS ($_ p;seq s;nat (s;tuple (p;many s;any)) s;any)) + (#e;Success [offset initsS+ bodyS]) + (loopT;translate-loop translate offset initsS+ bodyS) + + (#e;Error error) + (&;throw Wrong-Syntax (wrong-syntax proc-name inputsS))) + ))) + (def: lux//recur (-> Text Proc) (function [proc-name] (function [translate inputsS] - (functionT;translate-recur translate inputsS)))) + (loopT;translate-recur translate inputsS)))) ## [[Bits]] (do-template [<name> <op>] @@ -560,6 +582,7 @@ (install "is" (binary lux//is)) (install "try" (unary lux//try)) (install "if" (trinary lux//if)) + (install "loop" lux//loop) (install "recur" lux//recur) )) diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux index a5e06aac3..e45c0b911 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux @@ -25,12 +25,6 @@ ["ls" synthesis])) ["@" ../common]) -(exception: #export Wrong-Syntax) -(def: (wrong-syntax procedure args) - (-> Text (List ls;Synthesis) Text) - (format "Procedure: " procedure "\n" - "Arguments: " (%code (code;tuple args)))) - (exception: #export Invalid-Syntax-For-JVM-Type) (exception: #export Invalid-Syntax-For-Argument-Generation) @@ -304,7 +298,7 @@ ($i;array arrayJT)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: (array//read proc translate inputs) (-> Text @;Proc) @@ -330,7 +324,7 @@ loadI))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: (array//write proc translate inputs) (-> Text @;Proc) @@ -359,7 +353,7 @@ storeI))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: array-procs @;Bundle @@ -415,7 +409,7 @@ false)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: (object//instance? proc translate inputs) (-> Text @;Proc) @@ -428,7 +422,7 @@ ($i;wrap #$;Boolean)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: object-procs @;Bundle @@ -479,7 +473,7 @@ (wrap ($i;GETSTATIC class field ($t;class unboxed (list)))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: (static//put proc translate inputs) (-> Text @;Proc) @@ -511,7 +505,7 @@ ($i;string hostL;unit))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: (virtual//get proc translate inputs) (-> Text @;Proc) @@ -542,7 +536,7 @@ ($i;GETFIELD class field ($t;class unboxed (list))))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: (virtual//put proc translate inputs) (-> Text @;Proc) @@ -579,7 +573,7 @@ ($i;PUTFIELD class field ($t;class unboxed (list))))))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: base-type (l;Lexer $;Type) @@ -686,7 +680,7 @@ (wrap (prepare-return returnT callI))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (do-template [<name> <invoke> <interface?>] [(def: (<name> proc translate inputs) @@ -707,7 +701,7 @@ (wrap (prepare-return returnT callI))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs))))] + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs))))] [invoke//virtual $i;INVOKEVIRTUAL false] [invoke//special $i;INVOKESPECIAL false] @@ -728,7 +722,7 @@ false)))) _ - (&;throw Wrong-Syntax (wrong-syntax proc inputs)))) + (&;throw @;Wrong-Syntax (@;wrong-syntax proc inputs)))) (def: member-procs @;Bundle |