aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc')
-rw-r--r--new-luxc/source/luxc/analyser.lux253
-rw-r--r--new-luxc/source/luxc/analyser/case.lux32
-rw-r--r--new-luxc/source/luxc/analyser/function.lux13
-rw-r--r--new-luxc/source/luxc/analyser/inference.lux158
-rw-r--r--new-luxc/source/luxc/analyser/reference.lux22
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux71
-rw-r--r--new-luxc/source/luxc/base.lux8
-rw-r--r--new-luxc/source/luxc/generator.lux46
-rw-r--r--new-luxc/source/luxc/generator/case.jvm.lux63
-rw-r--r--new-luxc/source/luxc/generator/expr.jvm.lux34
-rw-r--r--new-luxc/source/luxc/generator/function.jvm.lux19
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux132
-rw-r--r--new-luxc/source/luxc/generator/primitive.jvm.lux9
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux41
-rw-r--r--new-luxc/source/luxc/generator/procedure/host.jvm.lux7
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux104
-rw-r--r--new-luxc/source/luxc/generator/structure.jvm.lux9
-rw-r--r--new-luxc/source/luxc/host.jvm.lux4
-rw-r--r--new-luxc/source/luxc/module/descriptor/annotation.lux2
-rw-r--r--new-luxc/source/luxc/scope.lux6
-rw-r--r--new-luxc/source/luxc/synthesizer/case.lux24
-rw-r--r--new-luxc/source/luxc/synthesizer/function.lux18
-rw-r--r--new-luxc/source/program.lux10
-rw-r--r--new-luxc/test/test/luxc/generator/case.lux13
-rw-r--r--new-luxc/test/test/luxc/generator/primitive.lux5
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/host.jvm.lux5
-rw-r--r--new-luxc/test/test/luxc/generator/reference.lux22
-rw-r--r--new-luxc/test/test/luxc/generator/structure.lux5
-rw-r--r--new-luxc/test/tests.lux3
29 files changed, 676 insertions, 462 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index b10f29369..f0712794d 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -1,14 +1,19 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
(data ["e" error]
+ [product]
text/format)
[meta]
(meta [type]
- (type ["tc" check])))
+ (type ["tc" check]))
+ [host #+ do-to])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis])
- ["&;" module])
+ ["&;" module]
+ (generator [";G" common]))
(. ["&&;" common]
["&&;" function]
["&&;" primitive]
@@ -18,6 +23,37 @@
["&&;" case]
["&&;" procedure]))
+(for {"JVM" (as-is (host;import java.lang.reflect.Method
+ (invoke [Object (Array Object)] #try Object))
+ (host;import (java.lang.Class c)
+ (getMethod [String (Array (Class Object))] #try Method))
+ (host;import java.lang.Object
+ (getClass [] (Class Object))
+ (toString [] String))
+ (def: _object-class (Class Object) (host;class-for Object))
+ (def: _apply-args
+ (Array (Class Object))
+ (|> (host;array (Class Object) +2)
+ (host;array-write +0 _object-class)
+ (host;array-write +1 _object-class)))
+ (def: (call-macro macro inputs)
+ (-> Macro (List Code) (Meta (List Code)))
+ (do meta;Monad<Meta>
+ [class (commonG;load-class hostL;function-class)]
+ (function [compiler]
+ (do e;Monad<Error>
+ [apply-method (Class.getMethod ["apply" _apply-args] class)
+ output (Method.invoke [(:! Object macro)
+ (|> (host;array Object +2)
+ (host;array-write +0 (:! Object inputs))
+ (host;array-write +1 (:! Object compiler)))]
+ apply-method)]
+ (:! (e;Error [Compiler (List Code)])
+ output))))))
+ })
+
+(exception: #export Macro-Expression-Must-Have-Single-Expansion)
+
(def: (to-branches raw)
(-> (List Code) (Meta (List [Code Code])))
(case raw
@@ -36,104 +72,113 @@
(-> &;Eval &;Analyser)
(: (-> Code (Meta la;Analysis))
(function analyse [ast]
- (let [[cursor ast'] ast]
- ## The cursor must be set in the compiler for the sake
- ## of having useful error messages.
- (&;with-cursor cursor
- (case ast'
- (^template [<tag> <analyser>]
- (<tag> value)
- (<analyser> value))
- ([#;Bool &&primitive;analyse-bool]
- [#;Nat &&primitive;analyse-nat]
- [#;Int &&primitive;analyse-int]
- [#;Deg &&primitive;analyse-deg]
- [#;Frac &&primitive;analyse-frac]
- [#;Text &&primitive;analyse-text])
-
- (^ (#;Tuple (list)))
- &&primitive;analyse-unit
-
- ## Singleton tuples are equivalent to the element they contain.
- (^ (#;Tuple (list singleton)))
- (analyse singleton)
-
- (^ (#;Tuple elems))
- (&&structure;analyse-product analyse elems)
-
- (^ (#;Record pairs))
- (&&structure;analyse-record analyse pairs)
-
- (#;Symbol reference)
- (&&reference;analyse-reference reference)
-
- (^ (#;Form (list [_ (#;Text "lux function")]
- [_ (#;Symbol ["" func-name])]
- [_ (#;Symbol ["" arg-name])]
- body)))
- (&&function;analyse-function analyse func-name arg-name body)
-
- (^template [<special> <analyser>]
- (^ (#;Form (list [_ (#;Text <special>)] type value)))
- (<analyser> analyse eval type value))
- (["lux check" &&type;analyse-check]
- ["lux coerce" &&type;analyse-coerce])
-
- (^ (#;Form (list& [_ (#;Text "lux case")]
- input
- branches)))
- (do meta;Monad<Meta>
- [paired (to-branches branches)]
- (&&case;analyse-case analyse input paired))
-
- (^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
- (&&procedure;analyse-procedure analyse proc-name proc-args)
-
- (^template [<tag> <analyser>]
- (^ (#;Form (list& [_ (<tag> tag)]
- values)))
- (case values
- (#;Cons value #;Nil)
- (<analyser> analyse tag value)
-
- _
- (<analyser> analyse tag (` [(~@ values)]))))
- ([#;Nat &&structure;analyse-sum]
- [#;Tag &&structure;analyse-tagged-sum])
-
- (#;Tag tag)
- (&&structure;analyse-tagged-sum analyse tag (' []))
-
- (^ (#;Form (list& func args)))
- (do meta;Monad<Meta>
- [[funcT =func] (&&common;with-unknown-type
- (analyse func))]
- (case =func
- (#la;Definition def-name)
- (do @
- [[def-type def-anns def-value] (meta;find-def def-name)]
- (if (meta;macro? def-anns)
- (do @
- [## macro-expansion (function [compiler]
- ## (case (macro-caller def-value args compiler)
- ## (#e;Success [compiler' output])
- ## (#e;Success [compiler' output])
-
- ## (#e;Error error)
- ## ((&;fail error) compiler)))
- macro-expansion (: (Meta (List Code))
- (undefined))]
- (case macro-expansion
- (^ (list single-expansion))
- (analyse single-expansion)
-
- _
- (&;fail (format "Macro expressions must expand to a single expression: " (%code ast)))))
- (&&function;analyse-apply analyse funcT =func args)))
-
- _
- (&&function;analyse-apply analyse funcT =func args)))
-
- _
- (&;fail (format "Unrecognized syntax: " (%code ast)))
- ))))))
+ (do meta;Monad<Meta>
+ [expectedT meta;expected-type]
+ (let [[cursor ast'] ast]
+ ## The cursor must be set in the compiler for the sake
+ ## of having useful error messages.
+ (&;with-cursor cursor
+ (case ast'
+ (^template [<tag> <analyser>]
+ (<tag> value)
+ (<analyser> value))
+ ([#;Bool &&primitive;analyse-bool]
+ [#;Nat &&primitive;analyse-nat]
+ [#;Int &&primitive;analyse-int]
+ [#;Deg &&primitive;analyse-deg]
+ [#;Frac &&primitive;analyse-frac]
+ [#;Text &&primitive;analyse-text])
+
+ (^ (#;Tuple (list)))
+ &&primitive;analyse-unit
+
+ ## Singleton tuples are equivalent to the element they contain.
+ (^ (#;Tuple (list singleton)))
+ (analyse singleton)
+
+ (^ (#;Tuple elems))
+ (&&structure;analyse-product analyse elems)
+
+ (^ (#;Record pairs))
+ (&&structure;analyse-record analyse pairs)
+
+ (#;Symbol reference)
+ (&&reference;analyse-reference reference)
+
+ (^ (#;Form (list [_ (#;Text "lux function")]
+ [_ (#;Symbol ["" func-name])]
+ [_ (#;Symbol ["" arg-name])]
+ body)))
+ (&&function;analyse-function analyse func-name arg-name body)
+
+ (^template [<special> <analyser>]
+ (^ (#;Form (list [_ (#;Text <special>)] type value)))
+ (<analyser> analyse eval type value))
+ (["lux check" &&type;analyse-check]
+ ["lux coerce" &&type;analyse-coerce])
+
+ (^ (#;Form (list [_ (#;Text "lux check type")] valueC)))
+ (do meta;Monad<Meta>
+ [valueA (&;with-expected-type Type
+ (analyse valueC))
+ expected meta;expected-type
+ _ (&;with-type-env
+ (tc;check expected Type))]
+ (wrap valueA))
+
+ (^ (#;Form (list& [_ (#;Text "lux case")]
+ input
+ branches)))
+ (do meta;Monad<Meta>
+ [paired (to-branches branches)]
+ (&&case;analyse-case analyse input paired))
+
+ (^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
+ (&&procedure;analyse-procedure analyse proc-name proc-args)
+
+ (^template [<tag> <analyser>]
+ (^ (#;Form (list& [_ (<tag> tag)]
+ values)))
+ (case values
+ (#;Cons value #;Nil)
+ (<analyser> analyse tag value)
+
+ _
+ (<analyser> analyse tag (` [(~@ values)]))))
+ ([#;Nat &&structure;analyse-sum]
+ [#;Tag &&structure;analyse-tagged-sum])
+
+ (#;Tag tag)
+ (&&structure;analyse-tagged-sum analyse tag (' []))
+
+ (^ (#;Form (list& func args)))
+ (do meta;Monad<Meta>
+ [[funcT =func] (&&common;with-unknown-type
+ (analyse func))]
+ (case =func
+ (#la;Definition def-name)
+ (do @
+ [[def-type def-anns def-value] (meta;find-def def-name)]
+ (if (meta;macro? def-anns)
+ (do @
+ [expansion (function [compiler]
+ (case (call-macro (:! Macro def-value) args compiler)
+ (#e;Success [compiler' output])
+ (#e;Success [compiler' output])
+
+ (#e;Error error)
+ ((&;fail error) compiler)))]
+ (case expansion
+ (^ (list single))
+ (analyse single)
+
+ _
+ (&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast))))
+ (&&function;analyse-apply analyse funcT =func args)))
+
+ _
+ (&&function;analyse-apply analyse funcT =func args)))
+
+ _
+ (&;fail (format "Unrecognized syntax: " (%code ast)))
+ )))))))
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux
index b65b9ff94..b17dbcbfd 100644
--- a/new-luxc/source/luxc/analyser/case.lux
+++ b/new-luxc/source/luxc/analyser/case.lux
@@ -1,6 +1,7 @@
(;module:
lux
(lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
eq)
(data [bool]
[number]
@@ -21,10 +22,15 @@
["&;" structure])
(. ["&&;" coverage]))
+(exception: #export Cannot-Match-Type-With-Pattern)
+(exception: #export Sum-Type-Has-No-Case)
+(exception: #export Unrecognized-Pattern-Syntax)
+
(def: (pattern-error type pattern)
(-> Type Code Text)
- (format "Cannot match this type: " (%type type) "\n"
- " With this pattern: " (%code pattern)))
+ (Cannot-Match-Type-With-Pattern
+ (format " Type: " (%type type) "\n"
+ "Pattern: " (%code pattern))))
## Type-checking on the input value is done during the analysis of a
## "case" expression, to ensure that the patterns being used make
@@ -56,6 +62,14 @@
tc;existential)]
(simplify-case-type (maybe;assume (type;apply (list exT) type))))
+ (#;Apply inputT funcT)
+ (case (type;apply (list inputT) funcT)
+ (#;Some outputT)
+ (:: meta;Monad<Meta> wrap outputT)
+
+ #;None
+ (&;fail (format "Cannot apply type " (%type funcT) " to type " (%type inputT))))
+
_
(:: meta;Monad<Meta> wrap type)))
@@ -122,7 +136,7 @@
[inputT' (simplify-case-type inputT)]
(case inputT'
(#;Product _)
- (let [sub-types (type;flatten-tuple inputT)
+ (let [sub-types (type;flatten-tuple inputT')
num-sub-types (maybe;default (list;size sub-types)
num-tags)
num-sub-patterns (list;size sub-patterns)
@@ -175,7 +189,7 @@
[inputT' (simplify-case-type inputT)]
(case inputT'
(#;Sum _)
- (let [flat-sum (type;flatten-variant inputT)
+ (let [flat-sum (type;flatten-variant inputT')
size-sum (list;size flat-sum)
num-cases (maybe;default size-sum num-tags)]
(case (list;nth idx flat-sum)
@@ -196,7 +210,9 @@
nextA])))
_
- (&;fail (format "Cannot match index " (%n idx) " against type: " (%type inputT)))))
+ (&;throw Sum-Type-Has-No-Case
+ (format "Case: " (%n idx) "\n"
+ "Type: " (%type inputT)))))
_
(&;fail (pattern-error inputT pattern)))))
@@ -211,10 +227,10 @@
(analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next)))
_
- (&;fail (format "Unrecognized pattern syntax: " (%code pattern)))
+ (&;throw Unrecognized-Pattern-Syntax (%code pattern))
))
-(def: #export (analyse-case analyse input branches)
+(def: #export (analyse-case analyse inputC branches)
(-> &;Analyser Code (List [Code Code]) (Meta la;Analysis))
(case branches
#;Nil
@@ -223,7 +239,7 @@
(#;Cons [patternH bodyH] branchesT)
(do meta;Monad<Meta>
[[inputT inputA] (&common;with-unknown-type
- (analyse input))
+ (analyse inputC))
outputH (analyse-pattern #;None inputT patternH (analyse bodyH))
outputT (monad;map @
(function [[patternT bodyT]]
diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux
index 1432308f8..55896480e 100644
--- a/new-luxc/source/luxc/analyser/function.lux
+++ b/new-luxc/source/luxc/analyser/function.lux
@@ -1,6 +1,7 @@
(;module:
lux
- (lux (control monad)
+ (lux (control monad
+ ["ex" exception #+ exception:])
(data [maybe]
[text]
text/format
@@ -14,6 +15,9 @@
(analyser ["&;" common]
["&;" inference])))
+(exception: #export Invalid-Function-Type)
+(exception: #export Cannot-Apply-Function)
+
## [Analysers]
(def: #export (analyse-function analyse func-name arg-name body)
(-> &;Analyser Text Text Code (Meta Analysis))
@@ -21,7 +25,7 @@
[functionT meta;expected-type]
(loop [expectedT functionT]
(&;with-stacked-errors
- (function [_] (format "Functions require function types: " (type;to-text expectedT)))
+ (function [_] (Invalid-Function-Type (%type expectedT)))
(case expectedT
(#;Named name unnamedT)
(recur unnamedT)
@@ -92,8 +96,9 @@
(def: #export (analyse-apply analyse funcT funcA args)
(-> &;Analyser Type Analysis (List Code) (Meta Analysis))
(&;with-stacked-errors
- (function [_] (format "Cannot apply function " (%type funcT)
- " to args: " (|> args (list/map %code) (text;join-with " "))))
+ (function [_]
+ (Cannot-Apply-Function (format " Function: " (%type funcT) "\n"
+ "Arguments: " (|> args (list/map %code) (text;join-with " ")))))
(do Monad<Meta>
[expected meta;expected-type
[applyT argsA] (&inference;apply-function analyse funcT args)
diff --git a/new-luxc/source/luxc/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux
index 86832ae9e..049abec28 100644
--- a/new-luxc/source/luxc/analyser/inference.lux
+++ b/new-luxc/source/luxc/analyser/inference.lux
@@ -1,9 +1,11 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
(data [maybe]
+ [text]
text/format
- (coll [list "L/" Functor<List>]))
+ (coll [list "list/" Functor<List>]))
[meta #+ Monad<Meta>]
(meta [type]
(type ["tc" check])))
@@ -11,6 +13,10 @@
(lang ["la" analysis #+ Analysis])
(analyser ["&;" common])))
+(exception: #export Cannot-Infer)
+(exception: #export Cannot-Infer-Argument)
+(exception: #export Smaller-Variant-Than-Expected)
+
## When doing inference, type-variables often need to be created in
## order to figure out which types are present in the expression being
## inferred.
@@ -23,7 +29,7 @@
(-> Nat Nat Type Type)
(case type
(#;Primitive name params)
- (#;Primitive name (L/map (replace-var var-id bound-idx) params))
+ (#;Primitive name (list/map (replace-var var-id bound-idx) params))
(^template [<tag>]
(<tag> left right)
@@ -41,15 +47,41 @@
(^template [<tag>]
(<tag> env quantified)
- (<tag> (L/map (replace-var var-id bound-idx) env)
+ (<tag> (list/map (replace-var var-id bound-idx) env)
(replace-var var-id (n.+ +2 bound-idx) quantified)))
([#;UnivQ]
[#;ExQ])
- (#;Named name unnamedT)
- (#;Named name
- (replace-var var-id bound-idx unnamedT))
+ _
+ type))
+(def: (replace-bound bound-idx replacementT type)
+ (-> Nat Type Type Type)
+ (case type
+ (#;Primitive name params)
+ (#;Primitive name (list/map (replace-bound bound-idx replacementT) params))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (replace-bound bound-idx replacementT left)
+ (replace-bound bound-idx replacementT right)))
+ ([#;Sum]
+ [#;Product]
+ [#;Function]
+ [#;Apply])
+
+ (#;Bound idx)
+ (if (n.= bound-idx idx)
+ replacementT
+ type)
+
+ (^template [<tag>]
+ (<tag> env quantified)
+ (<tag> (list/map (replace-bound bound-idx replacementT) env)
+ (replace-bound (n.+ +2 bound-idx) replacementT quantified)))
+ ([#;UnivQ]
+ [#;ExQ])
+
_
type))
@@ -66,7 +98,7 @@
#;Nil
(:: Monad<Meta> wrap [funcT (list)])
- (#;Cons arg args')
+ (#;Cons argC args')
(case funcT
(#;Named name unnamedT)
(apply-function analyse unnamedT args)
@@ -104,29 +136,31 @@
(do Monad<Meta>
[[outputT' args'A] (apply-function analyse outputT args')
argA (&;with-stacked-errors
- (function [_] (format "Expected type: " (%type inputT) "\n"
- " For argument: " (%code arg)))
+ (function [_] (Cannot-Infer-Argument
+ (format "Inferred Type: " (%type inputT) "\n"
+ " Argument: " (%code argC))))
(&;with-expected-type inputT
- (analyse arg)))]
+ (analyse argC)))]
(wrap [outputT' (list& argA args'A)]))
_
- (&;fail (format "Cannot apply a non-function: " (%type funcT))))
+ (&;throw Cannot-Infer (format "Inference Type: " (%type funcT)
+ " Arguments: " (|> args (list/map %code) (text;join-with " ")))))
))
## Turns a record type into the kind of function type suitable for inference.
-(def: #export (record-inference-type type)
+(def: #export (record type)
(-> Type (Meta Type))
(case type
(#;Named name unnamedT)
(do Monad<Meta>
- [unnamedT+ (record-inference-type unnamedT)]
- (wrap (#;Named name unnamedT+)))
+ [unnamedT+ (record unnamedT)]
+ (wrap unnamedT+))
(^template [<tag>]
(<tag> env bodyT)
(do Monad<Meta>
- [bodyT+ (record-inference-type bodyT)]
+ [bodyT+ (record bodyT)]
(wrap (<tag> env bodyT+))))
([#;UnivQ]
[#;ExQ])
@@ -138,47 +172,57 @@
(&;fail (format "Not a record type: " (%type type)))))
## Turns a variant type into the kind of function type suitable for inference.
-(def: #export (variant-inference-type tag expected-size type)
+(def: #export (variant tag expected-size type)
(-> Nat Nat Type (Meta Type))
- (case type
- (#;Named name unnamedT)
- (do Monad<Meta>
- [unnamedT+ (variant-inference-type tag expected-size unnamedT)]
- (wrap (#;Named name unnamedT+)))
-
- (^template [<tag>]
- (<tag> env bodyT)
+ (loop [depth +0
+ currentT type]
+ (case currentT
+ (#;Named name unnamedT)
(do Monad<Meta>
- [bodyT+ (variant-inference-type tag expected-size bodyT)]
- (wrap (<tag> env bodyT+))))
- ([#;UnivQ]
- [#;ExQ])
-
- (#;Sum _)
- (let [cases (type;flatten-variant type)
- actual-size (list;size cases)
- boundary (n.dec expected-size)]
- (cond (or (n.= expected-size actual-size)
- (and (n.> expected-size actual-size)
- (n.< boundary tag)))
- (case (list;nth tag cases)
- (#;Some caseT)
- (:: Monad<Meta> wrap (type;function (list caseT) type))
-
- #;None
- (&common;variant-out-of-bounds-error type expected-size tag))
-
- (n.< expected-size actual-size)
- (&;fail (format "Variant type is smaller than expected." "\n"
- "Expected: " (%i (nat-to-int expected-size)) "\n"
- " Actual: " (%i (nat-to-int actual-size))))
-
- (n.= boundary tag)
- (let [caseT (type;variant (list;drop boundary cases))]
- (:: Monad<Meta> wrap (type;function (list caseT) type)))
-
- ## else
- (&common;variant-out-of-bounds-error type expected-size tag)))
+ [unnamedT+ (recur depth unnamedT)]
+ (wrap unnamedT+))
+
+ (^template [<tag>]
+ (<tag> env bodyT)
+ (do Monad<Meta>
+ [bodyT+ (recur (n.inc depth) bodyT)]
+ (wrap (<tag> env bodyT+))))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;Sum _)
+ (let [cases (type;flatten-variant currentT)
+ actual-size (list;size cases)
+ boundary (n.dec expected-size)]
+ (cond (or (n.= expected-size actual-size)
+ (and (n.> expected-size actual-size)
+ (n.< boundary tag)))
+ (case (list;nth tag cases)
+ (#;Some caseT)
+ (:: Monad<Meta> wrap (if (n.= +0 depth)
+ (type;function (list caseT) currentT)
+ (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+ (type;function (list (replace! caseT))
+ (replace! currentT)))))
+
+ #;None
+ (&common;variant-out-of-bounds-error type expected-size tag))
+
+ (n.< expected-size actual-size)
+ (&;throw Smaller-Variant-Than-Expected
+ (format "Expected: " (%i (nat-to-int expected-size)) "\n"
+ " Actual: " (%i (nat-to-int actual-size))))
+
+ (n.= boundary tag)
+ (let [caseT (type;variant (list;drop boundary cases))]
+ (:: Monad<Meta> wrap (if (n.= +0 depth)
+ (type;function (list caseT) currentT)
+ (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+ (type;function (list (replace! caseT))
+ (replace! currentT))))))
+
+ ## else
+ (&common;variant-out-of-bounds-error type expected-size tag)))
- _
- (&;fail (format "Not a variant type: " (%type type)))))
+ _
+ (&;fail (format "Not a variant type: " (%type type))))))
diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux
index 9756a1b9c..4a2f6dbc5 100644
--- a/new-luxc/source/luxc/analyser/reference.lux
+++ b/new-luxc/source/luxc/analyser/reference.lux
@@ -1,8 +1,8 @@
(;module:
lux
(lux (control monad)
- [meta #+ Monad<Meta>]
- (meta (type ["TC" check])))
+ [meta]
+ (meta (type ["tc" check])))
(luxc ["&" base]
(lang ["la" analysis #+ Analysis])
["&;" scope]))
@@ -10,23 +10,23 @@
## [Analysers]
(def: (analyse-definition def-name)
(-> Ident (Meta Analysis))
- (do Monad<Meta>
- [actual (meta;find-def-type def-name)
- expected meta;expected-type
+ (do meta;Monad<Meta>
+ [actualT (meta;find-def-type def-name)
+ expectedT meta;expected-type
_ (&;with-type-env
- (TC;check expected actual))]
+ (tc;check expectedT actualT))]
(wrap (#la;Definition def-name))))
(def: (analyse-variable var-name)
(-> Text (Meta (Maybe Analysis)))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[?var (&scope;find var-name)]
(case ?var
- (#;Some [actual ref])
+ (#;Some [actualT ref])
(do @
- [expected meta;expected-type
+ [expectedT meta;expected-type
_ (&;with-type-env
- (TC;check expected actual))]
+ (tc;check expectedT actualT))]
(wrap (#;Some (#la;Variable ref))))
#;None
@@ -36,7 +36,7 @@
(-> Ident (Meta Analysis))
(case reference
["" simple-name]
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[?var (analyse-variable simple-name)]
(case ?var
(#;Some analysis)
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux
index 8c1f7118c..7720202d8 100644
--- a/new-luxc/source/luxc/analyser/structure.lux
+++ b/new-luxc/source/luxc/analyser/structure.lux
@@ -1,6 +1,7 @@
(;module:
lux
(lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
pipe)
[function]
(concurrency ["A" atom])
@@ -23,13 +24,13 @@
(analyser ["&;" common]
["&;" inference])))
+(exception: #export Not-Variant-Type)
+(exception: #export Not-Tuple-Type)
+(exception: #export Cannot-Infer-Numeric-Tag)
+
(type: Type-Error
(-> Type Text))
-(def: (not-variant type)
- Type-Error
- (format "Invalid type for variant: " (%type type)))
-
(def: (not-quantified type)
Type-Error
(format "Not a quantified type: " (%type type)))
@@ -37,12 +38,14 @@
(def: #export (analyse-sum analyse tag valueC)
(-> &;Analyser Nat Code (Meta la;Analysis))
(do meta;Monad<Meta>
- [expected meta;expected-type]
+ [expectedT meta;expected-type]
(&;with-stacked-errors
- (function [_] (not-variant expected))
- (case expected
+ (function [_] (Not-Variant-Type (format " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC) "\n"
+ " Type: " (%type expectedT))))
+ (case expectedT
(#;Sum _)
- (let [flat (type;flatten-variant expected)
+ (let [flat (type;flatten-variant expectedT)
type-size (list;size flat)]
(case (list;nth tag flat)
(#;Some variant-type)
@@ -53,7 +56,7 @@
(wrap (la;sum tag type-size temp valueA)))
#;None
- (&common;variant-out-of-bounds-error expected type-size tag)))
+ (&common;variant-out-of-bounds-error expectedT type-size tag)))
(#;Named name unnamedT)
(&;with-expected-type unnamedT
@@ -65,26 +68,28 @@
(tc;bound? id))]
(if bound?
(do @
- [expected' (&;with-type-env
- (tc;read id))]
- (&;with-expected-type expected'
+ [expectedT' (&;with-type-env
+ (tc;read id))]
+ (&;with-expected-type expectedT'
(analyse-sum analyse tag valueC)))
## Cannot do inference when the tag is numeric.
## This is because there is no way of knowing how many
## cases the inferred sum type would have.
- (&;fail (not-variant expected))))
+ (&;throw Cannot-Infer-Numeric-Tag (format " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC) "\n"
+ " Type: " (%type expectedT)))))
(#;UnivQ _)
(do @
[[var-id var] (&;with-type-env
tc;existential)]
- (&;with-expected-type (maybe;assume (type;apply (list var) expected))
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
(analyse-sum analyse tag valueC)))
(#;ExQ _)
(&common;with-var
(function [[var-id var]]
- (&;with-expected-type (maybe;assume (type;apply (list var) expected))
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
(analyse-sum analyse tag valueC))))
(#;Apply inputT funT)
@@ -97,15 +102,17 @@
(analyse-sum analyse tag valueC)))
_
- (&;fail "")))))
+ (&;throw Not-Variant-Type (format " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC) "\n"
+ " Type: " (%type expectedT)))))))
(def: (analyse-typed-product analyse members)
(-> &;Analyser (List Code) (Meta la;Analysis))
(do meta;Monad<Meta>
- [expected meta;expected-type]
- (loop [expected expected
+ [expectedT meta;expected-type]
+ (loop [expectedT expectedT
members members]
- (case [expected members]
+ (case [expectedT members]
## If the type and the code are still ongoing, match each
## sub-expression to its corresponding type.
[(#;Product leftT rightT) (#;Cons leftC rightC)]
@@ -150,10 +157,11 @@
(def: #export (analyse-product analyse membersC)
(-> &;Analyser (List Code) (Meta la;Analysis))
(do meta;Monad<Meta>
- [expected meta;expected-type]
+ [expectedT meta;expected-type]
(&;with-stacked-errors
- (function [_] (format "Invalid type for tuple: " (%type expected)))
- (case expected
+ (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
+ "Value: " (%code (` [(~@ membersC)])))))
+ (case expectedT
(#;Product _)
(analyse-typed-product analyse membersC)
@@ -167,16 +175,16 @@
(tc;bound? id))]
(if bound?
(do @
- [expected' (&;with-type-env
- (tc;read id))]
- (&;with-expected-type expected'
+ [expectedT' (&;with-type-env
+ (tc;read id))]
+ (&;with-expected-type expectedT'
(analyse-product analyse membersC)))
## Must do inference...
(do @
[membersTA (monad;map @ (|>. analyse &common;with-unknown-type)
membersC)
_ (&;with-type-env
- (tc;check expected
+ (tc;check expectedT
(type;tuple (list/map product;left membersTA))))]
(wrap (la;product (list/map product;right membersTA))))))
@@ -184,13 +192,13 @@
(do @
[[var-id var] (&;with-type-env
tc;existential)]
- (&;with-expected-type (maybe;assume (type;apply (list var) expected))
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
(analyse-product analyse membersC)))
(#;ExQ _)
(&common;with-var
(function [[var-id var]]
- (&;with-expected-type (maybe;assume (type;apply (list var) expected))
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
(analyse-product analyse membersC))))
(#;Apply inputT funT)
@@ -203,7 +211,8 @@
(analyse-product analyse membersC)))
_
- (&;fail "")
+ (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
+ "Value: " (%code (` [(~@ membersC)]))))
))))
(def: #export (analyse-tagged-sum analyse tag valueC)
@@ -216,7 +225,7 @@
(#;Var _)
(do @
[#let [case-size (list;size group)]
- inferenceT (&inference;variant-inference-type idx case-size variantT)
+ inferenceT (&inference;variant idx case-size variantT)
[inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC))
_ (&;with-type-env
(tc;check expectedT inferredT))
@@ -295,7 +304,7 @@
[members (normalize members)
[members recordT] (order members)
expectedT meta;expected-type
- inferenceT (&inference;record-inference-type recordT)
+ inferenceT (&inference;record recordT)
[inferredT membersA] (&inference;apply-function analyse inferenceT members)
_ (&;with-type-env
(tc;check expectedT inferredT))]
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux
index bac16fd79..580f5593f 100644
--- a/new-luxc/source/luxc/base.lux
+++ b/new-luxc/source/luxc/base.lux
@@ -27,8 +27,8 @@
#let [location (format file
"," (|> line nat-to-int %i)
"," (|> col nat-to-int %i))]]
- (meta;fail (format "@ " location
- "\n" message))))
+ (meta;fail (format message "\n\n"
+ "@ " location))))
(def: #export (assert message test)
(-> Text Bool (Meta Unit))
@@ -57,7 +57,7 @@
(function [compiler]
(case (action (get@ #;type-context compiler))
(#e;Error error)
- (#e;Error error)
+ ((fail error) compiler)
(#e;Success [context' output])
(#e;Success [(set@ #;type-context context' compiler)
@@ -136,7 +136,7 @@
(#e;Error error)
(#e;Error (if (text/= "" error)
(handler [])
- (format error "\n-----------------------------------------\n" (handler [])))))))
+ (format (handler []) "\n\n-----------------------------------------\n\n" error))))))
(def: fresh-bindings
(All [k v] (Bindings k v))
diff --git a/new-luxc/source/luxc/generator.lux b/new-luxc/source/luxc/generator.lux
index 4ac937402..ad5f578e3 100644
--- a/new-luxc/source/luxc/generator.lux
+++ b/new-luxc/source/luxc/generator.lux
@@ -11,10 +11,10 @@
[io]
(world [file #+ File]))
(luxc ["&" base]
+ [";L" host]
["&;" io]
["&;" module]
["&;" parser]
- ["&;" host]
["&;" analyser]
["&;" analyser/common]
["&;" synthesizer]
@@ -75,24 +75,12 @@
[result action]
(exhaust action)))
-(def: (ensure-new-module! file-hash module-name)
- (-> Nat Text (Meta Unit))
- (do meta;Monad<Meta>
- [module-exists? (meta;module-exists? module-name)
- _ (: (Meta Unit)
- (if module-exists?
- (&;fail (format "Cannot re-define a module: " module-name))
- (wrap [])))
- _ (&module;create file-hash module-name)]
- (wrap [])))
-
(def: prelude Text "lux")
(def: (with-active-compilation [module-name file-name source-code] action)
(All [a] (-> [Text Text Text] (Meta a) (Meta a)))
(do meta;Monad<Meta>
- [_ (ensure-new-module! (text/hash source-code) module-name)
- #let [init-cursor [file-name +0 +0]]
+ [#let [init-cursor [file-name +1 +0]]
output (&;with-source-code [init-cursor +0 source-code]
action)
_ (&module;flag-compiled! module-name)]
@@ -113,17 +101,21 @@
(-> (List File) Text File Compiler (T;Task Compiler))
(do T;Monad<Task>
[_ (&io;prepare-module target-dir module-name)
- [file-name file-content] (&io;read-module source-dirs module-name)]
+ [file-name file-content] (&io;read-module source-dirs module-name)
+ #let [module-hash (text/hash file-content)]]
(case (meta;run' compiler
(do meta;Monad<Meta>
- [[artifacts _] (&&common;with-artifacts
- (with-active-compilation [module-name
- file-name
- file-content]
- (exhaust
- (do @
- [code parse]
- (generate code)))))]
+ [[_ artifacts _] (&module;with-module module-hash module-name
+ (&&common;with-artifacts
+ (with-active-compilation [module-name
+ file-name
+ file-content]
+ (exhaust
+ (do @
+ [code parse
+ #let [[cursor _] code]]
+ (&;with-cursor cursor
+ (generate code)))))))]
(wrap artifacts)
## (&module;generate-descriptor module-name)
))
@@ -139,7 +131,7 @@
(#e;Error error)
(T;fail error))))
-(def: init-cursor Cursor ["" +0 +0])
+(def: init-cursor Cursor ["" +1 +0])
(def: #export init-type-context
Type-Context
@@ -170,15 +162,15 @@
(def: #export (generate-program program target sources)
(-> Text File (List File) (T;Task Unit))
(do T;Monad<Task>
- [compiler (|> (case (&&runtime;generate (init-compiler (io;run &host;init-host)))
+ [compiler (|> (case (&&runtime;generate (init-compiler (io;run hostL;init-host)))
(#e;Error error)
(T;fail error)
(#e;Success [compiler [runtime-bc function-bc]])
(do @
[_ (&io;prepare-target target)
- _ (&io;write-file target &&runtime;runtime-class runtime-bc)
- _ (&io;write-file target &&runtime;function-class function-bc)]
+ _ (&io;write-file target hostL;runtime-class runtime-bc)
+ _ (&io;write-file target hostL;function-class function-bc)]
(wrap compiler)))
(: (T;Task Compiler))
(:: @ map (generate-module sources prelude target)) (:: @ join)
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux
index 53912f5d0..f20c83f6e 100644
--- a/new-luxc/source/luxc/generator/case.jvm.lux
+++ b/new-luxc/source/luxc/generator/case.jvm.lux
@@ -2,9 +2,9 @@
lux
(lux (control [monad #+ do])
[meta "meta/" Monad<Meta>])
- (luxc (lang ["ls" synthesis])
- (generator [expr]
- (host ["$" jvm]
+ (luxc [";L" host]
+ (lang ["ls" synthesis])
+ (generator (host ["$" jvm]
(jvm ["$t" type]
["$i" inst]))))
[../runtime])
@@ -24,7 +24,7 @@
(def: peekI
$;Inst
(|>. $i;DUP
- ($i;INVOKESTATIC ../runtime;runtime-class
+ ($i;INVOKESTATIC hostL;runtime-class
"pm_peek"
($t;method (list ../runtime;$Stack)
(#;Some $Object)
@@ -33,7 +33,7 @@
(def: popI
$;Inst
- (|>. ($i;INVOKESTATIC ../runtime;runtime-class
+ (|>. ($i;INVOKESTATIC hostL;runtime-class
"pm_pop"
($t;method (list ../runtime;$Stack)
(#;Some ../runtime;$Stack)
@@ -42,19 +42,20 @@
(def: pushI
$;Inst
- (|>. ($i;INVOKESTATIC ../runtime;runtime-class
+ (|>. ($i;INVOKESTATIC hostL;runtime-class
"pm_push"
($t;method (list ../runtime;$Stack $Object)
(#;Some ../runtime;$Stack)
(list))
false)))
-(def: (generate-pattern' stack-depth @else @end path)
- (-> Nat $;Label $;Label ls;Path (Meta $;Inst))
+(def: (generate-pattern' generate stack-depth @else @end path)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ Nat $;Label $;Label ls;Path (Meta $;Inst))
(case path
(#ls;ExecP bodyS)
(do meta;Monad<Meta>
- [bodyI (expr;generate bodyS)]
+ [bodyI (generate bodyS)]
(wrap (|>. (pop-altI stack-depth)
bodyI
($i;GOTO @end))))
@@ -104,7 +105,7 @@
(#ls;TupleP idx subP)
(do meta;Monad<Meta>
- [subI (generate-pattern' stack-depth @else @end subP)
+ [subI (generate-pattern' generate stack-depth @else @end subP)
#let [[idx tail?] (case idx
(#;Left idx)
[idx false]
@@ -124,7 +125,7 @@
(|>. peekI
($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
($i;int (nat-to-int idx))
- ($i;INVOKESTATIC ../runtime;runtime-class
+ ($i;INVOKESTATIC hostL;runtime-class
(if tail? "pm_right" "pm_left")
($t;method (list ../runtime;$Tuple $t;int)
(#;Some $Object)
@@ -135,7 +136,7 @@
(#ls;VariantP idx subP)
(do meta;Monad<Meta>
- [subI (generate-pattern' stack-depth @else @end subP)
+ [subI (generate-pattern' generate stack-depth @else @end subP)
#let [[idx last?] (case idx
(#;Left idx)
[idx false]
@@ -151,7 +152,7 @@
($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
($i;int (nat-to-int idx))
flagI
- ($i;INVOKESTATIC ../runtime;runtime-class "pm_variant"
+ ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
(#;Some ../runtime;$Datum)
(list))
@@ -168,16 +169,16 @@
(#ls;SeqP leftP rightP)
(do meta;Monad<Meta>
- [leftI (generate-pattern' stack-depth @else @end leftP)
- rightI (generate-pattern' stack-depth @else @end rightP)]
+ [leftI (generate-pattern' generate stack-depth @else @end leftP)
+ rightI (generate-pattern' generate stack-depth @else @end rightP)]
(wrap (|>. leftI
rightI)))
(#ls;AltP leftP rightP)
(do meta;Monad<Meta>
[@alt-else $i;make-label
- leftI (generate-pattern' (n.inc stack-depth) @alt-else @end leftP)
- rightI (generate-pattern' stack-depth @else @end rightP)]
+ leftI (generate-pattern' generate (n.inc stack-depth) @alt-else @end leftP)
+ rightI (generate-pattern' generate stack-depth @else @end rightP)]
(wrap (|>. $i;DUP
leftI
($i;label @alt-else)
@@ -185,30 +186,42 @@
rightI)))
))
-(def: (generate-pattern path @end)
- (-> ls;Path $;Label (Meta $;Inst))
+(def: (generate-pattern generate path @end)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ ls;Path $;Label (Meta $;Inst))
(do meta;Monad<Meta>
[@else $i;make-label
- pathI (generate-pattern' +1 @else @end path)]
+ pathI (generate-pattern' generate +1 @else @end path)]
(wrap (|>. pathI
($i;label @else)
$i;POP
- ($i;INVOKESTATIC ../runtime;runtime-class
+ ($i;INVOKESTATIC hostL;runtime-class
"pm_fail"
($t;method (list) #;None (list))
false)
$i;NULL
($i;GOTO @end)))))
-(def: #export (generate valueS path)
- (-> ls;Synthesis ls;Path (Meta $;Inst))
+(def: #export (generate-case generate valueS path)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ ls;Synthesis ls;Path (Meta $;Inst))
(do meta;Monad<Meta>
[@end $i;make-label
- valueI (expr;generate valueS)
- pathI (generate-pattern path @end)]
+ valueI (generate valueS)
+ pathI (generate-pattern generate path @end)]
(wrap (|>. valueI
$i;NULL
$i;SWAP
pushI
pathI
($i;label @end)))))
+
+(def: #export (generate-let generate register inputS exprS)
+ (-> (-> ls;Synthesis (Meta $;Inst))
+ Nat ls;Synthesis ls;Synthesis (Meta $;Inst))
+ (do meta;Monad<Meta>
+ [inputI (generate inputS)
+ exprI (generate exprS)]
+ (wrap (|>. inputI
+ ($i;ASTORE register)
+ exprI))))
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index 116c29fb5..685bf2335 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -1,6 +1,7 @@
(;module:
lux
- (lux (control monad)
+ (lux (control monad
+ ["ex" exception #+ exception:])
(data text/format)
[meta #+ Monad<Meta> "Meta/" Monad<Meta>])
(luxc ["&" base]
@@ -15,8 +16,11 @@
["&;" procedure]
["&;" function]
["&;" reference]
+ [";G" case]
(host ["$" jvm]))))
+(exception: #export Unrecognized-Synthesis)
+
(def: #export (generate synthesis)
(-> ls;Synthesis (Meta $;Inst))
(case synthesis
@@ -47,6 +51,12 @@
(#ls;Definition definition)
(&reference;generate-definition definition)
+ (#ls;Let register inputS exprS)
+ (caseG;generate-let generate register inputS exprS)
+
+ (#ls;Case inputS pathPS)
+ (caseG;generate-case generate inputS pathPS)
+
(#ls;Function arity env body)
(&function;generate-function generate env arity body)
@@ -57,25 +67,5 @@
(&procedure;generate-procedure generate name args)
_
- (meta;fail "Unrecognized synthesis.")
+ (&;throw Unrecognized-Synthesis "")
))
-
-## (def: #export (eval type code)
-## (-> Type Code (Meta Top))
-## (do Monad<Meta>
-## [analysis (&;with-expected-type leftT
-## (&analyser;analyser eval code))
-## #let [synthesis (&synthesizer;synthesize analysis)]
-## inst (generate synthesis)]
-## (&eval;eval inst)))
-
-## (def: analyse
-## &;Analyser
-## (&analyser;analyser eval))
-
-## (def: #export (generate input)
-## (-> Code (Meta Unit))
-## (do Monad<Meta>
-## [analysis (analyse input)
-## #let [synthesis (&synthesizer;synthesize analysis)]]
-## (generate-synthesis synthesis)))
diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux
index 97d3a7c91..ce92b9010 100644
--- a/new-luxc/source/luxc/generator/function.jvm.lux
+++ b/new-luxc/source/luxc/generator/function.jvm.lux
@@ -5,6 +5,7 @@
(coll [list "list/" Functor<List> Monoid<List>]))
[meta])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -58,7 +59,7 @@
(def: get-amount-of-partialsI
$;Inst
(|>. ($i;ALOAD +0)
- ($i;GETFIELD &runtime;function-class &runtime;partials-field $t;int)))
+ ($i;GETFIELD hostL;function-class &runtime;partials-field $t;int)))
(def: (load-fieldI class field)
(-> Text Text $;Inst)
@@ -77,9 +78,9 @@
later-applysI (if (n.> &runtime;num-apply-variants amount)
(applysI (n.+ &runtime;num-apply-variants start) (n.- &runtime;num-apply-variants amount))
id)]
- (|>. ($i;CHECKCAST &runtime;function-class)
+ (|>. ($i;CHECKCAST hostL;function-class)
(inputsI start max-args)
- ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature max-args) false)
+ ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature max-args) false)
later-applysI)))
(def: (inc-intI by)
@@ -167,9 +168,9 @@
(-> ls;Arity Nat $;Inst)
(if (n.= +1 arity)
(|>. ($i;int 0)
- ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false))
+ ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false))
(|>. ($i;ILOAD (n.inc env-size))
- ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false))))
+ ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false))))
(def: (with-init class env arity)
(-> Text (List ls;Variable) ls;Arity $;Def)
@@ -262,7 +263,7 @@
($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int)
@default @labels)
casesI
- ($i;INVOKESTATIC &runtime;runtime-class "apply_fail" ($t;method (list) #;None (list)) false)
+ ($i;INVOKESTATIC hostL;runtime-class "apply_fail" ($t;method (list) #;None (list)) false)
$i;NULL
$i;ARETURN
))))
@@ -306,7 +307,7 @@
_ (&common;store-class function-class
($d;class #$;V1.6 #$;Public $;finalC
function-class (list)
- ($;simple-class &runtime;function-class) (list)
+ ($;simple-class hostL;function-class) (list)
functionD))]
(wrap instanceI)))
@@ -326,9 +327,9 @@
argsI (monad;map @ generate argsS)
#let [applyI (|> (segment &runtime;num-apply-variants argsI)
(list/map (function [chunkI+]
- (|>. ($i;CHECKCAST &runtime;function-class)
+ (|>. ($i;CHECKCAST hostL;function-class)
($i;fuse chunkI+)
- ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false))))
+ ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false))))
$i;fuse)]]
(wrap (|>. functionI
applyI))))
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index f515e86ac..37ab75020 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -22,68 +22,72 @@
(L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int)))))
wrap))
-(with-expansions [<conversion> (declare D2F D2I D2L
- F2D F2I F2L
- I2B I2C I2D I2F I2L I2S
- L2D L2F L2I)
- <primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
- T_BYTE T_SHORT T_INT T_LONG)
- <class> (declare CHECKCAST NEW INSTANCEOF)
- <member> (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD
- INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE)
- <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2
- POP POP2
- SWAP)
- <jump> (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL
- IFEQ IFNE IFLT IFLE IFGT IFGE
- GOTO)
- <var> (declare ILOAD LLOAD DLOAD ALOAD
- ISTORE LSTORE ASTORE)
- <arithmetic> (declare IADD ISUB IMUL IDIV IREM
- LADD LSUB LMUL LDIV LREM LCMP
- FADD FSUB FMUL FDIV FREM FCMPG FCMPL
- DADD DSUB DMUL DDIV DREM DCMPG DCMPL)
- <bit-wise> (declare IAND IOR IXOR ISHL ISHR IUSHR
- LAND LOR LXOR LSHL LSHR LUSHR)
- <array> (declare ARRAYLENGTH NEWARRAY ANEWARRAY
- AALOAD AASTORE
- BALOAD BASTORE
- SALOAD SASTORE
- IALOAD IASTORE
- LALOAD LASTORE
- FALOAD FASTORE
- DALOAD DASTORE
- CALOAD CASTORE)
- <concurrency> (declare MONITORENTER MONITOREXIT)
- <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)]
- (host;import org.objectweb.asm.Opcodes
- (#static NOP int)
-
- <conversion>
- <primitive>
-
- <class>
-
- <stack>
- <jump>
-
- (#static ACONST_NULL int)
-
- <var>
-
- <arithmetic>
- <bit-wise>
-
- <array>
-
- <member>
-
- (#static ATHROW int)
-
- <concurrency>
-
- <return>
- ))
+(`` (host;import org.objectweb.asm.Opcodes
+ (#static NOP int)
+
+ ## Conversion
+ (~~ (declare D2F D2I D2L
+ F2D F2I F2L
+ I2B I2C I2D I2F I2L I2S
+ L2D L2F L2I))
+
+ ## Primitive
+ (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
+ T_BYTE T_SHORT T_INT T_LONG))
+
+ ## Class
+ (~~ (declare CHECKCAST NEW INSTANCEOF))
+
+ ## Stack
+ (~~ (declare DUP DUP_X1 DUP_X2
+ DUP2 DUP2_X1 DUP2_X2
+ POP POP2
+ SWAP))
+
+ ## Jump
+ (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL
+ IFEQ IFNE IFLT IFLE IFGT IFGE
+ GOTO))
+
+ (#static ACONST_NULL int)
+
+ ## Var
+ (~~ (declare ILOAD LLOAD DLOAD ALOAD
+ ISTORE LSTORE ASTORE))
+
+ ## Arithmetic
+ (~~ (declare IADD ISUB IMUL IDIV IREM
+ LADD LSUB LMUL LDIV LREM LCMP
+ FADD FSUB FMUL FDIV FREM FCMPG FCMPL
+ DADD DSUB DMUL DDIV DREM DCMPG DCMPL))
+
+ ## Bit-wise
+ (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR
+ LAND LOR LXOR LSHL LSHR LUSHR))
+
+ ## Array
+ (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY
+ AALOAD AASTORE
+ BALOAD BASTORE
+ SALOAD SASTORE
+ IALOAD IASTORE
+ LALOAD LASTORE
+ FALOAD FASTORE
+ DALOAD DASTORE
+ CALOAD CASTORE))
+
+ ## Member
+ (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD
+ INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE))
+
+ (#static ATHROW int)
+
+ ## Concurrency
+ (~~ (declare MONITORENTER MONITOREXIT))
+
+ ## Return
+ (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN))
+ ))
(host;import org.objectweb.asm.FieldVisitor
(visitEnd [] void))
@@ -152,7 +156,9 @@
[NOP]
## Stack
- [DUP] [DUP2] [DUP2_X1] [DUP2_X2] [POP] [POP2] [SWAP]
+ [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2]
+ [POP] [POP2]
+ [SWAP]
## Conversions
[D2F] [D2I] [D2L]
diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux
index fc6ffae1f..571ba4835 100644
--- a/new-luxc/source/luxc/generator/primitive.jvm.lux
+++ b/new-luxc/source/luxc/generator/primitive.jvm.lux
@@ -2,8 +2,9 @@
lux
(lux (control monad)
(data text/format)
- [meta #+ Monad<Meta> "Meta/" Monad<Meta>])
+ [meta "meta/" Monad<Meta>])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -16,18 +17,18 @@
(def: #export generate-unit
(Meta $;Inst)
- (Meta/wrap ($i;string ../runtime;unit)))
+ (meta/wrap ($i;string hostL;unit)))
(def: #export (generate-bool value)
(-> Bool (Meta $;Inst))
- (Meta/wrap ($i;GETSTATIC "java.lang.Boolean"
+ (meta/wrap ($i;GETSTATIC "java.lang.Boolean"
(if value "TRUE" "FALSE")
($t;class "java.lang.Boolean" (list)))))
(do-template [<name> <type> <load> <wrap>]
[(def: #export (<name> value)
(-> <type> (Meta $;Inst))
- (Meta/wrap (|>. (<load> value) <wrap>)))]
+ (meta/wrap (|>. (<load> value) <wrap>)))]
[generate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)]
[generate-int Int $i;long ($i;wrap #$;Long)]
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index 48a820663..fd76082a6 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -10,6 +10,7 @@
["s" syntax #+ syntax:])
[host])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -56,7 +57,7 @@
(def: $Object-Array $;Type ($t;array +1 $Object))
(def: $String $;Type ($t;class "java.lang.String" (list)))
(def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list)))
-(def: $Function $;Type ($t;class &runtime;function-class (list)))
+(def: $Function $;Type ($t;class hostL;function-class (list)))
(def: #export (install name unnamed)
(-> Text (-> Text Proc)
@@ -142,8 +143,8 @@
(def: (lux//try riskyI)
Unary
(|>. riskyI
- ($i;CHECKCAST &runtime;function-class)
- ($i;INVOKESTATIC &runtime;runtime-class "try" try-method false)))
+ ($i;CHECKCAST hostL;function-class)
+ ($i;INVOKESTATIC hostL;runtime-class "try" try-method false)))
## [[Bits]]
(do-template [<name> <op>]
@@ -263,9 +264,9 @@
[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 &runtime;runtime-class "div_nat" nat-method false)]
+ ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)]
[nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-class "rem_nat" nat-method false)]
+ ($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]
@@ -276,9 +277,9 @@
[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 &runtime;runtime-class "mul_deg" deg-method false)]
+ ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)]
[deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC &runtime;runtime-class "div_deg" deg-method false)]
+ ($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]
@@ -296,10 +297,10 @@
[<eq> 0]
[<lt> -1])]
- [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)]
+ [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)]
[int//eq int//lt ($i;unwrap #$;Long) $i;LCMP]
[frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG]
- [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)]
+ [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)]
)
(do-template [<name> <prepare> <transform>]
@@ -317,15 +318,15 @@
[frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)]
[frac//to-deg ($i;unwrap #$;Double)
- (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "frac_to_deg"
+ (<| ($i;wrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "frac_to_deg"
($t;method (list $t;double) (#;Some $t;long) (list)) false))]
[frac//encode ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)]
[frac//decode ($i;CHECKCAST "java.lang.String")
- ($i;INVOKESTATIC &runtime;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
+ ($i;INVOKESTATIC hostL;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
[deg//to-frac ($i;unwrap #$;Long)
- (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-class "deg_to_frac"
+ (<| ($i;wrap #$;Double) ($i;INVOKESTATIC hostL;runtime-class "deg_to_frac"
($t;method (list $t;long) (#;Some $t;double) (list)) false))]
)
@@ -365,7 +366,7 @@
($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false)
($i;wrap #$;Boolean)]
[text//char ($i;CHECKCAST "java.lang.String") jvm-intI
- ($i;INVOKESTATIC &runtime;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
+ ($i;INVOKESTATIC hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
lux-intI]
)
@@ -378,7 +379,7 @@
<op>))]
[text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI
- ($i;INVOKESTATIC &runtime;runtime-class "text_clip"
+ ($i;INVOKESTATIC hostL;runtime-class "text_clip"
($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)]
[text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)]
@@ -466,7 +467,7 @@
messageI
($i;CHECKCAST "java.lang.String")
($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false)
- ($i;string &runtime;unit)))
+ ($i;string hostL;unit)))
(def: (io//error messageI)
Unary
@@ -515,20 +516,20 @@
## [[Processes]]
(def: (process//concurrency-level [])
Nullary
- (|>. ($i;GETSTATIC &runtime;runtime-class "concurrency_level" $t;int)
+ (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int)
lux-intI))
(def: (process//future procedureI)
Unary
- (|>. procedureI ($i;CHECKCAST &runtime;function-class)
- ($i;INVOKESTATIC &runtime;runtime-class "future"
+ (|>. procedureI ($i;CHECKCAST hostL;function-class)
+ ($i;INVOKESTATIC hostL;runtime-class "future"
($t;method (list $Function) (#;Some $Object) (list)) false)))
(def: (process//schedule [millisecondsI procedureI])
Binary
(|>. millisecondsI ($i;unwrap #$;Long)
- procedureI ($i;CHECKCAST &runtime;function-class)
- ($i;INVOKESTATIC &runtime;runtime-class "schedule"
+ procedureI ($i;CHECKCAST hostL;function-class)
+ ($i;INVOKESTATIC hostL;runtime-class "schedule"
($t;method (list $t;long $Function) (#;Some $Object) (list)) false)))
## [Bundles]
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index f908c6c6e..fc6bdd01b 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -15,6 +15,7 @@
["s" syntax #+ syntax:])
[host])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -494,13 +495,13 @@
(wrap (|>. valueI
($i;unwrap primitive)
($i;PUTSTATIC class field (#$;Primitive primitive))
- ($i;string &runtime;unit))))
+ ($i;string hostL;unit))))
#;None
(wrap (|>. valueI
($i;CHECKCAST class)
($i;PUTSTATIC class field ($t;class class (list)))
- ($i;string &runtime;unit)))))
+ ($i;string hostL;unit)))))
_
(&;fail (format "Wrong syntax for '" proc "'."))))
@@ -655,7 +656,7 @@
(case returnT
#;None
(|>. returnI
- ($i;string &runtime;unit))
+ ($i;string hostL;unit))
(#;Some type)
(case type
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index d2ad42a2c..d3f99ae6a 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -7,6 +7,7 @@
[meta]
[host])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -40,20 +41,16 @@
(visitEnd [] void)
(toByteArray [] (Array byte)))
-(def: #export runtime-class Text "LuxRuntime")
-(def: #export function-class Text "LuxFunction")
-(def: #export unit Text "\u0000")
-
(def: $Object $;Type ($t;class "java.lang.Object" (list)))
(def: $Object-Array $;Type ($t;array +1 $Object))
(def: $String $;Type ($t;class "java.lang.String" (list)))
(def: #export $Stack $;Type ($t;array +1 $Object))
-(def: #export $Tuple $;Type ($t;array +1 $Object))
-(def: #export $Variant $;Type ($t;array +1 $Object))
+(def: #export $Tuple $;Type $Object-Array)
+(def: #export $Variant $;Type $Object-Array)
(def: #export $Tag $;Type $t;int)
(def: #export $Flag $;Type $Object)
(def: #export $Datum $;Type $Object)
-(def: #export $Function $;Type ($t;class function-class (list)))
+(def: #export $Function $;Type ($t;class hostL;function-class (list)))
(def: $Throwable $;Type ($t;class "java.lang.Throwable" (list)))
(def: #export logI
@@ -69,7 +66,7 @@
(def: variantI
$;Inst
- ($i;INVOKESTATIC runtime-class "variant_make" variant-method false))
+ ($i;INVOKESTATIC hostL;runtime-class "variant_make" variant-method false))
(def: #export leftI
$;Inst
@@ -93,9 +90,13 @@
$;Inst
(|>. ($i;int 0)
$i;NULL
- ($i;string unit)
+ ($i;string hostL;unit)
variantI))
+(def: #export string-concatI
+ $;Inst
+ ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false))
+
(def: #export partials-field Text "partials")
(def: #export apply-method Text "apply")
(def: #export num-apply-variants Nat +8)
@@ -108,8 +109,59 @@
$;Def
(let [store-tagI (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE)
store-flagI (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE)
- store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)]
- (|>. ($d;method #$;Public $;staticM "variant_make"
+ store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)
+ force-textMT ($t;method (list $Object) (#;Some $String) (list))]
+ (|>. ($d;method #$;Public $;staticM "force_text" force-textMT
+ (<| $i;with-label (function [@is-null])
+ $i;with-label (function [@normal-object])
+ $i;with-label (function [@array-loop])
+ $i;with-label (function [@within-bounds])
+ $i;with-label (function [@is-first])
+ $i;with-label (function [@elem-end])
+ $i;with-label (function [@fold-end])
+ (let [on-normal-objectI (|>. ($i;ALOAD +0)
+ ($i;INVOKEVIRTUAL "java.lang.Object" "toString" ($t;method (list) (#;Some $String) (list)) false))
+ on-null-objectI ($i;string "NULL")
+ arrayI (|>. ($i;ALOAD +0)
+ ($i;CHECKCAST ($t;descriptor $Object-Array)))
+ recurseI ($i;INVOKESTATIC hostL;runtime-class "force_text" force-textMT false)
+ force-elemI (|>. $i;DUP arrayI $i;SWAP $i;AALOAD recurseI)
+ swap2 (|>. $i;DUP2_X2 ## X,Y => Y,X,Y
+ $i;POP2 ## Y,X,Y => Y,X
+ )
+ add-spacingI (|>. ($i;string ", ") $i;SWAP string-concatI)
+ merge-with-totalI (|>. $i;DUP_X2 $i;POP ## TSIP => TPSI
+ swap2 ## TPSI => SITP
+ string-concatI ## SITP => SIT
+ $i;DUP_X2 $i;POP ## SIT => TSI
+ )
+ foldI (|>. $i;DUP ## TSI => TSII
+ ($i;IFEQ @is-first) ## TSI
+ force-elemI add-spacingI merge-with-totalI ($i;GOTO @elem-end)
+ ($i;label @is-first) ## TSI
+ force-elemI merge-with-totalI
+ ($i;label @elem-end) ## TSI
+ )
+ inc-idxI (|>. ($i;int 1) $i;IADD)
+ on-array-objectI (|>. ($i;string "[") ## T
+ arrayI $i;ARRAYLENGTH ## TS
+ ($i;int 0) ## TSI
+ ($i;label @array-loop) ## TSI
+ $i;DUP2
+ ($i;IF_ICMPGT @within-bounds) ## TSI
+ $i;POP2 ($i;string "]") string-concatI ($i;GOTO @fold-end)
+ ($i;label @within-bounds)
+ foldI inc-idxI ($i;GOTO @array-loop)
+ ($i;label @fold-end))])
+ (|>. ($i;ALOAD +0)
+ ($i;IFNULL @is-null)
+ ($i;ALOAD +0)
+ ($i;INSTANCEOF ($t;descriptor $Object-Array))
+ ($i;IFEQ @normal-object)
+ on-array-objectI $i;ARETURN
+ ($i;label @normal-object) on-normal-objectI $i;ARETURN
+ ($i;label @is-null) on-null-objectI $i;ARETURN)))
+ ($d;method #$;Public $;staticM "variant_make"
($t;method (list $t;int $Object $Object)
(#;Some $Variant)
(list))
@@ -120,14 +172,18 @@
store-valueI
$i;ARETURN)))))
+(def: #export force-textI
+ $;Inst
+ ($i;INVOKESTATIC hostL;runtime-class "force_text" ($t;method (list $Object) (#;Some $String) (list)) false))
+
(def: nat-methods
$;Def
(let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list))
- less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-class "compare_nat" compare-nat-method false) ($i;IFLT @where)))
+ less-thanI (function [@where] (|>. ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false) ($i;IFLT @where)))
$BigInteger ($t;class "java.math.BigInteger" (list))
upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list))
div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))
- upcastI ($i;INVOKESTATIC runtime-class "_toUnsignedBigInteger" upcast-method false)
+ 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
@@ -300,7 +356,7 @@
(let [subjectI ($i;LLOAD +0)
paramI ($i;LLOAD +2)
equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where)))
- count-leading-zerosI ($i;INVOKESTATIC runtime-class "count_leading_zeros" clz-method false)
+ count-leading-zerosI ($i;INVOKESTATIC hostL;runtime-class "count_leading_zeros" clz-method false)
calc-max-shiftI (|>. subjectI count-leading-zerosI
paramI count-leading-zerosI
($i;INVOKESTATIC "java.lang.Math" "min" ($t;method (list $t;int $t;int) (#;Some $t;int) (list)) false)
@@ -373,7 +429,7 @@
($i;int 1)
$i;AALOAD
$i;ARETURN))
- ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Stack $t;int $Object) (#;Some $Object) (list))
+ ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Variant $Tag $Flag) (#;Some $Object) (list))
(<| $i;with-label (function [@begin])
$i;with-label (function [@just-return])
$i;with-label (function [@then])
@@ -487,7 +543,7 @@
($i;label @from)
($i;ALOAD +0)
$i;NULL
- ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+ ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false)
rightI
$i;ARETURN
($i;label @to)
@@ -505,14 +561,14 @@
(Meta &common;Bytecode)
(do meta;Monad<Meta>
[_ (wrap [])
- #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list)
+ #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC hostL;runtime-class (list) ["java.lang.Object" (list)] (list)
(|>. adt-methods
nat-methods
frac-methods
deg-methods
pm-methods
io-methods))]
- _ (&common;store-class runtime-class bytecode)]
+ _ (&common;store-class hostL;runtime-class bytecode)]
(wrap bytecode)))
(def: generate-function
@@ -526,24 +582,24 @@
(list/map $i;ALOAD)
$i;fuse)]
(|>. preI
- ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false)
- ($i;CHECKCAST function-class)
+ ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature (n.dec arity)) false)
+ ($i;CHECKCAST hostL;function-class)
($i;ALOAD arity)
- ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+ ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false)
$i;ARETURN)))))
(list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1)))
$d;fuse)
- bytecode ($d;abstract #$;V1.6 #$;Public $;noneC function-class (list) ["java.lang.Object" (list)] (list)
+ bytecode ($d;abstract #$;V1.6 #$;Public $;noneC hostL;function-class (list) ["java.lang.Object" (list)] (list)
(|>. ($d;field #$;Public $;finalF partials-field $t;int)
($d;method #$;Public $;noneM "<init>" ($t;method (list $t;int) #;None (list))
(|>. ($i;ALOAD +0)
($i;INVOKESPECIAL "java.lang.Object" "<init>" ($t;method (list) #;None (list)) false)
($i;ALOAD +0)
($i;ILOAD +1)
- ($i;PUTFIELD function-class partials-field $t;int)
+ ($i;PUTFIELD hostL;function-class partials-field $t;int)
$i;RETURN))
applyI))]
- _ (&common;store-class function-class bytecode)]
+ _ (&common;store-class hostL;function-class bytecode)]
(wrap bytecode)))
(def: #export generate
diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux
index cee5800cd..28196b914 100644
--- a/new-luxc/source/luxc/generator/structure.jvm.lux
+++ b/new-luxc/source/luxc/generator/structure.jvm.lux
@@ -3,9 +3,10 @@
(lux (control [monad #+ do])
(data text/format
(coll [list]))
- [meta #+ Monad<Meta> "Meta/" Monad<Meta>]
+ [meta]
[host #+ do-to])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis]
["ls" synthesis])
["&;" analyser]
@@ -21,7 +22,7 @@
(def: #export (generate-tuple generate members)
(-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[#let [size (list;size members)]
_ (&;assert "Cannot generate tuples with less than 2 elements."
(n.>= +2 size))
@@ -47,12 +48,12 @@
(def: #export (generate-variant generate tag tail? member)
(-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[memberI (generate member)]
(wrap (|>. ($i;int (nat-to-int tag))
(flagI tail?)
memberI
- ($i;INVOKESTATIC ../runtime;runtime-class
+ ($i;INVOKESTATIC hostL;runtime-class
"variant_make"
($t;method (list $t;int $Object $Object)
(#;Some ($t;array +1 $Object))
diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux
index f118deed2..b74c9748c 100644
--- a/new-luxc/source/luxc/host.jvm.lux
+++ b/new-luxc/source/luxc/host.jvm.lux
@@ -95,3 +95,7 @@
(get@ #;host)
(:! &&common;Host)
(get@ #&&common;loader))])))
+
+(def: #export runtime-class Text "LuxRuntime")
+(def: #export function-class Text "LuxFunction")
+(def: #export unit Text "\u0000")
diff --git a/new-luxc/source/luxc/module/descriptor/annotation.lux b/new-luxc/source/luxc/module/descriptor/annotation.lux
index 299616e6b..2ed106545 100644
--- a/new-luxc/source/luxc/module/descriptor/annotation.lux
+++ b/new-luxc/source/luxc/module/descriptor/annotation.lux
@@ -11,7 +11,7 @@
["&" ../common]
[luxc ["&;" parser]])
-(def: dummy-cursor Cursor ["" +0 +0])
+(def: dummy-cursor Cursor ["" +1 +0])
(do-template [<name> <code>]
[(def: <name> &;Signal <code>)]
diff --git a/new-luxc/source/luxc/scope.lux b/new-luxc/source/luxc/scope.lux
index bd9a3233f..4ce8a51cb 100644
--- a/new-luxc/source/luxc/scope.lux
+++ b/new-luxc/source/luxc/scope.lux
@@ -60,14 +60,14 @@
(let [[ref-type init-ref] (maybe;default (undefined)
(get-ref name top-outer))
[ref inner'] (list/fold (: (-> Scope [Ref (List Scope)] [Ref (List Scope)])
- (function [scope [ref inner]]
+ (function [scope ref+inner]
[(#;Captured (get@ [#;captured #;counter] scope))
(#;Cons (update@ #;captured
(: (-> Captured Captured)
(|>. (update@ #;counter n.inc)
- (update@ #;mappings (&;pl-put name [ref-type ref]))))
+ (update@ #;mappings (&;pl-put name [ref-type (product;left ref+inner)]))))
scope)
- inner)]))
+ (product;right ref+inner))]))
[init-ref #;Nil]
(list;reverse inner))
scopes (list/compose inner' outer)]
diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux
index 8221b4f8d..02b1bfba5 100644
--- a/new-luxc/source/luxc/synthesizer/case.lux
+++ b/new-luxc/source/luxc/synthesizer/case.lux
@@ -49,17 +49,17 @@
(#ls;VariantP (if last? (#;Right tag) (#;Left tag))
(path memberP)))))
-(def: #export (weave nextP prevP)
+(def: #export (weave leftP rightP)
(-> ls;Path ls;Path ls;Path)
- (with-expansions [<default> (as-is (#ls;AltP prevP nextP))]
- (case [nextP prevP]
+ (with-expansions [<default> (as-is (#ls;AltP leftP rightP))]
+ (case [leftP rightP]
[#ls;UnitP #ls;UnitP]
#ls;UnitP
(^template [<tag> <test>]
- [(<tag> next) (<tag> prev)]
- (if (<test> next prev)
- prevP
+ [(<tag> left) (<tag> right)]
+ (if (<test> left right)
+ leftP
<default>))
([#ls;BindP n.=]
[#ls;BoolP B/=]
@@ -70,22 +70,22 @@
[#ls;TextP T/=])
(^template [<tag> <side>]
- [(<tag> (<side> next-idx) next-then) (<tag> (<side> prev-idx) prev-then)]
- (if (n.= next-idx prev-idx)
- (weave next-then prev-then)
+ [(<tag> (<side> left-idx) left-then) (<tag> (<side> right-idx) right-then)]
+ (if (n.= left-idx right-idx)
+ (weave left-then right-then)
<default>))
([#ls;TupleP #;Left]
[#ls;TupleP #;Right]
[#ls;VariantP #;Left]
[#ls;VariantP #;Right])
- [(#ls;SeqP next-pre next-post) (#ls;SeqP prev-pre prev-post)]
- (case (weave next-pre prev-pre)
+ [(#ls;SeqP left-pre left-post) (#ls;SeqP right-pre right-post)]
+ (case (weave left-pre right-pre)
(#ls;AltP _ _)
<default>
weavedP
- (#ls;SeqP weavedP (weave next-post prev-post)))
+ (#ls;SeqP weavedP (weave left-post right-post)))
_
<default>)))
diff --git a/new-luxc/source/luxc/synthesizer/function.lux b/new-luxc/source/luxc/synthesizer/function.lux
index e8b2a7ec4..4d9970a3f 100644
--- a/new-luxc/source/luxc/synthesizer/function.lux
+++ b/new-luxc/source/luxc/synthesizer/function.lux
@@ -1,6 +1,6 @@
(;module:
lux
- (lux (data (coll [list "L/" Functor<List> Fold<List>])))
+ (lux (data (coll [list "list/" Functor<List>])))
(luxc (lang ["la" analysis]
["ls" synthesis])))
@@ -8,14 +8,14 @@
(-> Scope (List ls;Variable))
(|> scope
(get@ [#;captured #;mappings])
- (L/map (function [[_ _ ref]]
- (case ref
- (#;Local idx)
- (nat-to-int idx)
-
- (#;Captured idx)
- (|> idx n.inc nat-to-int (i.* -1))
- )))))
+ (list/map (function [[_ _ ref]]
+ (case ref
+ (#;Local idx)
+ (nat-to-int idx)
+
+ (#;Captured idx)
+ (|> idx n.inc nat-to-int (i.* -1))
+ )))))
(do-template [<name> <comp>]
[(def: #export (<name> var)
diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux
index 3e94c7521..e660b4158 100644
--- a/new-luxc/source/program.lux
+++ b/new-luxc/source/program.lux
@@ -4,7 +4,8 @@
["p" parser])
(concurrency ["P" promise]
["T" task])
- (data ["e" error])
+ (data ["e" error]
+ text/format)
[io #- run]
[cli #+ program: CLI])
(luxc ["&;" generator]))
@@ -45,9 +46,10 @@
[?output action]
(case ?output
(#e;Error error)
- (error! error)
+ (exec (log! (format "\n"
+ "Compilation failed:" "\n"
+ error "\n"))
+ (_lux_proc ["io" "exit"] [1]))
(#e;Success output)
(wrap output))))
-
-
diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux
index 34846a988..f9e165c03 100644
--- a/new-luxc/test/test/luxc/generator/case.lux
+++ b/new-luxc/test/test/luxc/generator/case.lux
@@ -12,6 +12,7 @@
[analyser]
[synthesizer]
(generator ["@" case]
+ [";G" expr]
["@;" eval]
["@;" runtime]
["@;" common]))
@@ -72,9 +73,10 @@
(test "Can generate pattern-matching."
(|> (do meta;Monad<Meta>
[runtime-bytecode @runtime;generate
- sampleI (@;generate valueS
- (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true)))
- (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false)))))]
+ sampleI (@;generate-case exprG;generate
+ valueS
+ (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true)))
+ (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -85,8 +87,9 @@
(test "Can bind values."
(|> (do meta;Monad<Meta>
[runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Nat to-bind)
- (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))]
+ sampleI (@;generate-case exprG;generate
+ (#ls;Nat to-bind)
+ (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux
index 2e909dd7e..66eacca27 100644
--- a/new-luxc/test/test/luxc/generator/primitive.lux
+++ b/new-luxc/test/test/luxc/generator/primitive.lux
@@ -10,7 +10,8 @@
["r" math/random]
[meta]
test)
- (luxc (lang ["ls" synthesis])
+ (luxc [";L" host]
+ (lang ["ls" synthesis])
[analyser]
[synthesizer]
(generator ["@" expr]
@@ -54,7 +55,7 @@
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
- (is @runtime;unit (:! Text valueG))
+ (is hostL;unit (:! Text valueG))
_
false)))
diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
index 097c2b802..7a047dff9 100644
--- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
@@ -15,7 +15,8 @@
[meta #+ Monad<Meta>]
[host]
test)
- (luxc (lang ["ls" synthesis])
+ (luxc [";L" host]
+ (lang ["ls" synthesis])
[analyser]
[synthesizer]
(generator ["@" expr]
@@ -520,7 +521,7 @@
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success outputG)
- (is @runtime;unit (:! Text outputG))
+ (is hostL;unit (:! Text outputG))
(#e;Error error)
false)))
diff --git a/new-luxc/test/test/luxc/generator/reference.lux b/new-luxc/test/test/luxc/generator/reference.lux
index 0fa32acb3..32f9c1b80 100644
--- a/new-luxc/test/test/luxc/generator/reference.lux
+++ b/new-luxc/test/test/luxc/generator/reference.lux
@@ -12,6 +12,7 @@
(generator [";G" statement]
[";G" eval]
[";G" expr]
+ [";G" case]
[";G" runtime]
(host ["$" jvm]
(jvm ["$i" inst]))))
@@ -54,3 +55,24 @@
(#e;Error error)
false)))
))))
+
+(context: "Variables."
+ (<| (times +100)
+ (do @
+ [register (|> r;nat (:: @ map (n.% +100)))
+ value r;int]
+ ($_ seq
+ (test "Can refer to local variables/registers."
+ (|> (do meta;Monad<Meta>
+ [sampleI (caseG;generate-let exprG;generate
+ register
+ (#ls;Int value)
+ (#ls;Variable (nat-to-int register)))]
+ (evalG;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success outputG)
+ (i.= value (:! Int outputG))
+
+ (#e;Error error)
+ false)))
+ ))))
diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux
index 927ff9ec8..7a14788b7 100644
--- a/new-luxc/test/test/luxc/generator/structure.lux
+++ b/new-luxc/test/test/luxc/generator/structure.lux
@@ -14,7 +14,8 @@
[meta #+ Monad<Meta>]
[host]
test)
- (luxc (lang ["ls" synthesis])
+ (luxc [";L" host]
+ (lang ["ls" synthesis])
[analyser]
[synthesizer]
(generator ["@" expr]
@@ -39,7 +40,7 @@
(-> [ls;Synthesis Top] Bool)
(case prediction
#ls;Unit
- (is @runtime;unit (:! Text sample))
+ (is hostL;unit (:! Text sample))
(^template [<tag> <type> <test>]
(<tag> prediction')
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index cde7c3714..13eb44402 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -27,8 +27,7 @@
["_;G" reference]
(procedure ["_;G" common]
["_;G" host]))
- ))
- )
+ )))
(program: args
(test;run))