From b6c3a84b536235a53bdfaf0f96d76413bc222ba7 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 30 Oct 2017 21:49:35 -0400
Subject: - Migrated the format of synthesis nodes from a custom data-type, to
just Code nodes.
---
new-luxc/source/luxc/generator/case.jvm.lux | 162 ++++++++++-----------
new-luxc/source/luxc/generator/expr.jvm.lux | 57 ++++----
.../source/luxc/generator/procedure/common.jvm.lux | 5 +
.../source/luxc/generator/procedure/host.jvm.lux | 33 +++--
4 files changed, 135 insertions(+), 122 deletions(-)
(limited to 'new-luxc/source/luxc/generator')
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux
index f20c83f6e..a619768bb 100644
--- a/new-luxc/source/luxc/generator/case.jvm.lux
+++ b/new-luxc/source/luxc/generator/case.jvm.lux
@@ -1,8 +1,11 @@
(;module:
lux
- (lux (control [monad #+ do])
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data text/format)
[meta "meta/" Monad])
- (luxc [";L" host]
+ (luxc ["_" base]
+ [";L" host]
(lang ["ls" synthesis])
(generator (host ["$" jvm]
(jvm ["$t" type]
@@ -49,50 +52,52 @@
(list))
false)))
-(def: (generate-pattern' generate stack-depth @else @end path)
+(exception: #export Unrecognized-Path)
+
+(def: (generate-path' generate stack-depth @else @end path)
(-> (-> ls;Synthesis (Meta $;Inst))
Nat $;Label $;Label ls;Path (Meta $;Inst))
(case path
- (#ls;ExecP bodyS)
+ (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))])
(do meta;Monad
[bodyI (generate bodyS)]
(wrap (|>. (pop-altI stack-depth)
bodyI
($i;GOTO @end))))
- #ls;UnitP
+ (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))])
(meta/wrap popI)
- (#ls;BindP register)
+ (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))])
(meta/wrap (|>. peekI
($i;ASTORE register)
popI))
- (#ls;BoolP value)
+ [_ (#;Bool value)]
(meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)]
(|>. peekI
($i;unwrap #$;Boolean)
(jumpI @else))))
(^template [ ]
- ( value)
+ [_ ( value)]
(meta/wrap (|>. peekI
($i;unwrap #$;Long)
($i;long (|> value ))
$i;LCMP
($i;IFNE @else))))
- ([#ls;NatP (:! Int)]
- [#ls;IntP (: Int)]
- [#ls;DegP (:! Int)])
+ ([#;Nat (:! Int)]
+ [#;Int (: Int)]
+ [#;Deg (:! Int)])
- (#ls;FracP value)
+ [_ (#;Frac value)]
(meta/wrap (|>. peekI
($i;unwrap #$;Double)
($i;double value)
$i;DCMPL
($i;IFNE @else)))
- (#ls;TextP value)
+ [_ (#;Text value)]
(meta/wrap (|>. peekI
($i;string value)
($i;INVOKEVIRTUAL "java.lang.Object"
@@ -103,95 +108,88 @@
false)
($i;IFEQ @else)))
- (#ls;TupleP idx subP)
- (do meta;Monad
- [subI (generate-pattern' generate stack-depth @else @end subP)
- #let [[idx tail?] (case idx
- (#;Left idx)
- [idx false]
-
- (#;Right idx)
- [idx true])]]
- (wrap (case idx
- +0
- (|>. peekI
- ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
- ($i;int 0)
- $i;AALOAD
- pushI
- subI)
-
- _
- (|>. peekI
- ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
- ($i;int (nat-to-int idx))
- ($i;INVOKESTATIC hostL;runtime-class
- (if tail? "pm_right" "pm_left")
- ($t;method (list ../runtime;$Tuple $t;int)
- (#;Some $Object)
- (list))
- false)
- pushI
- subI))))
-
- (#ls;VariantP idx subP)
- (do meta;Monad
- [subI (generate-pattern' generate stack-depth @else @end subP)
- #let [[idx last?] (case idx
- (#;Left idx)
- [idx false]
-
- (#;Right idx)
- [idx true])
- flagI (if last?
- ($i;string "")
- $i;NULL)]]
- (wrap (<| $i;with-label (function [@success])
- $i;with-label (function [@fail])
+ (^template [ ]
+ (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))])
+ (do meta;Monad
+ [subI (generate-path' generate stack-depth @else @end subP)]
+ (wrap (case idx
+ +0
+ (|>. peekI
+ ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
+ ($i;int 0)
+ $i;AALOAD
+ pushI
+ subI)
+
+ _
(|>. peekI
- ($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
+ ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
($i;int (nat-to-int idx))
- flagI
- ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
- ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
- (#;Some ../runtime;$Datum)
+ ($i;INVOKESTATIC hostL;runtime-class
+
+ ($t;method (list ../runtime;$Tuple $t;int)
+ (#;Some $Object)
(list))
false)
- $i;DUP
- ($i;IFNULL @fail)
- ($i;GOTO @success)
- ($i;label @fail)
- $i;POP
- ($i;GOTO @else)
- ($i;label @success)
pushI
- subI))))
-
- (#ls;SeqP leftP rightP)
+ subI)))))
+ (["lux case tuple left" "pm_left"]
+ ["lux case tuple right" "pm_right"])
+
+ (^template [ ]
+ (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))])
+ (do meta;Monad
+ [subI (generate-path' generate stack-depth @else @end subP)]
+ (wrap (<| $i;with-label (function [@success])
+ $i;with-label (function [@fail])
+ (|>. peekI
+ ($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
+ ($i;int (nat-to-int idx))
+
+ ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
+ ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
+ (#;Some ../runtime;$Datum)
+ (list))
+ false)
+ $i;DUP
+ ($i;IFNULL @fail)
+ ($i;GOTO @success)
+ ($i;label @fail)
+ $i;POP
+ ($i;GOTO @else)
+ ($i;label @success)
+ pushI
+ subI)))))
+ (["lux case variant left" $i;NULL]
+ ["lux case variant right" ($i;string "")])
+
+ (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))])
(do meta;Monad
- [leftI (generate-pattern' generate stack-depth @else @end leftP)
- rightI (generate-pattern' generate stack-depth @else @end rightP)]
+ [leftI (generate-path' generate stack-depth @else @end leftP)
+ rightI (generate-path' generate stack-depth @else @end rightP)]
(wrap (|>. leftI
rightI)))
- (#ls;AltP leftP rightP)
+ (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))])
(do meta;Monad
[@alt-else $i;make-label
- leftI (generate-pattern' generate (n.inc stack-depth) @alt-else @end leftP)
- rightI (generate-pattern' generate stack-depth @else @end rightP)]
+ leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP)
+ rightI (generate-path' generate stack-depth @else @end rightP)]
(wrap (|>. $i;DUP
leftI
($i;label @alt-else)
$i;POP
rightI)))
- ))
-(def: (generate-pattern generate path @end)
+ _
+ (_;throw Unrecognized-Path (%code path))))
+
+(def: (generate-path generate path @end)
(-> (-> ls;Synthesis (Meta $;Inst))
ls;Path $;Label (Meta $;Inst))
(do meta;Monad
[@else $i;make-label
- pathI (generate-pattern' generate +1 @else @end path)]
+ pathI (generate-path' generate +1 @else @end path)]
(wrap (|>. pathI
($i;label @else)
$i;POP
@@ -208,7 +206,7 @@
(do meta;Monad
[@end $i;make-label
valueI (generate valueS)
- pathI (generate-pattern generate path @end)]
+ pathI (generate-path generate path @end)]
(wrap (|>. valueI
$i;NULL
$i;SWAP
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index 685bf2335..b439ff17a 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -1,9 +1,12 @@
(;module:
lux
(lux (control monad
- ["ex" exception #+ exception:])
- (data text/format)
- [meta #+ Monad "Meta/" Monad])
+ ["ex" exception #+ exception:]
+ ["p" parser])
+ (data ["e" error]
+ text/format)
+ [meta]
+ (meta ["s" syntax]))
(luxc ["&" base]
(lang ["ls" synthesis])
["&;" analyser]
@@ -24,48 +27,52 @@
(def: #export (generate synthesis)
(-> ls;Synthesis (Meta $;Inst))
(case synthesis
- #ls;Unit
+ [_ (#;Tuple #;Nil)]
&primitive;generate-unit
+ (^ [_ (#;Tuple (list singleton))])
+ (generate singleton)
+
(^template [ ]
- ( value)
+ [_ ( value)]
( value))
- ([#ls;Bool &primitive;generate-bool]
- [#ls;Nat &primitive;generate-nat]
- [#ls;Int &primitive;generate-int]
- [#ls;Deg &primitive;generate-deg]
- [#ls;Frac &primitive;generate-frac]
- [#ls;Text &primitive;generate-text])
+ ([#;Bool &primitive;generate-bool]
+ [#;Nat &primitive;generate-nat]
+ [#;Int &primitive;generate-int]
+ [#;Deg &primitive;generate-deg]
+ [#;Frac &primitive;generate-frac]
+ [#;Text &primitive;generate-text])
- (#ls;Variant tag tail? member)
- (&structure;generate-variant generate tag tail? member)
+ (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] valueS))])
+ (&structure;generate-variant generate tag last? valueS)
- (#ls;Tuple members)
+ [_ (#;Tuple members)]
(&structure;generate-tuple generate members)
- (#ls;Variable var)
+ (^ [_ (#;Form (list [_ (#;Int var)]))])
(if (functionS;captured? var)
(&reference;generate-captured var)
(&reference;generate-variable var))
- (#ls;Definition definition)
+ [_ (#;Symbol definition)]
(&reference;generate-definition definition)
- (#ls;Let register inputS exprS)
+ (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS exprS))])
(caseG;generate-let generate register inputS exprS)
- (#ls;Case inputS pathPS)
+ (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathPS))])
(caseG;generate-case generate inputS pathPS)
- (#ls;Function arity env body)
- (&function;generate-function generate env arity body)
+ (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity)] [_ (#;Tuple environment)] bodyS))])
+ [(s;run environment (p;some s;int)) (#e;Success environment)])
+ (&function;generate-function generate environment arity bodyS)
- (#ls;Call args function)
- (&function;generate-call generate function args)
+ (^ [_ (#;Form (list& [_ (#;Text "lux call")] functionS argsS))])
+ (&function;generate-call generate functionS argsS)
- (#ls;Procedure name args)
- (&procedure;generate-procedure generate name args)
+ (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))])
+ (&procedure;generate-procedure generate procedure argsS)
_
- (&;throw Unrecognized-Synthesis "")
+ (&;throw Unrecognized-Synthesis (%code synthesis))
))
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index fd76082a6..7ae471c64 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -146,6 +146,10 @@
($i;CHECKCAST hostL;function-class)
($i;INVOKESTATIC hostL;runtime-class "try" try-method false)))
+(def: (lux//noop valueI)
+ Unary
+ valueI)
+
## [[Bits]]
(do-template [ ]
[(def: ( [inputI maskI])
@@ -536,6 +540,7 @@
(def: lux-procs
Bundle
(|> (dict;new text;Hash)
+ (install "lux noop" (unary lux//noop))
(install "lux is" (binary lux//is))
(install "lux try" (unary lux//try))))
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index fc6bdd01b..44da5744d 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -37,6 +37,7 @@
[L2S (|>. $i;L2I $i;I2S)]
[L2B (|>. $i;L2I $i;I2B)]
+ [L2C (|>. $i;L2I $i;I2C)]
)
(do-template [ ]
@@ -68,6 +69,7 @@
[convert//long-to-int #$;Long $i;L2I #$;Int]
[convert//long-to-short #$;Long L2S #$;Short]
[convert//long-to-byte #$;Long L2B #$;Byte]
+ [convert//long-to-char #$;Long L2C #$;Char]
[convert//char-to-byte #$;Char $i;I2B #$;Byte]
[convert//char-to-short #$;Char $i;I2S #$;Short]
[convert//char-to-int #$;Char $i;NOP #$;Int]
@@ -97,6 +99,7 @@
(@;install "long-to-int" (@;unary convert//long-to-int))
(@;install "long-to-short" (@;unary convert//long-to-short))
(@;install "long-to-byte" (@;unary convert//long-to-byte))
+ (@;install "long-to-char" (@;unary convert//long-to-char))
(@;install "char-to-byte" (@;unary convert//char-to-byte))
(@;install "char-to-short" (@;unary convert//char-to-short))
(@;install "char-to-int" (@;unary convert//char-to-int))
@@ -278,7 +281,7 @@
(def: (array//new proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Nat level) (#ls;Text class) lengthS))
+ (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS))
(do meta;Monad
[lengthI (generate lengthS)
#let [arrayJT ($t;array level (case class
@@ -302,7 +305,7 @@
(def: (array//read proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) idxS arrayS))
+ (^ (list [_ (#;Text class)] idxS arrayS))
(do meta;Monad
[arrayI (generate arrayS)
idxI (generate idxS)
@@ -328,7 +331,7 @@
(def: (array//write proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) idxS valueS arrayS))
+ (^ (list [_ (#;Text class)] idxS valueS arrayS))
(do meta;Monad
[arrayI (generate arrayS)
idxI (generate idxS)
@@ -397,7 +400,7 @@
(def: (object//class proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class)))
+ (^ (list [_ (#;Text class)]))
(do meta;Monad
[]
(wrap (|>. ($i;string class)
@@ -413,7 +416,7 @@
(def: (object//instance? proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) objectS))
+ (^ (list [_ (#;Text class)] objectS))
(do meta;Monad
[objectI (generate objectS)]
(wrap (|>. objectI
@@ -450,7 +453,7 @@
(def: (static//get proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed)))
+ (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)]))
(do meta;Monad
[]
(case (dict;get unboxed primitives)
@@ -477,7 +480,7 @@
(def: (static//put proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS))
+ (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS))
(do meta;Monad
[valueI (generate valueS)]
(case (dict;get unboxed primitives)
@@ -509,7 +512,7 @@
(def: (virtual//get proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) objectS))
+ (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS))
(do meta;Monad
[objectI (generate objectS)]
(case (dict;get unboxed primitives)
@@ -540,7 +543,7 @@
(def: (virtual//put proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS objectS))
+ (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS))
(do meta;Monad
[valueI (generate valueS)
objectI (generate objectS)]
@@ -632,7 +635,7 @@
#;Nil
(meta/wrap #;Nil)
- (^ (list& [(#ls;Tuple (list (#ls;Text argD) argS))] tail))
+ (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail))
(do meta;Monad
[argT (generate-type argD)
argI (:: @ map (prepare-input argT) (generate argS))
@@ -669,8 +672,8 @@
(def: (invoke//static proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list& (#ls;Text class) (#ls;Text method)
- (#ls;Text unboxed) argsS))
+ (^ (list& [_ (#;Text class)] [_ (#;Text method)]
+ [_ (#;Text unboxed)] argsS))
(do meta;Monad
[argsTI (generate-args generate argsS)
returnT (method-return-type unboxed)
@@ -687,8 +690,8 @@
[(def: ( proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list& (#ls;Text class) (#ls;Text method)
- (#ls;Text unboxed) objectS argsS))
+ (^ (list& [_ (#;Text class)] [_ (#;Text method)]
+ [_ (#;Text unboxed)] objectS argsS))
(do meta;Monad
[objectI (generate objectS)
argsTI (generate-args generate argsS)
@@ -712,7 +715,7 @@
(def: (invoke//constructor proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list& (#ls;Text class) argsS))
+ (^ (list& [_ (#;Text class)] argsS))
(do meta;Monad
[argsTI (generate-args generate argsS)]
(wrap (|>. ($i;NEW class)
--
cgit v1.2.3