From 63624fd6b7f9f2563898655472025020483d398f Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Thu, 9 Nov 2017 14:19:54 -0400
Subject: - Fixed the tests. - Fixed a few bugs. - Can now translate recursion.
---
new-luxc/source/luxc/lang/translation/case.jvm.lux | 1 +
.../source/luxc/lang/translation/common.jvm.lux | 8 +-
.../source/luxc/lang/translation/function.jvm.lux | 89 ++++++++++++++--------
.../luxc/lang/translation/procedure/common.jvm.lux | 27 +++++--
.../source/luxc/lang/translation/reference.jvm.lux | 2 +-
5 files changed, 87 insertions(+), 40 deletions(-)
(limited to 'new-luxc/source/luxc/lang/translation')
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
- [@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
- [[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
+ [[@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
+ [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 [ ]
[(def: ( [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)
(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
[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)))))
--
cgit v1.2.3