aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/translation.lux92
-rw-r--r--new-luxc/source/luxc/lang/translation/imports.jvm.lux1
-rw-r--r--new-luxc/source/luxc/lang/translation/loop.jvm.lux58
-rw-r--r--new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux127
-rw-r--r--new-luxc/source/luxc/lang/translation/runtime.jvm.lux4
5 files changed, 158 insertions, 124 deletions
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index 33f74795a..fbecf2da5 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -7,10 +7,10 @@
(data ["e" error]
[text "text/" Hash<Text>]
text/format
- (coll [list]
+ (coll [list "list/" Functor<List>]
[dict]))
[macro]
- (lang [syntax]
+ (lang [syntax #+ Aliases]
(type ["tc" check]))
[host]
[io #+ IO Process io]
@@ -52,9 +52,12 @@
(wrap [annsI (:! Code annsV)])))
(def: (switch-compiler new-compiler)
- (-> Compiler (Meta Unit))
+ (-> Compiler (Meta Aliases))
(function [old-compiler]
- (#e;Success [new-compiler []])))
+ ((do macro;Monad<Meta>
+ [this macro;current-module]
+ (wrap (|> this (get@ #;module-aliases) (dict;from-list text;Hash<Text>) (: Aliases))))
+ new-compiler)))
(def: (ensure-valid-alias def-name annotations value)
(-> Text Code Code (Meta Unit))
@@ -66,8 +69,8 @@
_
(&;throw Invalid-Alias def-name)))
-(def: (translate translate-module code)
- (-> (-> Text Compiler (Process Compiler)) Code (Meta Unit))
+(def: (translate translate-module aliases code)
+ (-> (-> Text Compiler (Process Compiler)) Aliases Code (Meta Aliases))
(case code
(^code ((~ [_ (#;Symbol macro-name)]) (~@ args)))
(do macro;Monad<Meta>
@@ -76,15 +79,26 @@
(case ?macro
(#;Some macro)
(do @
- [expansion (function [compiler]
- (case (macroL;expand macro args compiler)
- (#e;Success [compiler' output])
- (#e;Success [compiler' output])
+ [expansion (: (Meta (List Code))
+ (function [compiler]
+ (case (macroL;expand macro args compiler)
+ (#e;Error error)
+ ((&;throw Macro-Expansion-Failed error) compiler)
- (#e;Error error)
- ((&;throw Macro-Expansion-Failed error) compiler)))
- _ (monad;map @ (translate translate-module) expansion)]
- (wrap []))
+ output
+ output)))
+ expansion-aliases (monad;map @ (translate translate-module aliases) expansion)]
+ (if (dict;empty? aliases)
+ (loop [expansion-aliases expansion-aliases]
+ (case expansion-aliases
+ #;Nil
+ (wrap aliases)
+
+ (#;Cons head tail)
+ (if (dict;empty? head)
+ (recur tail)
+ (wrap head))))
+ (wrap aliases)))
#;None
(&;throw Unrecognized-Statement (%code code))))
@@ -100,7 +114,7 @@
[_ (ensure-valid-alias def-name annsV valueC)
_ (&;with-scope
(statementT;translate-def def-name Void id annsI annsV))]
- (wrap []))
+ (wrap aliases))
#;None
(do @
@@ -114,10 +128,15 @@
(analyse valueC))))
valueT (&;with-type-env
(tc;clean valueT))
+ ## #let [_ (if (or (text/= "list/size" def-name))
+ ## (log! (format "{" def-name "}\n"
+ ## " ANALYSIS: " (%code valueA) "\n"
+ ## "SYNTHESIS: " (%code (expressionS;synthesize valueA))))
+ ## [])]
valueI (expressionT;translate (expressionS;synthesize valueA))
_ (&;with-scope
(statementT;translate-def def-name valueT valueI annsI annsV))]
- (wrap []))))))
+ (wrap aliases))))))
(^code ("lux module" (~ annsC)))
(do macro;Monad<Meta>
@@ -135,23 +154,24 @@
[[_ programA] (&;with-scope
(&;with-type (type (io;IO Unit))
(analyse programC)))
- programI (expressionT;translate (expressionS;synthesize programA))]
- (statementT;translate-program program-args programI))
+ programI (expressionT;translate (expressionS;synthesize programA))
+ _ (statementT;translate-program program-args programI)]
+ (wrap aliases))
_
(&;throw Unrecognized-Statement (%code code))))
-(def: (exhaust action)
- (All [a] (-> (Meta a) (Meta Unit)))
+(def: (forgive-eof action)
+ (-> (Meta Unit) (Meta Unit))
(function [compiler]
(case (action compiler)
- (#e;Success [compiler' _])
- ((exhaust action) compiler')
-
(#e;Error error)
(if (ex;match? syntax;End-Of-File error)
(#e;Success [compiler []])
- (#e;Error error)))))
+ (#e;Error error))
+
+ output
+ output)))
(def: prelude Text "lux")
@@ -164,10 +184,10 @@
_ (moduleL;flag-compiled! module-name)]
(wrap output)))
-(def: (read current-module)
- (-> Text (Meta Code))
+(def: (read current-module aliases)
+ (-> Text Aliases (Meta Code))
(function [compiler]
- (case (syntax;read current-module (get@ #;source compiler))
+ (case (syntax;read current-module aliases (get@ #;source compiler))
(#e;Error error)
(#e;Error error)
@@ -178,8 +198,7 @@
(def: (translate-module source-dirs target-dir module-name compiler)
(-> (List File) File Text Compiler (Process Compiler))
(do io;Monad<Process>
- [#let [_ (log! (format "{translate-module} " module-name))]
- ## _ (&io;prepare-module target-dir module-name)
+ [## _ (&io;prepare-module target-dir module-name)
[file-name file-content] (&io;read-module source-dirs module-name)
#let [module-hash (text/hash file-content)
translate-module (translate-module source-dirs target-dir)]]
@@ -190,12 +209,15 @@
(with-active-compilation [module-name
file-name
file-content]
- (exhaust
- (do @
- [code (read module-name)
- #let [[cursor _] code]]
- (&;with-cursor cursor
- (translate translate-module code)))))))]
+ (forgive-eof
+ (loop [aliases (: Aliases
+ (dict;new text;Hash<Text>))]
+ (do @
+ [code (read module-name aliases)
+ #let [[cursor _] code]
+ aliases' (&;with-cursor cursor
+ (translate translate-module aliases code))]
+ (forgive-eof (recur aliases'))))))))]
(wrap artifacts)))
(#e;Success [compiler artifacts])
(do @
diff --git a/new-luxc/source/luxc/lang/translation/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/imports.jvm.lux
index c30f61225..be8b828cd 100644
--- a/new-luxc/source/luxc/lang/translation/imports.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/imports.jvm.lux
@@ -111,7 +111,6 @@
(do macro;Monad<Meta>
[_ (moduleL;set-annotations annotations)
current-module macro;current-module-name
- #let [_ (log! (format "{translate-imports} " current-module))]
imports (let [imports (|> (macro;get-tuple-ann (ident-for #;imports) annotations)
(maybe;default (list)))]
(case (s;run imports (p;some import))
diff --git a/new-luxc/source/luxc/lang/translation/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/loop.jvm.lux
index f5830bf9e..77d43a0e5 100644
--- a/new-luxc/source/luxc/lang/translation/loop.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/loop.jvm.lux
@@ -16,7 +16,18 @@
(translation [";T" common]
[";T" runtime]
[";T" reference])
- [";L" variable #+ Variable])))
+ [";L" variable #+ Variable Register])))
+
+(def: (constant? register changeS)
+ (-> Register ls;Synthesis Bool)
+ (case changeS
+ (^multi (^code ((~ [_ (#;Int var)])))
+ (i.= (variableL;local register)
+ var))
+ true
+
+ _
+ false))
(def: #export (translate-recur translate argsS)
(-> (-> ls;Synthesis (Meta $;Inst))
@@ -24,23 +35,30 @@
(Meta $;Inst))
(do macro;Monad<Meta>
[[@begin offset] hostL;anchor
- argsI (monad;map @ (function [[register argS]]
- (let [register' (|> register (n.+ offset))]
- (: (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)
+ #let [pairs (list;zip2 (list;n.range offset (|> (list;size argsS) n.dec (n.+ offset)))
+ argsS)]
+ ## It may look weird that first I compile the values separately,
+ ## and then I compile the stores/allocations.
+ ## It must be done that way in order to avoid a potential bug.
+ ## Let's say that you'll recur with 2 expressions: X and Y.
+ ## If Y depends on the value of X, and you don't compile values
+ ## and stores separately, then by the time Y is evaluated, it
+ ## will refer to the new value of X, instead of the old value, as
+ ## must be the case.
+ valuesI+ (monad;map @ (function [[register argS]]
+ (: (Meta $;Inst)
+ (if (constant? register argS)
+ (wrap id)
+ (translate argS))))
+ pairs)
+ #let [storesI+ (list/map (function [[register argS]]
+ (: $;Inst
+ (if (constant? register argS)
+ id
+ ($i;ASTORE register))))
+ (list;reverse pairs))]]
+ (wrap (|>. ($i;fuse valuesI+)
+ ($i;fuse storesI+)
($i;GOTO @begin)))))
(def: #export (translate-loop translate offset initsS+ bodyS)
@@ -50,12 +68,12 @@
(do macro;Monad<Meta>
[@begin $i;make-label
initsI+ (monad;map @ translate initsS+)
- bodyI (hostL;with-anchor [@begin (n.inc offset)]
+ 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;ASTORE (n.+ offset register)))))
$i;fuse)]]
(wrap (|>. initializationI
($i;label @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 0e17f99a6..6c1b18932 100644
--- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
@@ -267,65 +267,61 @@
$;Method
($t;method (list $t;long $t;long) (#;Some $t;int) (list)))
-(do-template [<name> <const> <wrapper>]
+(do-template [<name> <const> <type>]
[(def: (<name> _)
Nullary
- (|>. <const> <wrapper>))]
+ (|>. <const> ($i;wrap <type>)))]
- [nat//min ($i;long 0) ($i;wrap #$;Long)]
- [nat//max ($i;long -1) ($i;wrap #$;Long)]
+ [nat//min ($i;long 0) #$;Long]
+ [nat//max ($i;long -1) #$;Long]
- [int//min ($i;long Long.MIN_VALUE) ($i;wrap #$;Long)]
- [int//max ($i;long Long.MAX_VALUE) ($i;wrap #$;Long)]
+ [int//min ($i;long Long.MIN_VALUE) #$;Long]
+ [int//max ($i;long Long.MAX_VALUE) #$;Long]
- [frac//smallest ($i;double Double.MIN_VALUE) ($i;wrap #$;Double)]
- [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) ($i;wrap #$;Double)]
- [frac//max ($i;double Double.MAX_VALUE) ($i;wrap #$;Double)]
- [frac//not-a-number ($i;double Double.NaN) ($i;wrap #$;Double)]
- [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) ($i;wrap #$;Double)]
- [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) ($i;wrap #$;Double)]
-
- [deg//min ($i;long 0) ($i;wrap #$;Long)]
- [deg//max ($i;long -1) ($i;wrap #$;Long)]
+ [frac//smallest ($i;double Double.MIN_VALUE) #$;Double]
+ [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) #$;Double]
+ [frac//max ($i;double Double.MAX_VALUE) #$;Double]
+ [frac//not-a-number ($i;double Double.NaN) #$;Double]
+ [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) #$;Double]
+ [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) #$;Double]
+
+ [deg//min ($i;long 0) #$;Long]
+ [deg//max ($i;long -1) #$;Long]
)
-(do-template [<name> <unwrap> <wrap> <op>]
+(do-template [<name> <type> <op>]
[(def: (<name> [subjectI paramI])
Binary
- (|>. subjectI <unwrap>
- paramI <unwrap>
+ (|>. subjectI ($i;unwrap <type>)
+ paramI ($i;unwrap <type>)
<op>
- <wrap>))]
+ ($i;wrap <type>)))]
- [int//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
- [int//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
- [int//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
- [int//div ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV]
- [int//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LREM]
+ [int//add #$;Long $i;LADD]
+ [int//sub #$;Long $i;LSUB]
+ [int//mul #$;Long $i;LMUL]
+ [int//div #$;Long $i;LDIV]
+ [int//rem #$;Long $i;LREM]
- [nat//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
- [nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
- [nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
- [nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)]
- [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)]
-
- [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD]
- [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB]
- [frac//mul ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DMUL]
- [frac//div ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DDIV]
- [frac//rem ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DREM]
-
- [deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
- [deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
- [deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)]
- [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)]
- [deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
- [deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
- [deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV]
+ [nat//add #$;Long $i;LADD]
+ [nat//sub #$;Long $i;LSUB]
+ [nat//mul #$;Long $i;LMUL]
+ [nat//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)]
+ [nat//rem #$;Long ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)]
+
+ [frac//add #$;Double $i;DADD]
+ [frac//sub #$;Double $i;DSUB]
+ [frac//mul #$;Double $i;DMUL]
+ [frac//div #$;Double $i;DDIV]
+ [frac//rem #$;Double $i;DREM]
+
+ [deg//add #$;Long $i;LADD]
+ [deg//sub #$;Long $i;LSUB]
+ [deg//mul #$;Long ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)]
+ [deg//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)]
+ [deg//rem #$;Long $i;LSUB]
+ [deg//scale #$;Long $i;LMUL]
+ [deg//reciprocal #$;Long $i;LDIV]
)
(do-template [<eq> <lt> <unwrap> <cmp>]
@@ -382,11 +378,11 @@
($i;INVOKEVIRTUAL <class> <method> ($t;method (list) (#;Some <outputT>) (list)) false)
<post>))]
- [text//size "java.lang.String" "length" lux-intI $t;int]
- [text//hash "java.lang.Object" "hashCode" lux-intI $t;int]
- [text//trim "java.lang.String" "trim" id $String]
- [text//upper-case "java.lang.String" "toUpperCase" id $String]
- [text//lower-case "java.lang.String" "toLowerCase" id $String]
+ [text//size "java.lang.String" "length" lux-intI $t;int]
+ [text//hash "java.lang.Object" "hashCode" lux-intI $t;int]
+ [text//trim "java.lang.String" "trim" id $String]
+ [text//upper "java.lang.String" "toUpperCase" id $String]
+ [text//lower "java.lang.String" "toLowerCase" id $String]
)
(do-template [<name> <pre-subject> <pre-param> <op> <post>]
@@ -676,18 +672,21 @@
(def: text-procs
Bundle
- (|> (dict;new text;Hash<Text>)
- (install "text =" (binary text//eq))
- (install "text <" (binary text//lt))
- (install "text concat" (binary text//concat))
- (install "text index" (trinary text//index))
- (install "text size" (unary text//size))
- (install "text hash" (unary text//hash))
- (install "text replace-once" (trinary text//replace-once))
- (install "text replace-all" (trinary text//replace-all))
- (install "text char" (binary text//char))
- (install "text clip" (trinary text//clip))
- ))
+ (<| (prefix "text")
+ (|> (dict;new text;Hash<Text>)
+ (install "=" (binary text//eq))
+ (install "<" (binary text//lt))
+ (install "concat" (binary text//concat))
+ (install "index" (trinary text//index))
+ (install "size" (unary text//size))
+ (install "hash" (unary text//hash))
+ (install "replace-once" (trinary text//replace-once))
+ (install "replace-all" (trinary text//replace-all))
+ (install "char" (binary text//char))
+ (install "clip" (trinary text//clip))
+ (install "upper" (unary text//upper))
+ (install "lower" (unary text//lower))
+ )))
(def: array-procs
Bundle
diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux
index 87174b192..d2bb1645b 100644
--- a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux
@@ -198,7 +198,6 @@
div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))
upcastI ($i;INVOKESTATIC hostL;runtime-class "_toUnsignedBigInteger" upcast-method false)
downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)]
- ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215
(|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method
(let [upcastI ($i;INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false)
discernI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGE @where)))
@@ -220,14 +219,12 @@
($i;LLOAD +0)
upcastI
$i;ARETURN))))
- ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267
($d;method #$;Public $;staticM "compare_nat" compare-nat-method
(let [shiftI (|>. ($i;GETSTATIC "java.lang.Long" "MIN_VALUE" $t;long) $i;LADD)]
(|>. ($i;LLOAD +0) shiftI
($i;LLOAD +2) shiftI
$i;LCMP
$i;IRETURN)))
- ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290
($d;method #$;Public $;staticM "div_nat" div-method
(let [is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLT @where)))
is-subject-smallI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGT @where)))
@@ -257,7 +254,6 @@
## Less than
($i;label @is-zero)
($i;long 0) $i;LRETURN))))
- ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323
($d;method #$;Public $;staticM "rem_nat" div-method
(let [is-subject-largeI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFLE @where)))
is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLE @where)))