From 72603f38074a67f9ab1e53df1b5fb5da3836162d Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 14 Nov 2017 02:00:14 -0400
Subject: - Implemented loop translation.
---
.../source/luxc/lang/translation/function.jvm.lux | 25 ---------
new-luxc/source/luxc/lang/translation/loop.jvm.lux | 62 ++++++++++++++++++++++
.../luxc/lang/translation/procedure/common.jvm.lux | 31 +++++++++--
.../luxc/lang/translation/procedure/host.jvm.lux | 30 +++++------
4 files changed, 101 insertions(+), 47 deletions(-)
create mode 100644 new-luxc/source/luxc/lang/translation/loop.jvm.lux
(limited to 'new-luxc')
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
- [[@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 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]
+ [";T" reference])
+ [";L" variable #+ Variable])))
+
+(def: #export (translate-recur translate argsS)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ (List ls;Synthesis)
+ (Meta $;Inst))
+ (do meta;Monad
+ [[@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
+ [@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]
[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 [ ]
@@ -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 [ ]
[(def: ( 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
--
cgit v1.2.3