aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2015-04-08 20:27:38 -0400
committerEduardo Julian2015-04-08 20:27:38 -0400
commit36ba345de7e20ad1a51f5ab05ce10931dba04771 (patch)
treebc0be40430491f02a59a65b59fb2d0a6e852c575
parent0826f2b9780591b53ff1faa33bf413f05e8bdbc9 (diff)
- Renamed exec to |do.
- :let within |do now uses |let instead of let. - The analyser now does totality analysis and structures the pattern matching, with the compiler only compiling the generated structures. - Local bindings with case' can now be prefixed arbitrarily. (Note: must do the same with functions).
Diffstat (limited to '')
-rw-r--r--source/lux.lux252
-rw-r--r--src/lux/analyser.clj8
-rw-r--r--src/lux/analyser/base.clj10
-rw-r--r--src/lux/analyser/case.clj237
-rw-r--r--src/lux/analyser/def.clj2
-rw-r--r--src/lux/analyser/env.clj3
-rw-r--r--src/lux/analyser/host.clj52
-rw-r--r--src/lux/analyser/lambda.clj6
-rw-r--r--src/lux/analyser/lux.clj309
-rw-r--r--src/lux/base.clj43
-rw-r--r--src/lux/compiler.clj16
-rw-r--r--src/lux/compiler/base.clj6
-rw-r--r--src/lux/compiler/case.clj129
-rw-r--r--src/lux/compiler/host.clj68
-rw-r--r--src/lux/compiler/lambda.clj8
-rw-r--r--src/lux/compiler/lux.clj30
-rw-r--r--src/lux/host.clj10
-rw-r--r--src/lux/lexer.clj42
-rw-r--r--src/lux/optimizer.clj2
-rw-r--r--src/lux/parser.clj14
-rw-r--r--src/lux/reader.clj2
-rw-r--r--src/lux/type.clj172
22 files changed, 791 insertions, 630 deletions
diff --git a/source/lux.lux b/source/lux.lux
index faec7869a..b1ff13c16 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -74,135 +74,135 @@
#Nil])])])])])])])])])])]))])
#NothingT]))))
-## ## (deftype (Maybe a)
-## ## (| #None
-## ## (#Some a)))
-## (def' Maybe
-## (#AllT [#Nil "Maybe" "a"
-## (#VariantT (#Cons [["lux;None" (#TupleT #Nil)]
-## (#Cons [["lux;Some" (#BoundT "a")]
-## #Nil])]))]))
-
-## ## (deftype (Bindings k v)
-## ## (& #counter Int
-## ## #mappings (List (, k v))))
-## (def' Bindings
-## (#AllT [#Nil "Bindings" "k"
-## (#AllT [#Nil "" "v"
-## (#RecordT (#Cons [["lux;counter" Int]
-## (#Cons [["lux;mappings" (#AppT [List
-## (#TupleT (#Cons [(#BoundT "k")
-## (#Cons [(#BoundT "v")
-## #Nil])]))])]
-## #Nil])]))])]))
-
-## ## (deftype (Env k v)
-## ## (& #name Text
-## ## #inner-closures Int
-## ## #locals (Bindings k v)
-## ## #closure (Bindings k v)))
-## (def' Env
-## (#AllT [#Nil "Env" "k"
-## (#AllT [#Nil "" "v"
-## (#RecordT (#Cons [["lux;name" Text]
-## (#Cons [["lux;inner-closures" Int]
-## (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")])
-## (#BoundT "v")])]
-## (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
-## (#BoundT "v")])]
-## #Nil])])])]))])]))
-
-## ## (deftype Cursor
-## ## (, Text Int Int))
-## (def' Cursor
-## (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
-
-## ## (deftype (Meta m v)
-## ## (| (#Meta (, m v))))
-## (def' Meta
-## (#AllT [#Nil "Meta" "m"
-## (#AllT [#Nil "" "v"
-## (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
-## (#Cons [(#BoundT "v")
-## #Nil])]))]
-## #Nil]))])]))
-
-## ## (def' Reader
-## ## (List (Meta Cursor Text)))
-## (def' Reader
-## (#AppT [List
-## (#AppT [(#AppT [Meta Cursor])
-## Text])]))
-
-## ## (deftype CompilerState
-## ## (& #source (Maybe Reader)
-## ## #modules (List Any)
-## ## #module-aliases (List Any)
-## ## #global-env (Maybe (Env Text Any))
-## ## #local-envs (List (Env Text Any))
-## ## #types (Bindings Int Type)
-## ## #writer (^ org.objectweb.asm.ClassWriter)
-## ## #loader (^ java.net.URLClassLoader)
-## ## #eval-ctor Int))
-## (def' CompilerState
-## (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])]
-## (#Cons [["lux;modules" (#AppT [List Any])]
-## (#Cons [["lux;module-aliases" (#AppT [List Any])]
-## (#Cons [["lux;global-env" (#AppT [Maybe (#AppT [(#AppT [Env Text]) Any])])]
-## (#Cons [["lux;local-envs" (#AppT [List (#AppT [(#AppT [Env Text]) Any])])]
-## (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
-## (#Cons [["lux;writer" (#DataT ["org.objectweb.asm.ClassWriter" #Nil])]
-## (#Cons [["lux;loader" (#DataT ["java.lang.ClassLoader" #Nil])]
-## (#Cons [["lux;eval-ctor" Int]
-## #Nil])])])])])])])])])))
+## (deftype (Maybe a)
+## (| #None
+## (#Some a)))
+(def' Maybe
+ (#AllT [#Nil "Maybe" "a"
+ (#VariantT (#Cons [["lux;None" (#TupleT #Nil)]
+ (#Cons [["lux;Some" (#BoundT "a")]
+ #Nil])]))]))
-## ## (deftype #rec Syntax
-## ## (Meta Cursor (| (#Bool Bool)
-## ## (#Int Int)
-## ## (#Real Real)
-## ## (#Char Char)
-## ## (#Text Text)
-## ## (#Form (List Syntax))
-## ## (#Tuple (List Syntax))
-## ## (#Record (List (, Text Syntax))))))
-## (def' Syntax
-## (case' (#AppT [(#BoundT "Syntax") (#BoundT "")])
-## Syntax
-## (case' (#AppT [List Syntax])
-## SyntaxList
-## (#AppT [(#AllT [#Nil "Syntax" ""
-## (#VariantT (#Cons [["lux;Bool" Bool]
-## (#Cons [["lux;Int" Int]
-## (#Cons [["lux;Real" Real]
-## (#Cons [["lux;Char" Char]
-## (#Cons [["lux;Text" Text]
-## (#Cons [["lux;Form" SyntaxList]
-## (#Cons [["lux;Tuple" SyntaxList]
-## (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Text (#Cons [Syntax #Nil])]))])]
-## #Nil])])])])])])])]))])
-## #NothingT]))))
+## (deftype (Bindings k v)
+## (& #counter Int
+## #mappings (List (, k v))))
+(def' Bindings
+ (#AllT [#Nil "Bindings" "k"
+ (#AllT [#Nil "" "v"
+ (#RecordT (#Cons [["lux;counter" Int]
+ (#Cons [["lux;mappings" (#AppT [List
+ (#TupleT (#Cons [(#BoundT "k")
+ (#Cons [(#BoundT "v")
+ #Nil])]))])]
+ #Nil])]))])]))
+
+## (deftype (Env k v)
+## (& #name Text
+## #inner-closures Int
+## #locals (Bindings k v)
+## #closure (Bindings k v)))
+(def' Env
+ (#AllT [#Nil "Env" "k"
+ (#AllT [#Nil "" "v"
+ (#RecordT (#Cons [["lux;name" Text]
+ (#Cons [["lux;inner-closures" Int]
+ (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])]
+ (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])]
+ #Nil])])])]))])]))
+
+## (deftype Cursor
+## (, Text Int Int))
+(def' Cursor
+ (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
+
+## (deftype (Meta m v)
+## (| (#Meta (, m v))))
+(def' Meta
+ (#AllT [#Nil "Meta" "m"
+ (#AllT [#Nil "" "v"
+ (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
+ (#Cons [(#BoundT "v")
+ #Nil])]))]
+ #Nil]))])]))
-## ## (deftype (Either l r)
-## ## (| (#Left l)
-## ## (#Right r)))
-## (def' Either
-## (#AllT [#Nil "Either" "l"
-## (#AllT [#Nil "" "r"
-## (#VariantT (#Cons [["lux;Left" (#BoundT "l")]
-## (#Cons [["lux;Right" (#BoundT "r")]
-## #Nil])]))])]))
+## (def' Reader
+## (List (Meta Cursor Text)))
+(def' Reader
+ (#AppT [List
+ (#AppT [(#AppT [Meta Cursor])
+ Text])]))
+
+## (deftype CompilerState
+## (& #source (Maybe Reader)
+## #modules (List Any)
+## #module-aliases (List Any)
+## #global-env (Maybe (Env Text Any))
+## #local-envs (List (Env Text Any))
+## #types (Bindings Int Type)
+## #writer (^ org.objectweb.asm.ClassWriter)
+## #loader (^ java.net.URLClassLoader)
+## #eval-ctor Int))
+(def' CompilerState
+ (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])]
+ (#Cons [["lux;modules" (#AppT [List Any])]
+ (#Cons [["lux;module-aliases" (#AppT [List Any])]
+ (#Cons [["lux;global-env" (#AppT [Maybe (#AppT [(#AppT [Env Text]) Any])])]
+ (#Cons [["lux;local-envs" (#AppT [List (#AppT [(#AppT [Env Text]) Any])])]
+ (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
+ (#Cons [["lux;writer" (#DataT ["org.objectweb.asm.ClassWriter" #Nil])]
+ (#Cons [["lux;loader" (#DataT ["java.lang.ClassLoader" #Nil])]
+ (#Cons [["lux;eval-ctor" Int]
+ #Nil])])])])])])])])])))
+
+## (deftype #rec Syntax
+## (Meta Cursor (| (#Bool Bool)
+## (#Int Int)
+## (#Real Real)
+## (#Char Char)
+## (#Text Text)
+## (#Form (List Syntax))
+## (#Tuple (List Syntax))
+## (#Record (List (, Text Syntax))))))
+(def' Syntax
+ (case' (#AppT [(#BoundT "Syntax") (#BoundT "")])
+ Syntax
+ (case' (#AppT [List Syntax])
+ SyntaxList
+ (#AppT [(#AllT [#Nil "Syntax" ""
+ (#VariantT (#Cons [["lux;Bool" Bool]
+ (#Cons [["lux;Int" Int]
+ (#Cons [["lux;Real" Real]
+ (#Cons [["lux;Char" Char]
+ (#Cons [["lux;Text" Text]
+ (#Cons [["lux;Form" SyntaxList]
+ (#Cons [["lux;Tuple" SyntaxList]
+ (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Text (#Cons [Syntax #Nil])]))])]
+ #Nil])])])])])])])]))])
+ #NothingT]))))
-## ## (deftype Macro
-## ## (-> (List Syntax) CompilerState
-## ## (Either Text [CompilerState (List Syntax)])))
-## (def' Macro
-## (case' (#AppT [List Syntax])
-## SyntaxList
-## (#LambdaT [SyntaxList
-## (#LambdaT [CompilerState
-## (#AppT [(#AppT [Either Text])
-## (#TupleT (#Cons [CompilerState
-## (#Cons [SyntaxList #Nil])]))])])])))
+## (deftype (Either l r)
+## (| (#Left l)
+## (#Right r)))
+(def' Either
+ (#AllT [#Nil "Either" "l"
+ (#AllT [#Nil "" "r"
+ (#VariantT (#Cons [["lux;Left" (#BoundT "l")]
+ (#Cons [["lux;Right" (#BoundT "r")]
+ #Nil])]))])]))
+
+## (deftype Macro
+## (-> (List Syntax) CompilerState
+## (Either Text [CompilerState (List Syntax)])))
+(def' Macro
+ (case' (#AppT [List Syntax])
+ SyntaxList
+ (#LambdaT [SyntaxList
+ (#LambdaT [CompilerState
+ (#AppT [(#AppT [Either Text])
+ (#TupleT (#Cons [CompilerState
+ (#Cons [SyntaxList #Nil])]))])])])))
## ## Base functions & macros
## ## (def (_meta data)
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 80f2cd252..c56f3c053 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -2,7 +2,7 @@
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return fail |list]]
+ (lux [base :as & :refer [|do return fail |list]]
[reader :as &reader]
[parser :as &parser]
[type :as &type]
@@ -68,8 +68,8 @@
(&&lux/analyse-symbol analyse exo-type ?ident)
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "case'"]]]]
- ["lux;Cons" [?variant ?branches]]]]]]]]
- (&&lux/analyse-case analyse ?variant ?branches)
+ ["lux;Cons" [?value ?branches]]]]]]]]
+ (&&lux/analyse-case analyse exo-type ?value ?branches)
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "lambda'"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?self]]]]
@@ -444,5 +444,5 @@
;; [Resources]
(defn analyse [eval!]
- (exec [asts &parser/parse]
+ (|do [asts &parser/parse]
(&/flat-map% (partial analyse-ast eval! &type/Nothing) asts)))
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 62ccedb51..b287b545f 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -1,7 +1,7 @@
(ns lux.analyser.base
(:require [clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return fail]]
+ (lux [base :as & :refer [|do return fail]]
[type :as &type])))
;; [Resources]
@@ -17,7 +17,7 @@
(fail (str "[Analyser Error] Can't retrieve the type of a statement: " (pr-str syntax+)))))
(defn analyse-1 [analyse exo-type elem]
- (exec [output (analyse exo-type elem)]
+ (|do [output (analyse exo-type elem)]
(do ;; (prn 'analyse-1 (aget output 0))
(matchv ::M/objects [output]
[["lux;Cons" [x ["lux;Nil" _]]]]
@@ -27,7 +27,7 @@
(fail "[Analyser Error] Can't expand to other than 1 element.")))))
(defn analyse-2 [analyse el1 el2]
- (exec [output (&/flat-map% analyse (&/|list el1 el2))]
+ (|do [output (&/flat-map% analyse (&/|list el1 el2))]
(do ;; (prn 'analyse-2 (aget output 0))
(matchv ::M/objects [output]
[["lux;Cons" [x ["lux;Cons" [y ["lux;Nil" _]]]]]]
@@ -37,9 +37,9 @@
(fail "[Analyser Error] Can't expand to other than 2 elements.")))))
(defn with-var [k]
- (exec [=var &type/fresh-var
+ (|do [=var &type/fresh-var
=ret (k =var)]
(matchv ::M/objects [=ret]
[["Expression" [?expr ?type]]]
- (exec [=type (&type/clean =var ?type)]
+ (|do [=type (&type/clean =var ?type)]
(return (&/V "Expression" (&/T ?expr =type)))))))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index f6a0b2cc8..0c9c55cf8 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -1,36 +1,225 @@
(ns lux.analyser.case
(:require [clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return fail |let]]
+ (lux [base :as & :refer [|do return fail |let]]
[parser :as &parser]
[type :as &type])
(lux.analyser [base :as &&]
[env :as &env])))
-;; [Resources]
-(defn locals [member]
- (matchv ::M/objects [member]
- [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]]]
- (&/|list ?name)
+;; [Utils]
+(defn ^:private analyse-variant [analyse-pattern idx value-type tag value]
+ (|do [=var &type/fresh-var
+ _ (&type/check value-type (&/V "lux;VariantT" (&/|list (&/T tag =var))))
+ [idx* test] (analyse-pattern idx =var value)]
+ (return (&/T idx* (&/V "VariantTestAC" (&/T tag test))))))
- [["lux;Meta" [_ ["lux;Tuple" ?submembers]]]]
- (&/flat-map locals ?submembers)
+(defn ^:private analyse-pattern [idx value-type pattern]
+ (prn 'analyse-pattern/pattern (aget pattern 0) (aget pattern 1) (alength (aget pattern 1)))
+ (matchv ::M/objects [pattern]
+ [["lux;Meta" [_ pattern*]]]
+ ;; (assert false)
+ (do (prn 'analyse-pattern/pattern* (aget pattern* 0))
+ (matchv ::M/objects [pattern*]
+ [["lux;Symbol" [?module ?name]]]
+ (return (&/T (inc idx) (&/V "StoreTestAC" (&/T idx (str ?module ";" ?name) value-type))))
- [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" _]]] ?submembers]]]]]]
- (&/flat-map locals ?submembers)
+ [["lux;Bool" ?value]]
+ (|do [_ (&type/check value-type &type/Bool)]
+ (return (&/T idx (&/V "BoolTestAC" ?value))))
+ [["lux;Int" ?value]]
+ (|do [_ (&type/check value-type &type/Int)]
+ (return (&/T idx (&/V "IntTestAC" ?value))))
+
+ [["lux;Real" ?value]]
+ (|do [_ (&type/check value-type &type/Real)]
+ (return (&/T idx (&/V "RealTestAC" ?value))))
+
+ [["lux;Char" ?value]]
+ (|do [_ (&type/check value-type &type/Char)]
+ (return (&/T idx (&/V "CharTestAC" ?value))))
+
+ [["lux;Text" ?value]]
+ (|do [_ (&type/check value-type &type/Text)]
+ (return (&/T idx (&/V "TextTestAC" ?value))))
+
+ [["lux;Tuple" ?members]]
+ (|do [=vars (&/map% (fn [_] &type/fresh-var)
+ (&/|range (&/|length ?members)))
+ _ (&type/check value-type (&/V "lux;TupleT" =vars))
+ [idx* tests] (&/fold% (fn [idx+subs mv]
+ (|let [[idx subs] idx+subs
+ [?member ?var] mv]
+ (|do [[idx* test] (analyse-pattern idx ?var ?member)]
+ (return (&/T idx* (&/|cons test subs))))))
+ (&/T idx (&/|list))
+ (&/zip2 ?members =vars))]
+ (return (&/T idx* (&/V "TupleTestAC" (&/|reverse tests)))))
+
+ [["lux;Record" ?fields]]
+ (|do [=vars (&/map% (fn [_] &type/fresh-var)
+ (&/|range (&/|length ?fields)))
+ _ (&type/check value-type (&/V "lux;RecordT" (&/zip2 (&/|keys ?fields) =vars)))
+ tests (&/fold% (fn [idx+subs mv]
+ (|let [[idx subs] idx+subs
+ [[slot value] ?var] mv]
+ (|do [[idx* test] (analyse-pattern idx ?var value)]
+ (return (&/T idx* (&/|cons (&/T slot test) subs))))))
+ (&/T idx (&/|list)) (&/zip2 ?fields =vars))]
+ (return (&/V "RecordTestAC" tests)))
+
+ [["lux;Tag" ?tag]]
+ (analyse-variant analyse-pattern idx value-type ?tag (&/V "lus;Meta" (&/T (&/T "" -1 -1)
+ (&/V "lux;Tuple" (&/|list)))))
+
+ [["lux;Form" ["lux;Cons" [["lus;Meta" [_ ["lux;Tag" ?tag]]]
+ ["lux;Cons" [?value
+ ["lux;Nil" _]]]]]]]
+ (analyse-variant analyse-pattern idx value-type ?tag ?value)
+ ))
+ ))
+
+(defn ^:private with-test [test body]
+ (matchv ::M/objects [test]
+ [["StoreTestAC" [?idx ?name ?type]]]
+ (&env/with-local ?name ?type
+ body)
+
+ [["TupleTestAC" ?tests]]
+ (&/fold #(with-test %2 %1) body (&/|reverse ?tests))
+
+ [["RecordTestAC" ?tests]]
+ (&/fold #(with-test %2 %1) body (&/|reverse (&/|vals ?tests)))
+
+ [["VariantTestAC" [?tag ?value]]]
+ (with-test ?value body)
+
[_]
- (&/|list)))
-
-(defn analyse-branch [analyse max-registers bindings+body]
- (|let [[bindings body] bindings+body]
- (do ;; (prn 'analyse-branch max-registers (&/->seq bindings) body)
- (&/fold (fn [body* name]
- (&&/with-var
- (fn [=var]
- (&env/with-local name =var body*))))
- (&/fold (fn [body* _]
- (&env/with-local "" &type/+dont-care+ body*))
- (&&/analyse-1 analyse body)
- (&/|range (- max-registers (&/|length bindings))))
- (&/|reverse bindings)))))
+ body
+ ))
+
+(defn ^:private analyse-branch [analyse exo-type value-type pattern body match]
+ (|do [idx &env/next-local-idx
+ [idx* =test] (analyse-pattern idx value-type pattern)
+ =body (with-test =test
+ (&&/analyse-1 analyse exo-type body))]
+ (matchv ::M/objects [match]
+ [["MatchAC" ?patterns]]
+ (return (&/V "MatchAC" (&/|cons (&/T =test =body) ?patterns))))))
+
+(let [compare-kv #(compare (aget %1 0) (aget %2 0))]
+ (defn ^:private merge-total [struct test+body]
+ (prn 'merge-total (aget struct 0) (aget test+body 0 0))
+ (matchv ::M/objects [test+body]
+ [[test _]]
+ (matchv ::M/objects [struct test]
+ [["DefaultTotal" total?] ["StoreTestAC" [?idx ?name type]]]
+ (return (&/V "DefaultTotal" true))
+
+ [[?tag [total? ?values]] ["StoreTestAC" [?idx ?name type]]]
+ (return (&/V ?tag (&/T true ?values)))
+
+ [["DefaultTotal" total?] ["BoolTestAC" ?value]]
+ (return (&/V "BoolTotal" (&/T total? (&/|list ?value))))
+
+ [["BoolTotal" [total? ?values]] ["BoolTestAC" ?value]]
+ (return (&/V "BoolTotal" (&/T total? (&/|cons ?value ?values))))
+
+ [["DefaultTotal" total?] ["IntTestAC" ?value]]
+ (return (&/V "IntTotal" (&/T total? (&/|list ?value))))
+
+ [["IntTotal" [total? ?values]] ["IntTestAC" ?value]]
+ (return (&/V "IntTotal" (&/T total? (&/|cons ?value ?values))))
+
+ [["DefaultTotal" total?] ["RealTestAC" ?value]]
+ (return (&/V "RealTotal" (&/T total? (&/|list ?value))))
+
+ [["RealTotal" [total? ?values]] ["RealTestAC" ?value]]
+ (return (&/V "RealTotal" (&/T total? (&/|cons ?value ?values))))
+
+ [["DefaultTotal" total?] ["CharTestAC" ?value]]
+ (return (&/V "CharTotal" (&/T total? (&/|list ?value))))
+
+ [["CharTotal" [total? ?values]] ["CharTestAC" ?value]]
+ (return (&/V "CharTotal" (&/T total? (&/|cons ?value ?values))))
+
+ [["DefaultTotal" total?] ["TextTestAC" ?value]]
+ (return (&/V "TextTotal" (&/T total? (&/|list ?value))))
+
+ [["TextTotal" [total? ?values]] ["TextTestAC" ?value]]
+ (return (&/V "TextTotal" (&/T total? (&/|cons ?value ?values))))
+
+ [["DefaultTotal" total?] ["TupleTestAC" ?tests]]
+ (|do [structs (&/map% (fn [t]
+ (merge-total (&/V "DefaultTotal" total?) t))
+ ?tests)]
+ (return (&/V "TupleTotal" (&/T total? structs))))
+
+ [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]]
+ (if (= (&/|length ?values) (&/|length ?tests))
+ (|do [structs (&/map% (fn [vt]
+ (|let [[v t] vt]
+ (merge-total v t)))
+ (&/zip2 ?values ?tests))]
+ (return (&/V "TupleTotal" (&/T total? structs))))
+ (fail "[Pattern-matching error] Inconsistent tuple-size."))
+
+ [["DefaultTotal" total?] ["RecordTestAC" ?tests]]
+ (|do [structs (&/map% (fn [t]
+ (|let [[slot value] t]
+ (|do [struct (merge-total (&/V "DefaultTotal" total?) value)]
+ (return (&/T slot struct)))))
+ (sort compare-kv ?tests))]
+ (return (&/V "RecordTotal" (&/T total? structs))))
+
+ [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]]
+ (if (= (&/|length ?values) (&/|length ?tests))
+ (|do [structs (&/map% (fn [lr]
+ (|let [[[lslot struct] [rslot value]] lr]
+ (if (= lslot rslot)
+ (|do [struct (merge-total (&/V "DefaultTotal" total?) value)]
+ (return (&/T lslot struct)))
+ (fail "[Pattern-matching error] Record slots mismatch."))))
+ (&/zip2 ?values
+ (sort compare-kv ?tests)))]
+ (return (&/V "RecordTotal" (&/T total? structs))))
+ (fail "[Pattern-matching error] Inconsistent record-size."))
+
+ [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]]
+ (|do [struct (merge-total (&/V "DefaultTotal" total?) ?test)]
+ (return (&/V "VariantTotal" (&/T total? (&/|list (&/T ?tag struct))))))
+
+ [["VariantTotal" [total? ?branches]] ["VariantTestAC" [?tag ?test]]]
+ (|do [struct (merge-total (or (&/|get ?tag ?branches)
+ (&/V "DefaultTotal" total?))
+ ?test)]
+ (return (&/V "VariantTotal" (&/T total? (&/|put ?tag struct ?branches)))))
+ ))))
+
+(defn ^:private totality-struct [owner-total? match]
+ (let [msg "Pattern matching is non-total"]
+ (matchv ::M/objects [match]
+ [["MatchAC" ?tests]]
+ (&/fold% merge-total (&/V "DefaultTotal" false) ?tests))))
+
+(defn ^:private check-totality [value-type struct]
+ (prn 'check-totality (aget value-type 0) (aget struct 0) (&type/show-type value-type))
+ (matchv ::M/objects [value-type struct]
+ [_ ["DefaultTotal" true]]
+ true
+ ))
+
+;; [Exports]
+(defn analyse-branches [analyse exo-type value-type branches]
+ (|do [=match (&/fold% (fn [match branch]
+ (|let [[pattern body] branch]
+ (analyse-branch analyse exo-type value-type pattern body match)))
+ (&/V "MatchAC" (&/|list))
+ branches)
+ struct (totality-struct false =match)]
+ (matchv ::M/objects [=match]
+ [["MatchAC" ?tests]]
+ (if (check-totality value-type struct)
+ (return (&/V "MatchAC" (&/|reverse ?tests)))
+ (fail "[Pattern-maching error] Pattern-matching is non-total.")))))
diff --git a/src/lux/analyser/def.clj b/src/lux/analyser/def.clj
index 2a9b181e2..eb637f66b 100644
--- a/src/lux/analyser/def.clj
+++ b/src/lux/analyser/def.clj
@@ -2,7 +2,7 @@
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return return* fail]])
+ (lux [base :as & :refer [|do return return* fail]])
[lux.analyser.base :as &&]))
;; [Exports]
diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj
index 4f772e126..454d8ad6c 100644
--- a/src/lux/analyser/env.clj
+++ b/src/lux/analyser/env.clj
@@ -1,7 +1,7 @@
(ns lux.analyser.env
(:require [clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return return* fail]])
+ (lux [base :as & :refer [|do return return* fail]])
[lux.analyser.base :as &&]))
;; [Exports]
@@ -10,6 +10,7 @@
(return* state (->> state (&/get$ "lux;local-envs") &/|head (&/get$ "lux;locals") (&/get$ "lux;counter")))))
(defn with-local [name type body]
+ (prn 'with-local name)
(fn [state]
(let [old-mappings (->> state (&/get$ "lux;local-envs") &/|head (&/get$ "lux;locals") (&/get$ "lux;mappings"))
=return (body (&/update$ "lux;local-envs"
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index cfc79c0b3..6fce672de 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -2,7 +2,7 @@
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return fail]]
+ (lux [base :as & :refer [|do return fail]]
[parser :as &parser]
[type :as &type]
[host :as &host])
@@ -23,11 +23,11 @@
(let [input-type (&/V "lux;DataT" (to-array [<input-class> (&/V "lux;Nil" nil)]))
output-type (&/V "lux;DataT" (to-array [<output-class> (&/V "lux;Nil" nil)]))]
(defn <name> [analyse ?x ?y]
- (exec [[=x =y] (&&/analyse-2 analyse ?x ?y)
+ (|do [[=x =y] (&&/analyse-2 analyse ?x ?y)
=x-type (&&/expr-type =x)
=y-type (&&/expr-type =y)
- _ (&type/solve input-type =x-type)
- _ (&type/solve input-type =y-type)]
+ _ (&type/check input-type =x-type)
+ _ (&type/check input-type =y-type)]
(return (&/|list (&/V "Expression" (&/T (&/V <output-tag> (&/T =x =y)) output-type)))))))
analyse-jvm-iadd "jvm-iadd" "java.lang.Integer" "java.lang.Integer"
@@ -68,7 +68,7 @@
)
(defn analyse-jvm-getstatic [analyse ?class ?field]
- (exec [=class (&host/full-class-name ?class)
+ (|do [=class (&host/full-class-name ?class)
;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)]
=type (&host/lookup-static-field =class ?field)
;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)]
@@ -76,13 +76,13 @@
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-getstatic" (&/T =class ?field)) =type))))))
(defn analyse-jvm-getfield [analyse ?class ?field ?object]
- (exec [=class (&host/full-class-name ?class)
+ (|do [=class (&host/full-class-name ?class)
=type (&host/lookup-static-field =class ?field)
=object (&&/analyse-1 analyse ?object)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-getfield" (&/T =class ?field =object)) =type))))))
(defn analyse-jvm-putstatic [analyse ?class ?field ?value]
- (exec [=class (&host/full-class-name ?class)
+ (|do [=class (&host/full-class-name ?class)
;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)]
=type (&host/lookup-static-field =class ?field)
;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)]
@@ -90,14 +90,14 @@
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-putstatic" (&/T =class ?field =value)) =type))))))
(defn analyse-jvm-putfield [analyse ?class ?field ?object ?value]
- (exec [=class (&host/full-class-name ?class)
+ (|do [=class (&host/full-class-name ?class)
=type (&host/lookup-static-field =class ?field)
=object (&&/analyse-1 analyse ?object)
=value (&&/analyse-1 analyse ?value)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-putfield" (&/T =class ?field =object =value)) =type))))))
(defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args]
- (exec [=class (&host/full-class-name ?class)
+ (|do [=class (&host/full-class-name ?class)
=classes (&/map% &host/extract-jvm-param ?classes)
=return (&host/lookup-static-method =class ?method =classes)
=args (&/flat-map% analyse ?args)]
@@ -106,7 +106,7 @@
(do-template [<name> <tag>]
(defn <name> [analyse ?class ?method ?classes ?object ?args]
;; (prn '<name> ?class ?method)
- (exec [=class (&host/full-class-name ?class)
+ (|do [=class (&host/full-class-name ?class)
;; :let [_ (prn 'analyse-jvm-invokevirtual/=class =class)]
=classes (&/map% &host/extract-jvm-param ?classes)
;; :let [_ (prn 'analyse-jvm-invokevirtual/=classes =classes)]
@@ -125,22 +125,22 @@
)
(defn analyse-jvm-null? [analyse ?object]
- (exec [=object (&&/analyse-1 analyse ?object)]
+ (|do [=object (&&/analyse-1 analyse ?object)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" (&/T "java.lang.Boolean" (&/V "lux;Nil" nil)))))))))
(defn analyse-jvm-new [analyse ?class ?classes ?args]
- (exec [=class (&host/full-class-name ?class)
+ (|do [=class (&host/full-class-name ?class)
=classes (&/map% &host/extract-jvm-param ?classes)
=args (&/flat-map% analyse ?args)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-new" (&/T =class =classes =args)) (&/V "lux;DataT" (&/T =class (&/V "lux;Nil" nil)))))))))
(defn analyse-jvm-new-array [analyse ?class ?length]
- (exec [=class (&host/full-class-name ?class)]
+ (|do [=class (&host/full-class-name ?class)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-new-array" (&/T =class ?length)) (&/V "array" (&/T (&/V "lux;DataT" (to-array [=class (&/V "lux;Nil" nil)]))
(&/V "lux;Nil" nil)))))))))
(defn analyse-jvm-aastore [analyse ?array ?idx ?elem]
- (exec [=array+=elem (&&/analyse-2 analyse ?array ?elem)
+ (|do [=array+=elem (&&/analyse-2 analyse ?array ?elem)
:let [[=array =elem] (matchv ::M/objects [=array+=elem]
[[=array =elem]]
[=array =elem])]
@@ -148,12 +148,12 @@
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-aastore" (&/T =array ?idx =elem)) =array-type))))))
(defn analyse-jvm-aaload [analyse ?array ?idx]
- (exec [=array (&&/analyse-1 analyse ?array)
+ (|do [=array (&&/analyse-1 analyse ?array)
=array-type (&&/expr-type =array)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type))))))
(defn analyse-jvm-class [analyse ?name ?super-class ?fields]
- (exec [?fields (&/map% (fn [?field]
+ (|do [?fields (&/map% (fn [?field]
(matchv ::M/objects [?field]
[["lux;Meta" [_ ["lux;Tuple" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?class]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?field-name]]]
@@ -171,7 +171,7 @@
(defn analyse-jvm-interface [analyse ?name ?members]
;; (prn 'analyse-jvm-interface ?name ?members)
- (exec [=members (&/map% (fn [member]
+ (|do [=members (&/map% (fn [member]
;; (prn 'analyse-jvm-interface (&/show-ast member))
(matchv ::M/objects [member]
[["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ":"]]]]
@@ -182,7 +182,7 @@
["lux;Nil" _]]]]]]]]]]
["lux;Nil" _]]]]]]]]]]]
(do ;; (prn 'analyse-jvm-interface ?member-name ?inputs ?output)
- (exec [?inputs (&/map% extract-ident ?inputs)]
+ (|do [?inputs (&/map% extract-ident ?inputs)]
(return [?member-name [?inputs ?output]])))
[_]
@@ -196,10 +196,10 @@
(return (&/|list (&/V "Statement" (&/V "jvm-interface" (&/T $module ?name =methods)))))))
(defn analyse-jvm-try [analyse ?body [?catches ?finally]]
- (exec [=body (&&/analyse-1 analyse ?body)
+ (|do [=body (&&/analyse-1 analyse ?body)
=catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]]
(&&env/with-local ?ex-arg (&/V "lux;DataT" (&/T ?ex-class (&/V "lux;Nil" nil)))
- (exec [=catch-body (&&/analyse-1 analyse ?catch-body)]
+ (|do [=catch-body (&&/analyse-1 analyse ?catch-body)]
(return [?ex-class ?ex-arg =catch-body]))))
?catches)
=finally (&&/analyse-1 analyse ?finally)
@@ -207,20 +207,20 @@
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-try" (&/T =body =catches =finally)) =body-type))))))
(defn analyse-jvm-throw [analyse ?ex]
- (exec [=ex (&&/analyse-1 analyse ?ex)]
+ (|do [=ex (&&/analyse-1 analyse ?ex)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-throw" =ex) (&/V "lux;NothingT" nil)))))))
(defn analyse-jvm-monitorenter [analyse ?monitor]
- (exec [=monitor (&&/analyse-1 analyse ?monitor)]
+ (|do [=monitor (&&/analyse-1 analyse ?monitor)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-monitorenter" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))))
(defn analyse-jvm-monitorexit [analyse ?monitor]
- (exec [=monitor (&&/analyse-1 analyse ?monitor)]
+ (|do [=monitor (&&/analyse-1 analyse ?monitor)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-monitorexit" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))))
(do-template [<name> <tag> <from-class> <to-class>]
(defn <name> [analyse ?value]
- (exec [=value (&&/analyse-1 analyse ?value)]
+ (|do [=value (&&/analyse-1 analyse ?value)]
(return (&/|list (&/V "Expression" (&/T (&/V <tag> =value) (&/V "lux;DataT" (&/T <to-class> (&/V "lux;Nil" nil)))))))))
analyse-jvm-d2f "jvm-d2f" "java.lang.Double" "java.lang.Float"
@@ -245,7 +245,7 @@
(do-template [<name> <tag> <from-class> <to-class>]
(defn <name> [analyse ?value]
- (exec [=value (&&/analyse-1 analyse ?value)]
+ (|do [=value (&&/analyse-1 analyse ?value)]
(return (&/|list (&/V "Expression" (&/T (&/V <tag> =value) (&/V "lux;DataT" (&/T <to-class> (&/V "lux;Nil" nil)))))))))
analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer"
@@ -261,6 +261,6 @@
)
(defn analyse-jvm-program [analyse ?args ?body]
- (exec [=body (&&env/with-local ?args (&/V "lux;AnyT" nil)
+ (|do [=body (&&env/with-local ?args (&/V "lux;AnyT" nil)
(&&/analyse-1 analyse ?body))]
(return (&/|list (&/V "Statement" (&/V "jvm-program" =body))))))
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index c4d218c18..e12b22005 100644
--- a/src/lux/analyser/lambda.clj
+++ b/src/lux/analyser/lambda.clj
@@ -1,17 +1,17 @@
(ns lux.analyser.lambda
(:require [clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return fail]])
+ (lux [base :as & :refer [|do return fail]])
(lux.analyser [base :as &&]
[env :as &env])))
;; [Resource]
(defn with-lambda [self self-type arg arg-type body]
(&/with-closure
- (exec [scope-name &/get-scope-name]
+ (|do [scope-name &/get-scope-name]
(&env/with-local self self-type
(&env/with-local arg arg-type
- (exec [=return body
+ (|do [=return body
=captured &env/captured-vars]
(return (&/T scope-name =captured =return))))))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index e38d10117..119e77826 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -2,7 +2,7 @@
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return return* fail fail* |let |list]]
+ (lux [base :as & :refer [|do return return* fail fail* |let |list]]
[parser :as &parser]
[type :as &type]
[macro :as &macro]
@@ -19,206 +19,183 @@
;; [Exports]
(defn analyse-tuple [analyse exo-type ?elems]
- (exec [=elems (&/map% (analyse-1+ analyse) ?elems)
- =elems-types (&/map% &&/expr-type =elems)
- ;; :let [_ (prn 'analyse-tuple =elems)]
- :let [endo-type (&/V "lux;TupleT" =elems-types)]
- _ (&type/solve exo-type endo-type)
- ;; :let [_ (prn 'analyse-tuple 'DONE)]
- ]
+ (|do [=elems (&/map% (analyse-1+ analyse) ?elems)
+ =elems-types (&/map% &&/expr-type =elems)
+ ;; :let [_ (prn 'analyse-tuple =elems)]
+ :let [endo-type (&/V "lux;TupleT" =elems-types)]
+ _ (&type/check exo-type endo-type)
+ ;; :let [_ (prn 'analyse-tuple 'DONE)]
+ ]
(return (&/|list (&/V "Expression" (&/T (&/V "tuple" =elems)
exo-type))))))
(defn analyse-variant [analyse exo-type ident ?value]
- (|let [[?module ?name] ident
- ?tag (str ?module ";" ?name)]
- (exec [=value ((analyse-1+ analyse) ?value)
- =value-type (&&/expr-type =value)
- :let [endo-type (&/V "lux;VariantT" (|list (&/T ?tag =value-type)))]
- _ (&type/solve exo-type endo-type)
- ;; :let [_ (prn 'analyse-variant 'DONE)]
- ]
+ (|let [[?module ?name] ident]
+ (|do [module (if (= "" ?module)
+ &/get-module-name
+ (return ?module))
+ :let [?tag (str module ";" ?name)]
+ =value ((analyse-1+ analyse) ?value)
+ =value-type (&&/expr-type =value)
+ :let [endo-type (&/V "lux;VariantT" (|list (&/T ?tag =value-type)))]
+ _ (&type/check exo-type endo-type)
+ ;; :let [_ (prn 'analyse-variant 'DONE)]
+ ]
(return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag =value))
exo-type)))))))
(defn analyse-record [analyse exo-type ?elems]
- (exec [=elems (&/map% (fn [kv]
- (matchv ::M/objects [kv]
- [[k v]]
- (exec [=v (&&/analyse-1 analyse v)]
- (return (to-array [k =v])))))
- ?elems)
- =elems-types (&/map% (fn [kv]
- (matchv ::M/objects [kv]
- [[k v]]
- (exec [=v (&&/expr-type v)]
- (return (to-array [k =v])))))
- =elems)
- ;; :let [_ (prn 'analyse-tuple =elems)]
- ]
+ (|do [=elems (&/map% (fn [kv]
+ (matchv ::M/objects [kv]
+ [[k v]]
+ (|do [=v (&&/analyse-1 analyse v)]
+ (return (to-array [k =v])))))
+ ?elems)
+ =elems-types (&/map% (fn [kv]
+ (matchv ::M/objects [kv]
+ [[k v]]
+ (|do [module (if (= "" k)
+ &/get-module-name
+ (return k))
+ =v (&&/expr-type v)]
+ (return (to-array [module =v])))))
+ =elems)
+ ;; :let [_ (prn 'analyse-tuple =elems)]
+ ]
(return (&/|list (&/V "Expression" (&/T (&/V "lux;record" =elems) (&/V "lux;RecordT" =elems-types)))))))
(defn analyse-symbol [analyse exo-type ident]
- (|let [[?module ?name] ident]
- (do ;; (prn 'analyse-ident ?module ?name)
- (exec [module-name &/get-module-name]
- (fn [state]
- ;; (when (and (= "lux" ?module)
- ;; (= "output" ?name))
- ;; (prn (&/show-state state)))
- ;; (prn 'module-name module-name)
- ;; (prn '(&/get$ "local-envs" state) (&/get$ "local-envs" state))
- ;; (prn '(&/->seq (&/get$ "local-envs" state)) (&/->seq (&/get$ "local-envs" state)))
- ;; (println (&/show-state state))
- (|let [stack (&/get$ "lux;local-envs" state)
- no-binding? #(and (->> % (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|contains? ?name) not)
- (->> % (&/get$ "lux;closure") (&/get$ "lux;mappings") (&/|contains? ?name) not))
- [inner outer] (&/|split-with no-binding? stack)]
- (matchv ::M/objects [outer]
- [["lux;Nil" _]]
- (|let [[?module ?name] ident
- ident* (str ?module ";" ?name)]
- (if-let [global (->> state (&/get$ "lux;global-env") &/from-some (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|get ident*))]
- (&/run-state (exec [=global-type (&&/expr-type global)
- _ (&type/solve exo-type =global-type)]
- (return (&/|list global)))
- state)
- (fail* (str "[Analyser Error] Unresolved identifier: " ident*))))
-
- [["lux;Cons" [top-outer _]]]
- (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ "lux;name" %2) %1)
- (&/|map #(&/get$ "lux;name" %) outer)
- (&/|reverse inner)))
- ;; _ (prn 'inner module-name ident (&/->seq (&/|map #(&/get$ "name" %) inner)) scopes)
- [=local inner*] (&/fold (fn [register+new-inner frame+in-scope]
- (|let [[register new-inner] register+new-inner
- [frame in-scope] frame+in-scope
- [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ?name register frame)]
- (&/T register* (&/|cons frame* new-inner))))
- (&/T (or (->> top-outer (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|get ?name))
- (->> top-outer (&/get$ "lux;closure") (&/get$ "lux;mappings") (&/|get ?name)))
- (&/|list))
- (&/zip2 (&/|reverse inner) scopes))]
- (return* (&/set$ "lux;local-envs" (&/|++ inner* outer) state) (&/|list =local)))
- )))
- ))))
+ (|do [module-name &/get-module-name]
+ (fn [state]
+ (|let [[?module ?name] ident
+ local-ident (str ?module ";" ?name)
+ global-ident (str (if (= "" ?module) module-name ?module) ";" ?name)
+ stack (&/get$ "lux;local-envs" state)
+ no-binding? #(and (->> % (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|contains? local-ident) not)
+ (->> % (&/get$ "lux;closure") (&/get$ "lux;mappings") (&/|contains? local-ident) not))
+ [inner outer] (&/|split-with no-binding? stack)]
+ (matchv ::M/objects [outer]
+ [["lux;Nil" _]]
+ (if-let [global (->> state (&/get$ "lux;global-env") &/from-some (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|get global-ident))]
+ (&/run-state (|do [=global-type (&&/expr-type global)
+ _ (&type/check exo-type =global-type)]
+ (return (&/|list global)))
+ state)
+ (fail* (str "[Analyser Error] Unrecognized identifier: " local-ident)))
+
+ [["lux;Cons" [top-outer _]]]
+ (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ "lux;name" %2) %1)
+ (&/|map #(&/get$ "lux;name" %) outer)
+ (&/|reverse inner)))
+ [=local inner*] (&/fold (fn [register+new-inner frame+in-scope]
+ (|let [[register new-inner] register+new-inner
+ [frame in-scope] frame+in-scope
+ [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ?name register frame)]
+ (&/T register* (&/|cons frame* new-inner))))
+ (&/T (or (->> top-outer (&/get$ "lux;locals") (&/get$ "lux;mappings") (&/|get local-ident))
+ (->> top-outer (&/get$ "lux;closure") (&/get$ "lux;mappings") (&/|get local-ident)))
+ (&/|list))
+ (&/zip2 (&/|reverse inner) scopes))]
+ (return* (&/set$ "lux;local-envs" (&/|++ inner* outer) state) (&/|list =local)))
+ )))
+ ))
(defn ^:private analyse-apply* [analyse exo-type =fn ?args]
- (exec [=args (&/flat-map% analyse ?args)
- =fn-type (&&/expr-type =fn)
- [=apply _] (&/fold% (fn [[=fn =fn-type] =input]
- (exec [;; :let [_ (prn "#2")]
- =input-type (&&/expr-type =input)
- ;; :let [_ (prn "#3")]
- =output-type (&type/apply-lambda =fn-type =input-type)
- ;; :let [_ (prn "#4")]
- ]
- (return [(&/V "Expression" (&/T (&/V "apply" (&/T =fn =input))
- =output-type))
- =output-type])))
- [=fn =fn-type]
- =args)]
+ (|do [=args (&/flat-map% analyse ?args)
+ =fn-type (&&/expr-type =fn)
+ [=apply _] (&/fold% (fn [[=fn =fn-type] =input]
+ (|do [;; :let [_ (prn "#2")]
+ =input-type (&&/expr-type =input)
+ ;; :let [_ (prn "#3")]
+ =output-type (&type/apply-lambda =fn-type =input-type)
+ ;; :let [_ (prn "#4")]
+ ]
+ (return [(&/V "Expression" (&/T (&/V "apply" (&/T =fn =input))
+ =output-type))
+ =output-type])))
+ [=fn =fn-type]
+ =args)]
(return (&/|list =apply))))
(defn analyse-apply [analyse exo-type =fn ?args]
;; (prn 'analyse-apply1 (aget =fn 0))
- (exec [loader &/loader]
+ (|do [loader &/loader]
(matchv ::M/objects [=fn]
[["Expression" [=fn-form =fn-type]]]
(do ;; (prn 'analyse-apply2 (aget =fn-form 0))
- (matchv ::M/objects [=fn-form]
- [["global" [?module ?name]]]
- (exec [macro? (&&def/macro? ?module ?name)]
- (if macro?
- (let [macro-class (&host/location (&/|list ?module ?name))]
- (exec [macro-expansion (&macro/expand loader macro-class ?args)
- output (&/flat-map% analyse macro-expansion)]
- (return output)))
- (analyse-apply* analyse =fn ?args)))
-
- [_]
- (analyse-apply* analyse =fn ?args)))
+ (matchv ::M/objects [=fn-form]
+ [["global" [?module ?name]]]
+ (|do [macro? (&&def/macro? ?module ?name)]
+ (if macro?
+ (let [macro-class (&host/location (&/|list ?module ?name))]
+ (|do [macro-expansion (&macro/expand loader macro-class ?args)
+ output (&/flat-map% analyse macro-expansion)]
+ (return output)))
+ (analyse-apply* analyse =fn ?args)))
+
+ [_]
+ (analyse-apply* analyse =fn ?args)))
[_]
(fail "[Analyser Error] Can't call a statement!"))
))
(defn analyse-case [analyse exo-type ?value ?branches]
- ;; (prn 'analyse-case (aget ?branches 0) (aget ?branches 1 1 0)
- ;; (&/->seq ?branches))
- ;; (prn 'analyse-case (&/show-ast ?value))
- (exec [:let [num-branches (&/|length ?branches)
- ;; _ (prn 'analyse-case ?value (&/|length ?branches)
- ;; (and (> num-branches 0) (even? num-branches)))
- ]
- _ (&/assert! (and (> num-branches 0) (even? num-branches))
- "[Analyser Error] Unbalanced branches in \"case'\" expression.")
- :let [branches (&/|as-pairs ?branches)
- ;; _ (prn '(&/|length branches) (&/|length branches))
- locals-per-branch (&/|map (comp &&case/locals &/|first) branches)
- max-locals (&/fold max 0 (&/|map &/|length locals-per-branch))]
- ;; :let [_ (prn '[branches locals-per-branch max-locals] [branches locals-per-branch max-locals])]
- base-register &&env/next-local-idx
- ;; :let [_ (prn 'base-register base-register)]
- =value (&&/analyse-1 analyse ?value)
- ;; :let [_ (prn '=value =value)]
- =bodies (&/map% (partial &&case/analyse-branch analyse max-locals)
- (&/zip2 locals-per-branch (&/|map &/|second branches)))
- ;; :let [_ (prn '=bodies =bodies)]
- ;; :let [_ (prn 'analyse-case/=bodies =bodies)]
- =body-types (&/map% &&/expr-type =bodies)
- :let [_ (prn 'analyse-case (->> =body-types (&/|map &type/show-type) (&/|interpose " ") (&/fold str "")))]
- =case-type (&/fold% &type/merge (&/V "lux;NothingT" nil) =body-types)
- :let [=branches (&/zip2 (&/|map &/|first branches) =bodies)]]
- (return (&/|list (&/V "Expression" (&/T (&/V "case" (&/T =value base-register max-locals =branches))
- =case-type))))))
+ (|do [:let [num-branches (&/|length ?branches)]
+ _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.")
+ _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.")
+ =value ((analyse-1+ analyse) ?value)
+ =value-type (&&/expr-type =value)
+ =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))]
+ (return (&/|list (&/V "Expression" (&/T (&/V "case" (&/T =value =match))
+ exo-type))))))
(defn analyse-lambda [analyse exo-type ?self ?arg ?body]
;; (prn 'analyse-lambda ?self ?arg ?body)
- (exec [=lambda-type* &type/fresh-lambda]
+ (|do [=lambda-type* &type/fresh-lambda]
(matchv ::M/objects [=lambda-type*]
[["lux;LambdaT" [=arg =return]]]
- (exec [[=scope =captured =body] (&&lambda/with-lambda ?self =lambda-type*
- ?arg =arg
- (&&/analyse-1 analyse ?body))
- =body-type (&&/expr-type =body)
- ;; _ =body-type
- =lambda-type (exec [_ (&type/solve &type/init-fixpoints =return =body-type)]
- (&type/clean =return =lambda-type*))
- =bound-arg (&type/lookup =arg)
- =lambda-type (matchv ::M/objects [=arg =bound-arg]
- [["lux;VarT" id] ["lux;Some" bound]]
- (&type/clean =arg =lambda-type)
-
- [["lux;VarT" id] ["lux;None" _]]
- (let [var-name (str (gensym ""))
- bound (&/V "lux;BoundT" var-name)]
- (exec [_ (&type/reset id bound)
- lambda-type (&type/clean =arg =lambda-type)]
- (return (&/V "lux;AllT" (&/T (&/|list) "" var-name lambda-type))))))
- ;; :let [_ (prn '=lambda-type =lambda-type)]
- ]
+ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self =lambda-type*
+ ?arg =arg
+ (&&/analyse-1 analyse ?body))
+ =body-type (&&/expr-type =body)
+ ;; _ =body-type
+ =lambda-type (|do [_ (&type/check &type/init-fixpoints =return =body-type)]
+ (&type/clean =return =lambda-type*))
+ =bound-arg (&type/lookup =arg)
+ =lambda-type (matchv ::M/objects [=arg =bound-arg]
+ [["lux;VarT" id] ["lux;Some" bound]]
+ (&type/clean =arg =lambda-type)
+
+ [["lux;VarT" id] ["lux;None" _]]
+ (let [var-name (str (gensym ""))
+ bound (&/V "lux;BoundT" var-name)]
+ (|do [_ (&type/reset id bound)
+ lambda-type (&type/clean =arg =lambda-type)]
+ (return (&/V "lux;AllT" (&/T (&/|list) "" var-name lambda-type))))))
+ ;; :let [_ (prn '=lambda-type =lambda-type)]
+ ]
(return (&/|list (&/V "Expression" (&/T (&/V "lambda" (&/T =scope =captured ?arg =body)) =lambda-type))))))))
(defn analyse-def [analyse exo-type ?name ?value]
;; (prn 'analyse-def ?name ?value)
- (exec [_ (&type/solve &type/Nothing exo-type)
- module-name &/get-module-name]
+ (|do [_ (&type/check &type/Nothing exo-type)
+ module-name &/get-module-name]
(&/if% (&&def/defined? module-name ?name)
(fail (str "[Analyser Error] Can't redefine " ?name))
- (exec [=value (&/with-scope ?name
- (&&/with-var
- #(&&/analyse-1 analyse % ?value)))
- =value-type (&&/expr-type =value)
- :let [_ (prn 'analyse-def ?name (&type/show-type =value-type))]
- _ (&&def/define module-name ?name =value-type)]
+ (|do [=value (&/with-scope ?name
+ (&&/with-var
+ #(&&/analyse-1 analyse % ?value)))
+ =value-type (&&/expr-type =value)
+ :let [_ (prn 'analyse-def ?name (&type/show-type =value-type))]
+ _ (&&def/define module-name ?name =value-type)]
(return (&/|list (&/V "Statement" (&/V "def" (&/T ?name =value)))))))))
(defn analyse-declare-macro [exo-type ident]
(|let [[?module ?name] ident]
- (exec [module-name &/get-module-name]
+ (|do [module-name &/get-module-name]
(if (= ?module module-name)
- (exec [_ (&&def/declare-macro ?module ?name)]
+ (|do [_ (&&def/declare-macro ?module ?name)]
(return (&/|list)))
(fail "Can't declare macros from foreign modules.")))))
@@ -228,26 +205,24 @@
(defn analyse-check [analyse eval! exo-type ?type ?value]
(println "analyse-check#0")
- (exec [=type (&&/analyse-1 analyse &type/Type ?type)
+ (|do [=type (&&/analyse-1 analyse &type/Type ?type)
:let [_ (println "analyse-check#1")]
==type (eval! =type)
- _ (&type/solve &type/init-fixpoints exo-type ==type)
+ _ (&type/check &type/init-fixpoints exo-type ==type)
:let [_ (println "analyse-check#4" (&type/show-type ==type))]
=value (&&/analyse-1 analyse ==type ?value)
:let [_ (println "analyse-check#5")]]
(matchv ::M/objects [=value]
[["Expression" [?expr ?expr-type]]]
- (exec [:let [_ (println "analyse-check#6" (&type/show-type ?expr-type))]
- _ (&type/solve &type/init-fixpoints ==type ?expr-type)
+ (|do [:let [_ (println "analyse-check#6" (&type/show-type ?expr-type))]
+ _ (&type/check ==type ?expr-type)
:let [_ (println "analyse-check#7")]]
(return (&/|list (&/V "Expression" (&/T ?expr ==type))))))))
(defn analyse-coerce [analyse eval! exo-type ?type ?value]
- (exec [=type (&&/analyse-1 analyse ?type)
- =type-type (&&/expr-type =type)
- _ (&type/solve &type/init-fixpoints &type/Type =type-type)
+ (|do [=type (&&/analyse-1 analyse &type/Type ?type)
==type (eval! =type)
- =value (&&/analyse-1 analyse ?value)]
+ =value (&&/analyse-1 analyse ==type ?value)]
(matchv ::M/objects [=value]
[["Expression" [?expr ?expr-type]]]
(return (&/|list (&/V "Expression" (&/T ?expr ==type)))))))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index cd5801660..a8649816a 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -151,14 +151,21 @@
[["lux;Left" _]]
inputs))))
-(defmacro exec [steps return]
+(defmacro |do [steps return]
(assert (not= 0 (count steps)) "The steps can't be empty!")
(assert (= 0 (rem (count steps) 2)) "The number of steps must be even!")
(reduce (fn [inner [label computation]]
(case label
- :let `(let ~computation ~inner)
+ :let `(|let ~computation ~inner)
;; else
- `(bind ~computation (fn [~label] ~inner))))
+ ;; `(bind ~computation
+ ;; (fn [val#]
+ ;; (matchv ::M/objects [val#]
+ ;; [~label]
+ ;; ~inner)))
+ `(bind ~computation
+ (fn [~label] ~inner))
+ ))
return
(reverse (partition 2 steps))))
@@ -253,7 +260,7 @@
(return init)
[["lux;Cons" [x xs*]]]
- (exec [init* (f init x)]
+ (|do [init* (f init x)]
(fold% f init* xs*))))
(defn folds [f init xs]
@@ -299,6 +306,14 @@
[["lux;Cons" [[k v] plist*]]]
(|cons k (|keys plist*))))
+(defn |vals [plist]
+ (matchv ::M/objects [plist]
+ [["lux;Nil" _]]
+ (|list)
+
+ [["lux;Cons" [[k v] plist*]]]
+ (|cons v (|vals plist*))))
+
(defn |interpose [sep xs]
(matchv ::M/objects [xs]
[["lux;Nil" _]]
@@ -318,7 +333,7 @@
(return xs)
[["lux;Cons" [x xs*]]]
- (exec [y (f x)
+ (|do [y (f x)
;; :let [_ (prn '<name> 1 (class y))
;; _ (prn '<name> 2 (aget y 0))]
ys (<name> f xs*)]
@@ -351,7 +366,7 @@
"}}"))
(defn if% [text-m then-m else-m]
- (exec [? text-m]
+ (|do [? text-m]
(if ?
then-m
else-m)))
@@ -374,7 +389,7 @@
(fail message)))
(defn comp% [f-m g-m]
- (exec [temp g-m]
+ (|do [temp g-m]
(f-m temp)))
(defn pass [m-value]
@@ -388,7 +403,7 @@
(defn sequence% [m-values]
(matchv ::M/objects [m-values]
[["lux;Cons" [head tail]]]
- (exec [_ head]
+ (|do [_ head]
(sequence% tail))
[_]
@@ -447,13 +462,13 @@
((exhaust% step) state*)
[["lux;Left" msg]]
- ((exec [? source-consumed?]
+ ((|do [? source-consumed?]
(if ?
(return nil)
(fail* msg)))
state)
;; (if (= "[Reader Error] EOF" msg)
- ;; ((exec [? source-consumed?
+ ;; ((|do [? source-consumed?
;; :let [_ (prn '? ?)]]
;; (return nil))
;; state)
@@ -606,7 +621,7 @@
(|list)))
(def get-module-name
- (exec [module get-current-module-env]
+ (|do [module get-current-module-env]
(return (get$ "lux;name" module))))
(defn with-scope [name body]
@@ -620,9 +635,9 @@
output))))
(defn with-closure [body]
- (exec [closure-info (try-all% (|list (exec [top get-top-local-env]
+ (|do [closure-info (try-all% (|list (|do [top get-top-local-env]
(return (T true (->> top (get$ "lux;inner-closures") str))))
- (exec [global get-current-module-env]
+ (|do [global get-current-module-env]
(return (T false (->> global (get$ "lux;inner-closures") str))))))]
(matchv ::M/objects [closure-info]
[[local? closure-name]]
@@ -643,7 +658,7 @@
)))
(def get-scope-name
- (exec [module-name get-module-name]
+ (|do [module-name get-module-name]
(fn [state]
(return* state (->> state (get$ "lux;local-envs") (|map #(get$ "lux;name" %)) |reverse (|cons module-name))))))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index bf724c768..280f27e63 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -5,7 +5,7 @@
[template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return* return fail fail*]]
+ (lux [base :as & :refer [|do return* return fail fail*]]
[type :as &type]
[reader :as &reader]
[lexer :as &lexer]
@@ -70,8 +70,8 @@
[["variant" [?tag ?members]]]
(&&lux/compile-variant compile-expression ?type ?tag ?members)
- [["case" [?variant ?base-register ?num-registers ?branches]]]
- (&&case/compile-case compile-expression ?type ?variant ?base-register ?num-registers ?branches)
+ [["case" [?value ?match]]]
+ (&&case/compile-case compile-expression ?type ?value ?match)
[["lambda" [?scope ?env ?args ?body]]]
(&&lambda/compile-lambda compile-expression ?scope ?env ?args ?body)
@@ -176,8 +176,8 @@
[["jvm-dgt" [?x ?y]]]
(&&host/compile-jvm-dgt compile-expression ?type ?x ?y)
- [["exec" ?exprs]]
- (&&host/compile-exec compile-expression ?type ?exprs)
+ [["|do" ?exprs]]
+ (&&host/compile-|do compile-expression ?type ?exprs)
[["jvm-null" _]]
(&&host/compile-jvm-null compile-expression ?type)
@@ -330,7 +330,7 @@
(defn ^:private eval! [expr]
(prn 'eval! (aget expr 0))
;; (assert false)
- (exec [eval-ctor &/get-eval-ctor
+ (|do [eval-ctor &/get-eval-ctor
:let [class-name (str eval-ctor)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
@@ -338,7 +338,7 @@
(-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil)
(doto (.visitEnd))))]
_ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (.visitCode *writer*)]
_ (compile-expression expr)
:let [_ (doto *writer*
@@ -356,7 +356,7 @@
(.get nil)
return)))
-(let [compiler-step (exec [analysis+ (&optimizer/optimize eval!)
+(let [compiler-step (|do [analysis+ (&optimizer/optimize eval!)
;; :let [_ (prn 'analysis+ analysis+)]
]
(&/map% compile-statement analysis+)
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index eeac182e0..7a75917d0 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -2,7 +2,7 @@
(:require [clojure.string :as string]
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return* return fail fail*]])
+ (lux [base :as & :refer [|do return* return fail fail*]])
[lux.analyser.base :as &a])
(:import (org.objectweb.asm Opcodes
Label
@@ -26,7 +26,7 @@
(.loadClass loader name))
(defn save-class! [name bytecode]
- (exec [loader &/loader
+ (|do [loader &/loader
:let [_ (write-class name bytecode)
_ (load-class! loader (string/replace name #"/" "."))]]
(return nil)))
@@ -109,7 +109,7 @@
[["jvm-drem" [?x ?y]]]
(&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
- [["exec" ?exprs]]
+ [["|do" ?exprs]]
(&/fold max 0 (&/|map total-locals ?exprs))
[["jvm-new" [?class ?classes ?args]]]
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index afa446df0..7fd22dc59 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -3,7 +3,7 @@
[template :refer [do-template]])
[clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return* return fail fail* |let]]
+ (lux [base :as & :refer [|do return* return fail fail* |let]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
@@ -16,75 +16,18 @@
MethodVisitor)))
;; [Utils]
-(defn ^:private ->match [$body register token]
- ;; (prn '->match token)
- ;; (prn '->match (aget token 0))
- (matchv ::M/objects [token]
- [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]]]
- (&/T (inc register) (&/V "Pattern" (&/T $body (&/V "StoreMatch" register))))
-
- [["lux;Meta" [_ ["lux;Bool" ?value]]]]
- (&/T register (&/V "Pattern" (&/T $body (&/V "BoolMatch" ?value))))
-
- [["lux;Meta" [_ ["lux;Int" ?value]]]]
- (&/T register (&/V "Pattern" (&/T $body (&/V "IntMatch" ?value))))
-
- [["lux;Meta" [_ ["lux;Real" ?value]]]]
- (&/T register (&/V "Pattern" (&/T $body (&/V "RealMatch" ?value))))
-
- [["lux;Meta" [_ ["lux;Char" ?value]]]]
- (&/T register (&/V "Pattern" (&/T $body (&/V "CharMatch" ?value))))
-
- [["lux;Meta" [_ ["lux;Text" ?value]]]]
- (&/T register (&/V "Pattern" (&/T $body (&/V "TextMatch" ?value))))
-
- [["lux;Meta" [_ ["lux;Tuple" ?members]]]]
- (|let [[register* =members] (&/fold (fn [register+=members member]
- ;; (prn 'register+=members (alength register+=members))
- (|let [[_register =members] register+=members
- [__register =member] (let [matched (->match $body _register member)]
- ;; (prn 'matched (alength matched))
- matched)]
- (&/T __register (&/|cons =member =members))))
- (&/T register (&/|list))
- ?members)]
- (&/T register* (&/V "Pattern" (&/T $body (&/V "TupleMatch" (&/|reverse =members))))))
-
- [["lux;Meta" [_ ["lux;Tag" [?module ?name]]]]]
- (|let [?tag (str ?module ";" ?name)]
- (&/T register (&/V "Pattern" (&/T $body (&/V "VariantMatch" (&/T ?tag (&/V "Pattern" (&/T $body (&/V "TupleMatch" (&/|list))))))))))
-
- [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" [?module ?name]]]]
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]]]
- (|let [?tag (str ?module ";" ?name)
- [register* =value] (->match $body register ?value)]
- (&/T register* (&/V "Pattern" (&/T $body (&/V "VariantMatch" (&/T ?tag =value))))))
- ))
-
-(defn ^:private process-branches [base-register branches]
- ;; (prn 'process-branches base-register (&/|length branches))
- (|let [[_ mappings pms] (&/fold (fn [$id+mappings+=matches pattern+body]
- (|let [[$id mappings =matches] $id+mappings+=matches
- [pattern body] pattern+body
- [_ =match] (->match $id base-register pattern)]
- (&/T (inc $id) (&/|put $id body mappings) (&/|cons =match =matches))))
- (&/T 0 (&/|table) (&/|list))
- branches)]
- (&/T mappings (&/|reverse pms))))
-
(let [+tag-sig+ (&host/->type-signature "java.lang.String")
+oclass+ (&host/->class "java.lang.Object")
+equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z")]
(defn ^:private compile-match [writer ?match $target $else]
- ;; (prn 'compile-match (aget ?match 0) $target $else)
+ (prn 'compile-match (aget ?match 0) $target $else)
(matchv ::M/objects [?match]
- [["StoreMatch" ?register]]
+ [["StoreTestAC" [?idx ?name ?value]]]
(doto writer
- (.visitVarInsn Opcodes/ASTORE ?register)
+ (.visitVarInsn Opcodes/ASTORE ?idx)
(.visitJumpInsn Opcodes/GOTO $target))
- [["BoolMatch" ?value]]
+ [["BoolTestAC" ?value]]
(doto writer
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Boolean") "booleanValue" "()Z")
@@ -93,7 +36,7 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["IntMatch" ?value]]
+ [["IntTestAC" ?value]]
(doto writer
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Long") "longValue" "()J")
@@ -103,7 +46,7 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["RealMatch" ?value]]
+ [["RealTestAC" ?value]]
(doto writer
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Double") "doubleValue" "()D")
@@ -113,7 +56,7 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["CharMatch" ?value]]
+ [["CharTestAC" ?value]]
(doto writer
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Character") "charValue" "()C")
@@ -122,7 +65,7 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["TextMatch" ?value]]
+ [["TextTestAC" ?value]]
(doto writer
(.visitInsn Opcodes/DUP)
(.visitLdcInsn ?value)
@@ -131,25 +74,25 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["TupleMatch" ?members]]
+ [["TupleTestAC" ?members]]
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(-> (doto (.visitInsn Opcodes/DUP)
(.visitLdcInsn (int idx))
(.visitInsn Opcodes/AALOAD)
- (compile-match member $next $sub-else)
+ (compile-match test $next $sub-else)
(.visitLabel $sub-else)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $else)
(.visitLabel $next))
- (->> (|let [[idx ["Pattern" [_ member]]] idx+member
+ (->> (|let [[idx test] idx+member
$next (new Label)
$sub-else (new Label)])
(doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))])))
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["VariantMatch" [?tag ["Pattern" [_ ?value]]]]]
+ [["VariantTestAC" [?tag ?test]]]
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitInsn Opcodes/DUP)
@@ -161,7 +104,7 @@
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/AALOAD)
- (-> (doto (compile-match ?value $value-then $value-else)
+ (-> (doto (compile-match ?test $value-then $value-else)
(.visitLabel $value-then)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target)
@@ -172,9 +115,21 @@
$value-else (new Label)]))))
)))
+(defn ^:private separate-bodies [matches]
+ (prn 'separate-bodies (aget matches 0))
+ (matchv ::M/objects [matches]
+ [["MatchAC" ?tests]]
+ (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body]
+ (|let [[$id mappings =matches] $id+mappings+=matches
+ [pattern body] pattern+body]
+ (&/T (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches))))
+ (&/T 0 (&/|table) (&/|table))
+ ?tests)]
+ (&/T mappings (&/|reverse patterns*)))))
+
(let [ex-class (&host/->class "java.lang.IllegalStateException")]
(defn ^:private compile-pattern-matching [writer compile mappings patterns $end]
- ;; (prn 'compile-pattern-matching mappings (&/|length patterns) $end)
+ ;; (prn 'compile-pattern-matching ?matches $end)
(let [entries (&/|map (fn [?branch+?body]
(|let [[?branch ?body] ?branch+?body
label (new Label)]
@@ -185,10 +140,11 @@
(doto writer
(-> (doto (compile-match ?match (&/|get ?body mappings*) $else)
(.visitLabel $else))
- (->> (|let [["Pattern" [?body ?match]] ?body+?match])
+ (->> (|let [[?body ?match] ?body+?match])
(doseq [?body+?match (&/->seq patterns)
:let [;; _ (prn 'compile-pattern-matching/pattern pattern)
;; _ (prn '?body+?match (alength ?body+?match) (aget ?body+?match 0))
+ _ (prn '?body+?match (aget ?body+?match 0))
$else (new Label)]])))
(.visitInsn Opcodes/POP)
(.visitTypeInsn Opcodes/NEW ex-class)
@@ -197,23 +153,20 @@
(.visitInsn Opcodes/ATHROW))
(&/map% (fn [?label+?body]
(|let [[?label ?body] ?label+?body]
- (exec [:let [_ (.visitLabel writer ?label)]
- ret (compile ?body)
- :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]]
+ (|do [:let [_ (.visitLabel writer ?label)]
+ ret (compile ?body)
+ :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]]
(return ret))))
(&/|map &/|second entries))
)))
;; [Resources]
-(defn compile-case [compile *type* ?variant ?base-register ?num-registers ?branches]
- ;; (prn 'compile-case ?variant ?base-register ?num-registers (&/|length ?branches))
- (exec [*writer* &/get-writer
- :let [$end (new Label)]
- _ (compile ?variant)]
- (|let [[mappings patterns] (process-branches ?base-register ?branches)
- ;; _ (prn '[(&/|length mappings) (&/|length patterns)] [(&/|length mappings) (&/|length patterns)])
- ]
- (exec [_ (compile-pattern-matching *writer* compile mappings patterns $end)
- :let [_ (.visitLabel *writer* $end)]]
- (return nil)))
- ))
+(defn compile-case [compile *type* ?value ?matches]
+ ;; (prn 'compile-case ?value ?matches)
+ (|do [*writer* &/get-writer
+ :let [$end (new Label)]
+ _ (compile ?value)
+ _ (|let [[mappings patterns] (separate-bodies ?matches)]
+ (compile-pattern-matching *writer* compile mappings patterns $end))
+ :let [_ (.visitLabel *writer* $end)]]
+ (return nil)))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 40ad7bb6d..f289ed6ba 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -4,7 +4,7 @@
[template :refer [do-template]])
[clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return* return fail fail* |let]]
+ (lux [base :as & :refer [|do return* return fail fail* |let]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
@@ -62,7 +62,7 @@
;; [Resources]
(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>]
(defn <name> [compile *type* ?x ?y]
- (exec [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
+ (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
*writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
@@ -104,7 +104,7 @@
(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>]
(defn <name> [compile *type* ?x ?y]
- (exec [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
+ (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
*writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
@@ -132,7 +132,7 @@
(do-template [<name> <cmpcode> <ifcode> <wrapper-class> <value-method> <value-method-sig>]
(defn <name> [compile *type* ?x ?y]
- (exec [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
+ (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
*writer* &/get-writer
_ (compile ?x)
:let [_ (doto *writer*
@@ -168,10 +168,10 @@
)
(defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
_ (&/map% (fn [[class-name arg]]
- (exec [ret (compile arg)
+ (|do [ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
(return ret)))
(map vector ?classes ?args))
@@ -183,13 +183,13 @@
(do-template [<name> <op>]
(defn <name> [compile *type* ?class ?method ?classes ?object ?args]
;; (prn 'compile-jvm-invokevirtual ?classes *type*)
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
_ (compile ?object)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))]
_ (&/map% (fn [class-name+arg]
(|let [[class-name arg] class-name+arg]
- (exec [ret (compile arg)
+ (|do [ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
(return ret))))
(&/zip2 ?classes ?args))
@@ -204,12 +204,12 @@
)
(defn compile-jvm-null [compile *type*]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
(return nil)))
(defn compile-jvm-null? [compile *type* ?object]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?object)
:let [$then (new Label)
$end (new Label)
@@ -223,14 +223,14 @@
(return nil)))
(defn compile-jvm-new [compile *type* ?class ?classes ?args]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [init-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")V")
class* (&host/->class ?class)
_ (doto *writer*
(.visitTypeInsn Opcodes/NEW class*)
(.visitInsn Opcodes/DUP))]
_ (&/map% (fn [[class-name arg]]
- (exec [ret (compile arg)
+ (|do [ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
(return ret)))
(map vector ?classes ?args))
@@ -239,14 +239,14 @@
(return nil)))
(defn compile-jvm-new-array [compile *type* ?class ?length]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (doto *writer*
(.visitLdcInsn (int ?length))
(.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]]
(return nil)))
(defn compile-jvm-aastore [compile *type* ?array ?idx ?elem]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?array)
:let [_ (doto *writer*
(.visitInsn Opcodes/DUP)
@@ -256,7 +256,7 @@
(return nil)))
(defn compile-jvm-aaload [compile *type* ?array ?idx]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?array)
:let [_ (doto *writer*
(.visitLdcInsn (int ?idx))
@@ -264,25 +264,25 @@
(return nil)))
(defn compile-jvm-getstatic [compile *type* ?class ?field]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]]
(return nil)))
(defn compile-jvm-getfield [compile *type* ?class ?field ?object]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?object)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))]
:let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]]
(return nil)))
(defn compile-jvm-putstatic [compile *type* ?class ?field ?value]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?value)
:let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]]
(return nil)))
(defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?object)
_ (compile ?value)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))]
@@ -328,10 +328,10 @@
;; (prn 'SAVED_CLASS full-name)
(&&/save-class! full-name (.toByteArray =interface))))
-(defn compile-exec [compile *type* ?exprs]
- (exec [*writer* &/get-writer
+(defn compile-|do [compile *type* ?exprs]
+ (|do [*writer* &/get-writer
_ (&/map% (fn [expr]
- (exec [ret (compile expr)
+ (|do [ret (compile expr)
:let [_ (.visitInsn *writer* Opcodes/POP)]]
(return ret)))
(butlast ?exprs))
@@ -339,19 +339,19 @@
(return nil)))
(defn compile-jvm-try [compile *type* ?body ?catches ?finally]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [$from (new Label)
$to (new Label)
$end (new Label)
$catch-finally (new Label)
compile-finally (if ?finally
- (exec [_ (return nil)
+ (|do [_ (return nil)
_ (compile ?finally)
:let [_ (doto *writer*
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $end))]]
(return nil))
- (exec [_ (return nil)
+ (|do [_ (return nil)
:let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]]
(return nil)))
_ (.visitLabel *writer* $from)]
@@ -359,7 +359,7 @@
:let [_ (.visitLabel *writer* $to)]
_ compile-finally
handlers (&/map% (fn [[?ex-class ?ex-arg ?catch-body]]
- (exec [:let [$handler-start (new Label)
+ (|do [:let [$handler-start (new Label)
$handler-end (new Label)]
_ (compile ?catch-body)
:let [_ (.visitLabel *writer* $handler-end)]
@@ -368,12 +368,12 @@
?catches)
:let [_ (.visitLabel *writer* $catch-finally)]
_ (if ?finally
- (exec [_ (compile ?finally)
+ (|do [_ (compile ?finally)
:let [_ (doto *writer*
(.visitInsn Opcodes/POP)
(.visitInsn Opcodes/ATHROW))]]
(return nil))
- (exec [_ (return nil)
+ (|do [_ (return nil)
:let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
(return nil)))
:let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]
@@ -387,14 +387,14 @@
(return nil)))
(defn compile-jvm-throw [compile *type* ?ex]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?ex)
:let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
(return nil)))
(do-template [<name> <op>]
(defn <name> [compile *type* ?monitor]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?monitor)
:let [_ (doto *writer*
(.visitInsn <op>)
@@ -407,7 +407,7 @@
(do-template [<name> <op> <from-class> <from-method> <from-sig> <to-class> <to-sig>]
(defn <name> [compile *type* ?value]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW (&host/->class <to-class>))
(.visitInsn Opcodes/DUP))]
@@ -440,7 +440,7 @@
(do-template [<name> <op> <from1-method> <from1-sig> <from1-class> <from2-method> <from2-sig> <from2-class> <to-class> <to-sig>]
(defn <name> [compile *type* ?x ?y]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW (&host/->class <to-class>))
(.visitInsn Opcodes/DUP))]
@@ -466,10 +466,10 @@
)
(defn compile-jvm-program [compile *type* ?body]
- (exec [*writer* &/get-writer]
+ (|do [*writer* &/get-writer]
(&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil)
(.visitCode))
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?body)
:let [_ (doto *writer*
(.visitInsn Opcodes/POP)
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index cce87e978..b914eb87b 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -4,7 +4,7 @@
[template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return* return fail fail*]]
+ (lux [base :as & :refer [|do return* return fail fail*]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
@@ -60,7 +60,7 @@
(defn ^:private add-lambda-impl [class compile impl-signature impl-body]
(&/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil)
(.visitCode))
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [num-locals (&&/total-locals impl-body)
$start (new Label)
$end (new Label)
@@ -78,7 +78,7 @@
(defn ^:private instance-closure [compile lambda-class closed-over init-signature]
;; (prn 'instance-closure lambda-class closed-over init-signature)
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW lambda-class)
(.visitInsn Opcodes/DUP))]
@@ -99,7 +99,7 @@
;; [Exports]
(defn compile-lambda [compile ?scope ?env ?arg ?body]
;; (prn 'compile-lambda ?scope (&host/location ?scope) ?arg ?env)
- (exec [:let [lambda-class (&host/location ?scope)
+ (|do [:let [lambda-class (&host/location ?scope)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)]))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index a761f431a..a12c30531 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -4,7 +4,7 @@
[template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return* return fail fail* |let]]
+ (lux [base :as & :refer [|do return* return fail fail* |let]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
@@ -24,14 +24,14 @@
(let [+class+ (&host/->class "java.lang.Boolean")
+sig+ (&host/->type-signature "java.lang.Boolean")]
(defn compile-bool [compile *type* ?value]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (&host/->type-signature "java.lang.Boolean"))]]
(return nil))))
(do-template [<name> <class> <sig> <caster>]
(let [+class+ (&host/->class <class>)]
(defn <name> [compile *type* value]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW +class+)
(.visitInsn Opcodes/DUP)
@@ -45,19 +45,19 @@
)
(defn compile-text [compile *type* ?value]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (.visitLdcInsn *writer* ?value)]]
(return nil)))
(defn compile-tuple [compile *type* ?elems]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [num-elems (&/|length ?elems)
_ (doto *writer*
(.visitLdcInsn (int num-elems))
(.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))]
_ (&/map% (fn [idx+elem]
(|let [[idx elem] idx+elem]
- (exec [:let [_ (doto *writer*
+ (|do [:let [_ (doto *writer*
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int idx)))]
ret (compile elem)
@@ -67,14 +67,14 @@
(return nil)))
(defn compile-record [compile *type* ?elems]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [num-elems (&/|length ?elems)
_ (doto *writer*
(.visitLdcInsn (int (* 2 num-elems)))
(.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))]
_ (&/map% (fn [idx+kv]
(|let [[idx [k v]] idx+kv]
- (exec [:let [idx* (* 2 idx)
+ (|do [:let [idx* (* 2 idx)
_ (doto *writer*
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int idx*))
@@ -90,7 +90,7 @@
(return nil)))
(defn compile-variant [compile *type* ?tag ?value]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (doto *writer*
(.visitLdcInsn (int 2))
(.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object"))
@@ -105,13 +105,13 @@
(return nil)))
(defn compile-local [compile *type* ?idx]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]]
(return nil)))
(defn compile-captured [compile *type* ?scope ?captured-id ?source]
;; (prn 'compile-captured ?scope ?captured-id)
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (doto *writer*
(.visitVarInsn Opcodes/ALOAD 0)
(.visitFieldInsn Opcodes/GETFIELD
@@ -121,19 +121,19 @@
(return nil)))
(defn compile-global [compile *type* ?owner-class ?name]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]]
(return nil)))
(defn compile-apply [compile *type* ?fn ?arg]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
_ (compile ?fn)
_ (compile ?arg)
:let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]]
(return nil)))
(defn compile-def [compile ?name ?body]
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
module-name &/get-module-name
:let [outer-class (&host/->class module-name)
datum-sig (&host/->type-signature "java.lang.Object")
@@ -146,7 +146,7 @@
(doto (.visitEnd))))]
;; :let [_ (prn 'compile-def/pre-body)]
_ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (exec [*writer* &/get-writer
+ (|do [*writer* &/get-writer
:let [_ (.visitCode *writer*)]
;; :let [_ (prn 'compile-def/pre-body2)]
_ (compile ?body)
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 1dda5de5d..b10b23995 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -3,7 +3,7 @@
[template :refer [do-template]])
[clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return* return fail fail* |let]]
+ (lux [base :as & :refer [|do return* return fail fail* |let]]
[parser :as &parser]
[type :as &type])))
@@ -30,7 +30,7 @@
)))
(defn ^:private method->type [method]
- (exec [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method))))
+ (|do [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method))))
=return (class->type (.getReturnType method))]
(return =return)))
@@ -52,7 +52,7 @@
(defn full-class-name [class-name]
;; (prn 'full-class-name class-name)
- (exec [=class (full-class class-name)]
+ (|do [=class (full-class class-name)]
(return (.getName =class))))
(defn ->class [class]
@@ -104,7 +104,7 @@
[["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "Array"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?inner]]]]
["lux;Nil" _]]]]]]]]]
- (exec [=inner (full-class-name ?inner)]
+ (|do [=inner (full-class-name ?inner)]
(return (str "[L" (->class =inner) ";")))
[_]
@@ -118,7 +118,7 @@
(= field (.getName =field))
(= <static?> (java.lang.reflect.Modifier/isStatic (.getModifiers =field))))]
(.getType =field)))]
- (exec [=type (class->type type*)]
+ (|do [=type (class->type type*)]
(return =type))
(fail (str "[Analyser Error] Field does not exist: " target field)))))
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index 4dc46f41c..cae2fdcaf 100644
--- a/src/lux/lexer.clj
+++ b/src/lux/lexer.clj
@@ -1,6 +1,6 @@
(ns lux.lexer
(:require [clojure.template :refer [do-template]]
- (lux [base :as & :refer [exec return* return fail fail*]]
+ (lux [base :as & :refer [|do return* return fail fail*]]
[reader :as &reader])
[lux.analyser.def :as &def]))
@@ -18,30 +18,30 @@
(fail (str "[Lexer Error] Unknown escape character: " escaped))))
(defn ^:private lex-text-body [_____]
- (&/try-all% (&/|list (exec [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)")
+ (&/try-all% (&/|list (|do [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)")
unescaped (escape-char escaped)
[_ [_ postfix]] (lex-text-body nil)]
(return (str prefix unescaped postfix)))
- (exec [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")]
+ (|do [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")]
(return body)))))
(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)")
;; [Lexers]
(def ^:private lex-white-space
- (exec [[_ [meta white-space]] (&reader/read-regex #"^(\s+)")]
+ (|do [[_ [meta white-space]] (&reader/read-regex #"^(\s+)")]
(return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space))))))
(def ^:private lex-single-line-comment
- (exec [[_ [meta _]] (&reader/read-text "##")
+ (|do [[_ [meta _]] (&reader/read-text "##")
[_ [_ comment]] (&reader/read-regex #"^(.*)$")]
(return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment))))))
(defn ^:private lex-multi-line-comment [___]
- (exec [_ (&reader/read-text "#(")
- [meta comment] (&/try-all% (&/|list (exec [[_ [meta comment]] (&reader/read-regex #"(?is)^((?!#\().)*?(?=\)#)")]
+ (|do [_ (&reader/read-text "#(")
+ [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^((?!#\().)*?(?=\)#)")]
(return comment))
- (exec [[_ [meta pre]] (&reader/read-regex #"(?is)^(.+?(?=#\())")
+ (|do [[_ [meta pre]] (&reader/read-regex #"(?is)^(.+?(?=#\())")
[_ inner] (lex-multi-line-comment nil)
[_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))")]
(return (str pre "#(" inner ")#" post)))))
@@ -55,7 +55,7 @@
(do-template [<name> <tag> <regex>]
(def <name>
- (exec [[_ [meta token]] (&reader/read-regex <regex>)]
+ (|do [[_ [meta token]] (&reader/read-regex <regex>)]
(return (&/V "lux;Meta" (&/T meta (&/V <tag> token))))))
^:private lex-bool "Bool" #"^(true|false)"
@@ -64,30 +64,30 @@
)
(def ^:private lex-char
- (exec [[_ [meta _]] (&reader/read-text "#\"")
- token (&/try-all% (&/|list (exec [escaped (&reader/read-regex #"^(\\.)")]
+ (|do [[_ [meta _]] (&reader/read-text "#\"")
+ token (&/try-all% (&/|list (|do [escaped (&reader/read-regex #"^(\\.)")]
(escape-char escaped))
- (exec [[_ [_ char]] (&reader/read-regex #"^(.)")]
+ (|do [[_ [_ char]] (&reader/read-regex #"^(.)")]
(return char))))
_ (&reader/read-text "\"")]
(return (&/V "lux;Meta" (&/T meta (&/V "Char" token))))))
(def ^:private lex-text
- (exec [[_ [meta _]] (&reader/read-text "\"")
+ (|do [[_ [meta _]] (&reader/read-text "\"")
token (lex-text-body nil)
_ (&reader/read-text "\"")]
(return (&/V "lux;Meta" (&/T meta (&/V "Text" token))))))
(def ^:private lex-ident
- (&/try-all% (&/|list (exec [[_ [meta _]] (&reader/read-text ";")
+ (&/try-all% (&/|list (|do [[_ [meta _]] (&reader/read-text ";")
[_ [_ token]] (&reader/read-regex +ident-re+)]
(return (&/V "lux;Meta" (&/T meta (&/T "lux" token)))))
- (exec [[_ [meta token]] (&reader/read-regex +ident-re+)]
- (&/try-all% (&/|list (exec [_ (&reader/read-text ";")
+ (|do [[_ [meta token]] (&reader/read-regex +ident-re+)]
+ (&/try-all% (&/|list (|do [_ (&reader/read-text ";")
[_ [_ local-token]] (&reader/read-regex +ident-re+)]
- (&/try-all% (&/|list (exec [unaliased (&def/unalias-module token)]
+ (&/try-all% (&/|list (|do [unaliased (&def/unalias-module token)]
(return (&/V "lux;Meta" (&/T meta (&/T unaliased local-token)))))
- (exec [? (&def/module-exists? token)]
+ (|do [? (&def/module-exists? token)]
(if ?
(return (&/V "lux;Meta" (&/T meta (&/T token local-token))))
(fail (str "[Lexer Error] Unknown module: " token))))
@@ -97,17 +97,17 @@
)))
(def ^:private lex-symbol
- (exec [[_ [meta ident]] lex-ident]
+ (|do [[_ [meta ident]] lex-ident]
(return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident))))))
(def ^:private lex-tag
- (exec [[_ [meta _]] (&reader/read-text "#")
+ (|do [[_ [meta _]] (&reader/read-text "#")
[_ [_ ident]] lex-ident]
(return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident))))))
(do-template [<name> <text> <tag>]
(def <name>
- (exec [[_ [meta _]] (&reader/read-text <text>)]
+ (|do [[_ [meta _]] (&reader/read-text <text>)]
(return (&/V "lux;Meta" (&/T meta (&/V <tag> nil))))))
^:private lex-open-paren "(" "Open_Paren"
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index 5c93bfbfb..e50d2aae9 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -11,6 +11,8 @@
;; Avoid (un)boxing: Analyser movement of primitive values to/from functions to known when (un)boxing can be avoided.
;; Pre-compute constant expressions: Find function calls for which all arguments are known at compile-time and pre-calculate everything prior to compilation.
;; Convert pattern-matching on booleans into regular if-then-else structures
+;; Local var aliasing.
+;; Global var aliasing.
;; [Exports]
(defn optimize [eval!]
diff --git a/src/lux/parser.clj b/src/lux/parser.clj
index 71fca764a..a21dd5ba6 100644
--- a/src/lux/parser.clj
+++ b/src/lux/parser.clj
@@ -2,13 +2,13 @@
(:require [clojure.template :refer [do-template]]
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return fail]]
+ (lux [base :as & :refer [|do return fail]]
[lexer :as &lexer])))
;; [Utils]
(do-template [<name> <close-tag> <description> <tag>]
(defn <name> [parse]
- (exec [elems (&/repeat% parse)
+ (|do [elems (&/repeat% parse)
token &lexer/lex]
(matchv ::M/objects [token]
[["lux;Meta" [meta [<close-token> _]]]]
@@ -22,7 +22,7 @@
)
(defn ^:private parse-record [parse]
- (exec [elems* (&/repeat% parse)
+ (|do [elems* (&/repeat% parse)
token &lexer/lex
:let [elems (&/fold &/|++ (&/|list) elems*)]]
(matchv ::M/objects [token]
@@ -36,7 +36,7 @@
;; [Interface]
(def parse
- (exec [token &lexer/lex
+ (|do [token &lexer/lex
;; :let [_ (prn 'parse/token token)]
;; :let [_ (prn 'parse (aget token 0))]
]
@@ -69,15 +69,15 @@
(return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Tag" ?ident)))))
[["lux;Meta" [meta ["Open_Paren" _]]]]
- (exec [syntax (parse-form parse)]
+ (|do [syntax (parse-form parse)]
(return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
[["lux;Meta" [meta ["Open_Bracket" _]]]]
- (exec [syntax (parse-tuple parse)]
+ (|do [syntax (parse-tuple parse)]
(return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
[["lux;Meta" [meta ["Open_Brace" _]]]]
- (exec [syntax (parse-record parse)]
+ (|do [syntax (parse-record parse)]
(return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
[_]
diff --git a/src/lux/reader.clj b/src/lux/reader.clj
index a1e447669..d5d7b453c 100644
--- a/src/lux/reader.clj
+++ b/src/lux/reader.clj
@@ -2,7 +2,7 @@
(:require [clojure.string :as string]
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- [lux.base :as & :refer [exec return* return fail fail* |let]]))
+ [lux.base :as & :refer [|do return* return fail fail* |let]]))
;; [Utils]
(defn ^:private with-line [body]
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 77025b62e..e136e8b5c 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -2,7 +2,7 @@
(:refer-clojure :exclude [deref apply merge])
(:require [clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- [lux.base :as & :refer [exec return* return fail fail* assert! |let]]))
+ [lux.base :as & :refer [|do return* return fail fail* assert! |let]]))
;; [Util]
(def ^:private success (return nil))
@@ -49,7 +49,7 @@
(&/V "lux;VarT" id)))))
(def fresh-lambda
- (exec [=arg fresh-var
+ (|do [=arg fresh-var
=return fresh-var]
(return (&/V "lux;LambdaT" (&/T =arg =return)))))
@@ -59,42 +59,42 @@
(matchv ::M/objects [type]
[["lux;VarT" ?id]]
(if (= ?tid ?id)
- (&/try-all% (&/|list (exec [=type (deref ?id)]
+ (&/try-all% (&/|list (|do [=type (deref ?id)]
(clean tvar =type))
(return type)))
(return type))
[["lux;LambdaT" [?arg ?return]]]
- (exec [=arg (clean tvar ?arg)
+ (|do [=arg (clean tvar ?arg)
=return (clean tvar ?return)]
(return (&/V "lux;LambdaT" (&/T =arg =return))))
[["lux;AppT" [?lambda ?param]]]
- (exec [=lambda (clean tvar ?lambda)
+ (|do [=lambda (clean tvar ?lambda)
=param (clean tvar ?param)]
(return (&/V "lux;AppT" (&/T =lambda =param))))
[["lux;TupleT" ?members]]
- (exec [=members (&/map% (partial clean tvar) ?members)]
+ (|do [=members (&/map% (partial clean tvar) ?members)]
(return (&/V "lux;TupleT" =members)))
[["lux;VariantT" ?members]]
- (exec [=members (&/map% (fn [[k v]]
- (exec [=v (clean tvar v)]
+ (|do [=members (&/map% (fn [[k v]]
+ (|do [=v (clean tvar v)]
(return (&/T k =v))))
?members)]
(return (&/V "lux;VariantT" =members)))
[["lux;RecordT" ?members]]
- (exec [=members (&/map% (fn [[k v]]
- (exec [=v (clean tvar v)]
+ (|do [=members (&/map% (fn [[k v]]
+ (|do [=v (clean tvar v)]
(return (&/T k =v))))
?members)]
(return (&/V "lux;RecordT" =members)))
[["lux;AllT" [?env ?name ?arg ?body]]]
- (exec [=env (&/map% (fn [[k v]]
- (exec [=v (clean tvar v)]
+ (|do [=env (&/map% (fn [[k v]]
+ (|do [=v (clean tvar v)]
(return (&/T k =v))))
?env)]
(return (&/V "lux;AllT" (&/T =env ?name ?arg ?body))))
@@ -113,12 +113,12 @@
"Nothing"
[["lux;DataT" [name params]]]
- (if (&/|empty? params)
- "(,)"
- (str "(^ " name " [" (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) "])"))
-
+ (str "(^ " name " [" (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) "])")
+
[["lux;TupleT" elems]]
- (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")
+ (if (&/|empty? elems)
+ "(,)"
+ (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
[["lux;VariantT" cases]]
(str "(| " (->> cases
@@ -240,7 +240,7 @@
(defn ^:private fp-put [k v fixpoints]
(&/|cons (&/T k v) fixpoints))
-(defn ^:private solve-error [expected actual]
+(defn ^:private check-error [expected actual]
(str "Type " (show-type expected) " does not subsume type " (show-type actual)))
(defn beta-reduce [env type]
@@ -286,15 +286,13 @@
(defn slot-type [record slot]
(fn [state]
- (matchv ::M/objects [(&/|get record slot)]
+ (matchv ::M/objects [(&/|get slot record)]
[["lux;Left" msg]]
(fail* msg)
[["lux;Right" type]]
(return* state type))))
-(def +dont-care+ (&/V "lux;AnyT" nil))
-
(defn apply-type [type-fn param]
;; (prn 'apply-type (aget type-fn 0) (aget param 0))
(matchv ::M/objects [type-fn]
@@ -305,7 +303,7 @@
local-def))
[["lux;AppT" [F A]]]
- (exec [type-fn* (apply-type F A)]
+ (|do [type-fn* (apply-type F A)]
(apply-type type-fn* param))
[_]
@@ -313,9 +311,9 @@
(def init-fixpoints (&/|list))
-(defn ^:private solve* [fixpoints expected actual]
- (prn 'solve* (aget expected 0) (aget actual 0))
- ;; (prn 'solve* (show-type expected) (show-type actual))
+(defn ^:private check* [fixpoints expected actual]
+ (prn 'check* (aget expected 0) (aget actual 0))
+ ;; (prn 'check* (show-type expected) (show-type actual))
(matchv ::M/objects [expected actual]
[["lux;AnyT" _] _]
success
@@ -324,40 +322,40 @@
success
[["lux;VarT" ?id] _]
- (&/try-all% (&/|list (exec [bound (deref ?id)]
- (solve* fixpoints bound actual))
+ (&/try-all% (&/|list (|do [bound (deref ?id)]
+ (check* fixpoints bound actual))
(reset ?id actual)))
[_ ["lux;VarT" ?id]]
- (&/try-all% (&/|list (exec [bound (deref ?id)]
- (solve* fixpoints expected bound))
+ (&/try-all% (&/|list (|do [bound (deref ?id)]
+ (check* fixpoints expected bound))
(reset ?id expected)))
[["lux;AppT" [F A]] _]
- (exec [expected* (apply-type F A)
+ (|do [expected* (apply-type F A)
:let [fp-pair (&/T expected actual)]]
(matchv ::M/objects [(fp-get fp-pair fixpoints)]
[["lux;Some" ?]]
(if ?
success
- (fail (solve-error expected actual)))
+ (fail (check-error expected actual)))
[["lux;None" _]]
- (solve* (fp-put fp-pair true fixpoints) expected* actual)))
+ (check* (fp-put fp-pair true fixpoints) expected* actual)))
[_ ["lux;AppT" [F A]]]
- (exec [actual* (apply-type F A)]
- (solve* fixpoints expected actual*))
+ (|do [actual* (apply-type F A)]
+ (check* fixpoints expected actual*))
[["lux;AllT" _] _]
- (exec [$var fresh-var
+ (|do [$var fresh-var
expected* (apply-type expected $var)]
- (solve* fixpoints expected* actual))
+ (check* fixpoints expected* actual))
[_ ["lux;AllT" _]]
- (exec [$var fresh-var
+ (|do [$var fresh-var
actual* (apply-type actual $var)]
- (solve* fixpoints expected actual*))
+ (check* fixpoints expected actual*))
[["lux;DataT" [e!name e!params]] ["lux;DataT" [a!name a!params]]]
(cond (not= e!name a!name)
@@ -367,22 +365,22 @@
(fail "[Type Error] Params don't match in size.")
:else
- (exec [_ (&/map% (fn [ea]
+ (|do [_ (&/map% (fn [ea]
(|let [[e a] ea]
- (solve* fixpoints e a)))
+ (check* fixpoints e a)))
(&/zip2 e!params a!params))]
success))
[["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]]
- (exec [_ (solve* fixpoints aI eI)]
- (solve* fixpoints eO aO))
+ (|do [_ (check* fixpoints aI eI)]
+ (check* fixpoints eO aO))
[["lux;TupleT" e!members] ["lux;TupleT" a!members]]
(if (= (&/|length e!members) (&/|length a!members))
- (exec [_ (&/map% (fn [ea]
+ (|do [_ (&/map% (fn [ea]
(|let [[e a] ea]
(do ;; (prn "lux;TupleT" 'ITER (show-type e) (show-type a))
- (solve* fixpoints e a))))
+ (check* fixpoints e a))))
(&/zip2 e!members a!members))
;; :let [_ (prn "lux;TupleT" 'DONE)]
]
@@ -395,22 +393,22 @@
(fail "[Type Error] Tuples don't match in size.")))
[["lux;VariantT" e!cases] ["lux;VariantT" a!cases]]
- (exec [_ (&/map% (fn [kv]
+ (|do [_ (&/map% (fn [kv]
(|let [[k av] kv]
(if-let [ev (&/|get k e!cases)]
- (solve* fixpoints ev av)
+ (check* fixpoints ev av)
(fail (str "[Type Error] The expected variant cannot handle case: #" k)))))
a!cases)]
success)
[["lux;RecordT" e!fields] ["lux;RecordT" a!fields]]
(if (= (&/|length e!fields) (&/|length a!fields))
- (exec [_ (&/map% (fn [slot]
+ (|do [_ (&/map% (fn [slot]
(if-let [e!type (&/|get e!fields slot)]
(if-let [a!type (&/|get a!fields slot)]
- (solve* fixpoints e!type a!type)
- (fail (solve-error expected actual)))
- (fail (solve-error expected actual))))
+ (check* fixpoints e!type a!type)
+ (fail (check-error expected actual)))
+ (fail (check-error expected actual))))
(&/|keys e!fields))]
success)
(fail "[Type Error] Records don't match in size."))
@@ -424,16 +422,16 @@
;; ...
))
-(def solve (partial solve* init-fixpoints))
+(def check (partial check* init-fixpoints))
(defn apply-lambda [func param]
(matchv ::M/objects [func]
[["lux;LambdaT" [input output]]]
- (exec [_ (solve* init-fixpoints input param)]
+ (|do [_ (check* init-fixpoints input param)]
(return output))
[["lux;AllT" [local-env local-name local-arg local-def]]]
- (exec [$var fresh-var
+ (|do [$var fresh-var
func* (apply-type func $var)]
(apply-lambda func* param))
@@ -443,8 +441,12 @@
(def Any (&/V "lux;AnyT" nil))
(def Nothing (&/V "lux;NothingT" nil))
+(def Bool (&/V "lux;DataT" (&/T "java.lang.Boolean" (&/|list))))
(def Int (&/V "lux;DataT" (&/T "java.lang.Long" (&/|list))))
+(def Real (&/V "lux;DataT" (&/T "java.lang.Double" (&/|list))))
+(def Char (&/V "lux;DataT" (&/T "java.lang.Character" (&/|list))))
(def Text (&/V "lux;DataT" (&/T "java.lang.String" (&/|list))))
+(def Unit (&/V "lux;TupleT" (&/|list)))
(def List
(&/V "lux;AllT" (&/T (&/|table) "List" "a"
@@ -489,31 +491,55 @@
[["lux;NothingT" _] _]
(return y)
+ [["lux;DataT" [xname xparams]] ["lux;DataT" [yname yparams]]]
+ (if (and (= xname yname)
+ (= (&/|length xparams) (&/|length yparams)))
+ (fail (str "[Type System Error] Can't merge types: " (show-type x) " and " (show-type y)))
+ (|do [xyparams (&/map% (fn [xy]
+ (|let [[xp yp] xy]
+ (merge xp yp)))
+ (&/zip2 xparams yparams))]
+ (return (&/V "lux;DataT" (&/T xname xyparams)))))
+
+ [["lux;TupleT" xmembers] ["lux;TupleT" ymembers]]
+ (if (= (&/|length xmembers) (&/|length ymembers))
+ (fail (str "[Type System Error] Can't merge types: " (show-type x) " and " (show-type y)))
+ (|do [xymembers (&/map% (fn [xy]
+ (|let [[xp yp] xy]
+ (merge xp yp)))
+ (&/zip2 xmembers ymembers))]
+ (return (&/V "lux;TupleT" xymembers))))
+
[["lux;VariantT" x!cases] ["lux;VariantT" y!cases]]
- (exec [cases (&/fold% (fn [cases kv]
- (matchv ::M/objects [kv]
- [[k v]]
- (if-let [cv (&/|get k cases)]
- (exec [_ (solve* init-fixpoints cv v)]
- (return cases))
- (return (&/|put k v cases)))))
- x!cases
- y!cases)]
+ (|do [cases (&/fold% (fn [cases kv]
+ (matchv ::M/objects [kv]
+ [[k v]]
+ (if-let [cv (&/|get k cases)]
+ (|do [v* (merge cv v)]
+ (return (&/|put k v* cases)))
+ (return (&/|put k v cases)))))
+ x!cases
+ y!cases)]
(return (&/V "lux;VariantT" cases)))
[["lux;RecordT" x!fields] ["lux;RecordT" y!fields]]
(if (= (&/|length x!fields) (&/|length y!fields))
- (exec [fields (&/fold% (fn [fields kv]
- (matchv ::M/objects [kv]
- [[k v]]
- (if-let [cv (&/|get k fields)]
- (exec [_ (solve* init-fixpoints cv v)]
- (return fields))
- (fail (str "[Type System Error] Incompatible records: " (show-type x) " and " (show-type y))))))
- x!fields
- y!fields)]
+ (|do [fields (&/fold% (fn [fields kv]
+ (matchv ::M/objects [kv]
+ [[k v]]
+ (if-let [cv (&/|get k fields)]
+ (|do [v* (merge cv v)]
+ (return (&/|put k v* fields)))
+ (fail (str "[Type System Error] Incompatible records: " (show-type x) " and " (show-type y))))))
+ x!fields
+ y!fields)]
(return (&/V "lux;RecordT" fields)))
(fail (str "[Type System Error] Incompatible records: " (show-type x) " and " (show-type y))))
+
+ [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]]
+ (|do [xyinput (check xinput yinput)
+ xyoutput (check xoutput youtput)]
+ (return (&/V "lux;LambdaT" (&/T xyinput xyoutput))))
[_ _]
(fail (str "[Type System Error] Can't merge types: " (show-type x) " and " (show-type y))))))
@@ -524,7 +550,7 @@
(&/V "lux;VariantT" (&/|list (&/T "lux;Nil" (&/V "lux;TupleT" (&/|list)))))))))))
)
- (matchv ::M/objects [((solve Type RealT)
+ (matchv ::M/objects [((check Type RealT)
(&/init-state nil))]
[["lux;Left" ?msg]]
(assert false ?msg)
@@ -532,7 +558,7 @@
[_]
(println "YEAH!"))
- (matchv ::M/objects [((solve List (&/V "lux;AppT" (&/T List Real)))
+ (matchv ::M/objects [((check List (&/V "lux;AppT" (&/T List Real)))
(&/init-state nil))]
[["lux;Left" ?msg]]
(assert false ?msg)
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-25 10:16:26 +0000