aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--README.md23
-rw-r--r--src/lux/analyser.clj4
-rw-r--r--src/lux/analyser/base.clj1
-rw-r--r--src/lux/analyser/case.clj23
-rw-r--r--src/lux/analyser/host.clj140
-rw-r--r--src/lux/analyser/lux.clj4
-rw-r--r--src/lux/analyser/module.clj55
-rw-r--r--src/lux/base.clj7
-rw-r--r--src/lux/compiler.clj9
-rw-r--r--src/lux/compiler/case.clj10
-rw-r--r--src/lux/compiler/host.clj311
-rw-r--r--src/lux/compiler/lux.clj31
-rw-r--r--src/lux/compiler/type.clj4
-rw-r--r--src/lux/host.clj59
-rw-r--r--src/lux/lexer.clj14
-rw-r--r--src/lux/optimizer.clj237
-rw-r--r--src/lux/parser.clj3
-rw-r--r--src/lux/type.clj38
-rw-r--r--src/lux/type/host.clj11
19 files changed, 837 insertions, 147 deletions
diff --git a/README.md b/README.md
index 6cfb3fdaa..9e3b245ac 100644
--- a/README.md
+++ b/README.md
@@ -7,20 +7,14 @@ It's meant to be a functional, statically-typed Lisp that will run on several pl
### What's the current version?
-0.3.3
+0.4.0
### How far ahead is the project?
-The Java-bytecode compiler is feature-complete.
-
-Optimizations and other minor improvements are on the way.
+Lux is finally in the **beta** stage. The JVM compiler is pretty stable and the standard library has grown to a respectable size.
### How can I use it?
-Download the 0.3.3 compiler from here: https://github.com/LuxLang/lux/releases/download/0.3.3/luxc.jar
-
-Once you download the compiler, you'll want to create a directory named "source" in the same directory where the compiler is located.
-
You should use the Leiningen plugin for Lux to compile your programs and manager your dependencies.
You can find it here: https://github.com/LuxLang/lux-lein
@@ -35,8 +29,6 @@ To take a look at a sample Lux project, please take a look at this repository: h
The program in there was actually used to generate most of the documentation for the standard library in the wiki (located over here: https://github.com/LuxLang/lux/wiki/Standard-Library)
-You can also checkout this tutorial, which includes a sample TODO web-app: http://luxlang.blogspot.com/2015/12/lux-tutorial-1-simple-todo-list-using.html
-
### What's the license?
Mozilla Public License v2.0
@@ -87,8 +79,7 @@ Functions are curried and partial application is as simple as just applying a fu
e.g.
- (let [inc (i+ 1)]
- (map inc (list 1 2 3 4 5)))
+ (map (+ 1) (list 1 2 3 4 5))
### Code portability
@@ -122,21 +113,21 @@ But you can also use them to destructure them inside pattern-matching:
(case (: (List Int) (list 1 2 3))
(#Cons x (#Cons y (#Cons z #Nil)))
- (#Some ($ int:* x y z))
+ (#Some ($_ * x y z))
_
#None)
(case (: (List Int) (list 1 2 3))
(\ (list x y z))
- (#Some ($ int:* x y z))
+ (#Some ($_ * x y z))
_
#None)
There is also the special **\or** macro, which introduces *or patterns*:
- (deftype Weekday
+ (type: Weekday
(| #Monday
#Tuesday
#Wednesday
@@ -145,7 +136,7 @@ There is also the special **\or** macro, which introduces *or patterns*:
#Saturday
#Sunday))
- (def (weekend? day)
+ (def: (weekend? day)
(-> Weekday Bool)
(case day
(\or #Saturday #Sunday)
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index d6cc5cfda..2ad3745d8 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -71,6 +71,10 @@
(|do [_ (&type/check exo-type &type/Bool)]
(return (&/|list (&&/|meta exo-type cursor (&&/$bool ?value)))))
+ (&/$NatS ?value)
+ (|do [_ (&type/check exo-type &type/Nat)]
+ (return (&/|list (&&/|meta exo-type cursor (&&/$nat ?value)))))
+
(&/$IntS ?value)
(|do [_ (&type/check exo-type &type/Int)]
(return (&/|list (&&/|meta exo-type cursor (&&/$int ?value)))))
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index fed65bb29..45d111249 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -12,6 +12,7 @@
;; [Tags]
(defvariant
("bool" 1)
+ ("nat" 1)
("int" 1)
("real" 1)
("char" 1)
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 8b1ee3a89..bccbd4a07 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -18,6 +18,7 @@
(defvariant
("DefaultTotal" 1)
("BoolTotal" 2)
+ ("NatTotal" 2)
("IntTotal" 2)
("RealTotal" 2)
("CharTotal" 2)
@@ -29,6 +30,7 @@
("NoTestAC" 0)
("StoreTestAC" 1)
("BoolTestAC" 1)
+ ("NatTestAC" 1)
("IntTestAC" 1)
("RealTestAC" 1)
("CharTestAC" 1)
@@ -265,6 +267,11 @@
=kont kont]
(return (&/T [($BoolTestAC ?value) =kont])))
+ (&/$NatS ?value)
+ (|do [_ (&type/check value-type &type/Nat)
+ =kont kont]
+ (return (&/T [($NatTestAC ?value) =kont])))
+
(&/$IntS ?value)
(|do [_ (&type/check value-type &type/Int)
=kont kont]
@@ -394,6 +401,9 @@
[($BoolTotal total? ?values) ($NoTestAC)]
(return ($BoolTotal true ?values))
+ [($NatTotal total? ?values) ($NoTestAC)]
+ (return ($NatTotal true ?values))
+
[($IntTotal total? ?values) ($NoTestAC)]
(return ($IntTotal true ?values))
@@ -418,6 +428,9 @@
[($BoolTotal total? ?values) ($StoreTestAC ?idx)]
(return ($BoolTotal true ?values))
+ [($NatTotal total? ?values) ($StoreTestAC ?idx)]
+ (return ($NatTotal true ?values))
+
[($IntTotal total? ?values) ($StoreTestAC ?idx)]
(return ($IntTotal true ?values))
@@ -442,6 +455,12 @@
[($BoolTotal total? ?values) ($BoolTestAC ?value)]
(return ($BoolTotal total? (&/$Cons ?value ?values)))
+ [($DefaultTotal total?) ($NatTestAC ?value)]
+ (return ($NatTotal total? (&/|list ?value)))
+
+ [($NatTotal total? ?values) ($NatTestAC ?value)]
+ (return ($NatTotal total? (&/$Cons ?value ?values)))
+
[($DefaultTotal total?) ($IntTestAC ?value)]
(return ($IntTotal total? (&/|list ?value)))
@@ -527,6 +546,10 @@
(return (or ?total
(= #{true false} (set (&/->seq ?values))))))
+ ($NatTotal ?total _)
+ (|do [_ (&type/check value-type &type/Nat)]
+ (return ?total))
+
($IntTotal ?total _)
(|do [_ (&type/check value-type &type/Int)]
(return ?total))
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index be69dc54c..19971d95a 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -34,7 +34,8 @@
(&/|map #(Class/forName % true class-loader)))]
(if-let [missing-ex (&/fold (fn [prev ^Class now]
(or prev
- (cond (.isAssignableFrom java.lang.RuntimeException now)
+ (cond (or (.isAssignableFrom java.lang.RuntimeException now)
+ (.isAssignableFrom java.lang.Error now))
nil
(&/fold (fn [found? ^Class ex-catch]
@@ -464,11 +465,17 @@
^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double"
^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float"
^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer"
+ ^:private analyse-jvm-l2s "l2i" "java.lang.Long" "java.lang.Short"
+ ^:private analyse-jvm-l2b "l2i" "java.lang.Long" "java.lang.Byte"
^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte"
^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short"
^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer"
^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long"
+
+ ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long"
+
+ ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long"
)
(do-template [<name> <proc> <v1-class> <v2-class> <to-class>]
@@ -549,8 +556,8 @@
^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean"
)
-(let [length-type &type/Int
- idx-type &type/Int]
+(let [length-type &type/Nat
+ idx-type &type/Nat]
(do-template [<elem-class> <array-class> <new-name> <new-tag> <load-name> <load-tag> <store-name> <store-tag>]
(let [elem-type (&/$HostT <elem-class> &/$Nil)
array-type (&/$HostT <array-class> &/$Nil)]
@@ -599,8 +606,8 @@
;; else
false)))
-(let [length-type &type/Int
- idx-type &type/Int]
+(let [length-type &type/Nat
+ idx-type &type/Nat]
(defn ^:private analyse-jvm-anewarray [analyse exo-type ?values]
(|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values]
gclass (&reader/with-source "jvm-anewarray" _gclass
@@ -645,7 +652,7 @@
=array (&&/analyse-1+ analyse array)
[arr-class arr-params] (ensure-object (&&/expr-type* =array))
_ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- _ (&type/check exo-type &type/Int)
+ _ (&type/check exo-type &type/Nat)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
(&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list))
@@ -885,8 +892,8 @@
(return (&/|list (&&/|meta output-type _cursor
(&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type)))))))
-(let [length-type &type/Int
- idx-type &type/Int]
+(let [length-type &type/Nat
+ idx-type &type/Nat]
(defn ^:private analyse-array-new [analyse exo-type ?values]
(|do [:let [(&/$Cons length (&/$Nil)) ?values]
:let [gclass (&/$GenericClass "java.lang.Object" (&/|list))
@@ -1008,9 +1015,9 @@
(do-template [<name> <op>]
(defn <name> [analyse exo-type ?values]
(|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values]
- =mask (&&/analyse-1 analyse &type/Int mask)
- =input (&&/analyse-1 analyse &type/Int input)
- _ (&type/check exo-type &type/Int)
+ =mask (&&/analyse-1 analyse &type/Nat mask)
+ =input (&&/analyse-1 analyse &type/Nat input)
+ _ (&type/check exo-type &type/Nat)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
(&&/$proc (&/T ["bit" <op>]) (&/|list =input =mask) (&/|list)))))))
@@ -1022,25 +1029,25 @@
(defn ^:private analyse-bit-count [analyse exo-type ?values]
(|do [:let [(&/$Cons input (&/$Nil)) ?values]
- =input (&&/analyse-1 analyse &type/Int input)
- _ (&type/check exo-type &type/Int)
+ =input (&&/analyse-1 analyse &type/Nat input)
+ _ (&type/check exo-type &type/Nat)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
(&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list)))))))
-(do-template [<name> <op>]
+(do-template [<name> <op> <type>]
(defn <name> [analyse exo-type ?values]
(|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values]
- =shift (&&/analyse-1 analyse &type/Int shift)
- =input (&&/analyse-1 analyse &type/Int input)
- _ (&type/check exo-type &type/Int)
+ =shift (&&/analyse-1 analyse &type/Nat shift)
+ =input (&&/analyse-1 analyse <type> input)
+ _ (&type/check exo-type <type>)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
(&&/$proc (&/T ["bit" <op>]) (&/|list =input =shift) (&/|list)))))))
- ^:private analyse-bit-shift-left "shift-left"
- ^:private analyse-bit-shift-right "shift-right"
- ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right"
+ ^:private analyse-bit-shift-left "shift-left" &type/Nat
+ ^:private analyse-bit-shift-right "shift-right" &type/Int
+ ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat
)
(defn ^:private analyse-lux-== [analyse exo-type ?values]
@@ -1054,6 +1061,68 @@
(return (&/|list (&&/|meta exo-type _cursor
(&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list)))))))))
+(do-template [<name> <proc> <input-type> <output-type>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values]
+ =x (&&/analyse-1 analyse <input-type> x)
+ =y (&&/analyse-1 analyse <input-type> y)
+ _ (&type/check exo-type <output-type>)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta <output-type> _cursor
+ (&&/$proc (&/T ["nat" <proc>]) (&/|list =x =y) (&/|list)))))))
+
+ ^:private analyse-nat-add "add" &type/Nat &type/Nat
+ ^:private analyse-nat-sub "sub" &type/Nat &type/Nat
+ ^:private analyse-nat-mul "mul" &type/Nat &type/Nat
+ ^:private analyse-nat-div "div" &type/Nat &type/Nat
+ ^:private analyse-nat-rem "rem" &type/Nat &type/Nat
+ ^:private analyse-nat-eq "eq" &type/Nat &type/Bool
+ ^:private analyse-nat-lt "lt" &type/Nat &type/Bool
+ )
+
+(defn ^:private analyse-nat-encode [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Nil)) ?values]
+ =x (&&/analyse-1 analyse &type/Nat x)
+ _ (&type/check exo-type &type/Text)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta &type/Text _cursor
+ (&&/$proc (&/T ["nat" "encode"]) (&/|list =x) (&/|list)))))))
+
+(defn ^:private analyse-nat-decode [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Nil)) ?values]
+ =x (&&/analyse-1 analyse &type/Text x)
+ _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta (&/$AppT &type/Maybe &type/Nat) _cursor
+ (&&/$proc (&/T ["nat" "decode"]) (&/|list =x) (&/|list)))))))
+
+(do-template [<name> <type> <op>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Nil) ?values]
+ _ (&type/check exo-type <type>)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta <type> _cursor
+ (&&/$proc (&/T <op>) (&/|list) (&/|list)))))))
+
+ ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"]
+ ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"]
+ )
+
+(do-template [<name> <from-type> <to-type> <op>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Nil)) ?values]
+ =x (&&/analyse-1 analyse <from-type> x)
+ _ (&type/check exo-type <to-type>)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta <to-type> _cursor
+ (&&/$proc (&/T <op>) (&/|list =x) (&/|list)))))))
+
+ ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"]
+ ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"]
+ ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"]
+ ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"]
+ )
+
(defn analyse-host [analyse exo-type compilers category proc ?values]
(|let [[_ _ compile-class compile-interface] compilers]
(case category
@@ -1078,6 +1147,33 @@
"put" (analyse-jvm-aastore analyse exo-type ?values)
"remove" (analyse-array-remove analyse exo-type ?values)
"size" (analyse-jvm-arraylength analyse exo-type ?values))
+
+ "nat"
+ (case proc
+ "+" (analyse-nat-add analyse exo-type ?values)
+ "-" (analyse-nat-sub analyse exo-type ?values)
+ "*" (analyse-nat-mul analyse exo-type ?values)
+ "/" (analyse-nat-div analyse exo-type ?values)
+ "%" (analyse-nat-rem analyse exo-type ?values)
+ "=" (analyse-nat-eq analyse exo-type ?values)
+ "<" (analyse-nat-lt analyse exo-type ?values)
+ "encode" (analyse-nat-encode analyse exo-type ?values)
+ "decode" (analyse-nat-decode analyse exo-type ?values)
+ "min-value" (analyse-nat-min-value analyse exo-type ?values)
+ "max-value" (analyse-nat-max-value analyse exo-type ?values)
+ "to-int" (analyse-nat-to-int analyse exo-type ?values)
+ "to-char" (analyse-nat-to-char analyse exo-type ?values)
+ )
+
+ "int"
+ (case proc
+ "to-nat" (analyse-int-to-nat analyse exo-type ?values)
+ )
+
+ "char"
+ (case proc
+ "to-nat" (analyse-char-to-nat analyse exo-type ?values)
+ )
"jvm"
(case proc
@@ -1162,10 +1258,14 @@
"l2d" (analyse-jvm-l2d analyse exo-type ?values)
"l2f" (analyse-jvm-l2f analyse exo-type ?values)
"l2i" (analyse-jvm-l2i analyse exo-type ?values)
+ "l2s" (analyse-jvm-l2s analyse exo-type ?values)
+ "l2b" (analyse-jvm-l2b analyse exo-type ?values)
"c2b" (analyse-jvm-c2b analyse exo-type ?values)
"c2s" (analyse-jvm-c2s analyse exo-type ?values)
"c2i" (analyse-jvm-c2i analyse exo-type ?values)
"c2l" (analyse-jvm-c2l analyse exo-type ?values)
+ "b2l" (analyse-jvm-b2l analyse exo-type ?values)
+ "s2l" (analyse-jvm-s2l analyse exo-type ?values)
;; else
(->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))
(if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)]
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index c50f26437..b4f87f140 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -268,14 +268,14 @@
(defn ^:private analyse-global [analyse exo-type module name]
(|do [[[r-module r-name] [endo-type ?meta ?value]] (&&module/find-def module name)
+ ;; This is a small shortcut to optimize analysis of typing code.
_ (if (and (clojure.lang.Util/identical &type/Type endo-type)
(clojure.lang.Util/identical &type/Type exo-type))
(return nil)
(&type/check exo-type endo-type))
_cursor &/cursor]
(return (&/|list (&&/|meta endo-type _cursor
- (&&/$var (&/$Global (&/T [r-module r-name])))
- )))))
+ (&&/$var (&/$Global (&/T [r-module r-name]))))))))
(defn ^:private analyse-local [analyse exo-type name]
(fn [state]
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index f35334399..ead4ffc67 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -159,31 +159,44 @@
nil))))
))
+(defn ^:private imports? [state imported-module source-module]
+ (->> state
+ (&/get$ &/$modules)
+ (&/|get source-module)
+ (&/get$ $imports)
+ (&/|any? (partial = imported-module))))
+
(defn find-def [module name]
(|do [current-module &/get-module-name]
(fn [state]
- (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
- (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
- (|let [[?type ?meta ?value] $def]
- (if (.equals ^Object current-module module)
- (|case (&meta/meta-get &meta/alias-tag ?meta)
- (&/$Some (&/$IdentM [?r-module ?r-name]))
- ((find-def ?r-module ?r-name)
- state)
-
- _
- (return* state (&/T [(&/T [module name]) $def])))
- (|case (&meta/meta-get &meta/export?-tag ?meta)
- (&/$Some (&/$BoolM true))
- (return* state (&/T [(&/T [module name]) $def]))
-
- _
- ((&/fail-with-loc (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))
- state))))
- ((&/fail-with-loc (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))
+ (if (or (= "lux" module)
+ (= current-module module)
+ (imports? state module current-module))
+ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
+ (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
+ (|let [[?type ?meta ?value] $def]
+ (if (.equals ^Object current-module module)
+ (|case (&meta/meta-get &meta/alias-tag ?meta)
+ (&/$Some (&/$IdentM [?r-module ?r-name]))
+ ((find-def ?r-module ?r-name)
+ state)
+
+ _
+ (return* state (&/T [(&/T [module name]) $def])))
+ (|case (&meta/meta-get &meta/export?-tag ?meta)
+ (&/$Some (&/$BoolM true))
+ (return* state (&/T [(&/T [module name]) $def]))
+
+ _
+ ((&/fail-with-loc (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))
+ state))))
+ ((&/fail-with-loc (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))
+ state))
+ ((&/fail-with-loc (str "[Analyser Error] Module doesn't exist: " module))
state))
- ((&/fail-with-loc (str "[Analyser Error] Module doesn't exist: " module))
- state)))))
+ ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module))
+ state))
+ )))
(defn ensure-type-def [def-data]
"(-> DefData (Lux Type))"
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 462bccd69..3c4438c63 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -70,6 +70,7 @@
;; AST
(defvariant
("BoolS" 1)
+ ("NatS" 1)
("IntS" 1)
("RealS" 1)
("CharS" 1)
@@ -213,6 +214,7 @@
;; Meta-data
(defvariant
("BoolM" 1)
+ ("NatM" 1)
("IntM" 1)
("RealM" 1)
("CharM" 1)
@@ -1044,6 +1046,9 @@
[_ ($BoolS ?value)]
(pr-str ?value)
+ [_ ($NatS ?value)]
+ (str "+" (Long/toUnsignedString ?value))
+
[_ ($IntS ?value)]
(pr-str ?value)
@@ -1239,7 +1244,7 @@
<default>
($Cons x xs*)
- (<op> (p x) (|every? p xs*))))
+ (<op> (p x) (<name> p xs*))))
|every? true and
|any? false or)
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 4548e71ab..294f2dc63 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -52,6 +52,9 @@
(&o/$bool ?value)
(&&lux/compile-bool ?value)
+ (&o/$nat ?value)
+ (&&lux/compile-nat ?value)
+
(&o/$int ?value)
(&&lux/compile-int ?value)
@@ -91,6 +94,12 @@
(&o/$let _value _register _body)
(&&lux/compile-let (partial compile-expression $begin) _value _register _body)
+ (&o/$record-get _value _path)
+ (&&lux/compile-record-get (partial compile-expression $begin) _value _path)
+
+ (&o/$if _test _then _else)
+ (&&lux/compile-if (partial compile-expression $begin) _test _then _else)
+
(&o/$function ?arity ?scope ?env ?body)
(&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body)
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index 08624d171..4ca543b8e 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -72,6 +72,16 @@
(.visitLdcInsn _value)
(.visitJumpInsn Opcodes/IF_ICMPNE $else))
+ (&o/$NatPM _value)
+ (doto writer
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J")
+ (.visitLdcInsn (long _value))
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFNE $else))
+
(&o/$IntPM _value)
(doto writer
(.visitInsn Opcodes/DUP)
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index ae4b98f9f..cdd17a1ee 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -779,26 +779,109 @@
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
+ (.visitLdcInsn "LOG: ")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V")
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V")
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I
+ (.visitInsn Opcodes/ACONST_NULL) ;; I?
+ (.visitLdcInsn &/unit-tag) ;; I?U
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I
+ (.visitInsn Opcodes/ACONST_NULL) ;; I?
+ (.visitVarInsn Opcodes/ALOAD 0) ;; I?O
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
_ (let [$end (new Label)
- $else (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
+ ;; $then (new Label)
+ $else (new Label)
+ $from (new Label)
+ $to (new Label)
+ $handler (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil)
(.visitCode)
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
- (.visitLdcInsn "LOG: ")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V")
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
(.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V")
+ (.visitLdcInsn "+")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z")
+ (.visitJumpInsn Opcodes/IFEQ $else)
(.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn (int 1))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;")
+ (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
+ (.visitLabel $from)
+ (.visitLdcInsn ",|_")
+ (.visitLdcInsn "")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J")
+ (.visitLabel $to)
+ ;; (.visitJumpInsn Opcodes/GOTO $then)
+ ;; (.visitLabel $then)
+ (&&/wrap-long)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"]))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $handler)
+ (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Exception"]))
+ (.visitInsn Opcodes/POP)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"]))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $else)
+ (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 0 (to-array []))
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitLabel $end)
+ (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"]))
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
_ (doto =class
- (compile-LuxRT-adt-methods)
- (compile-LuxRT-pm-methods))]]
+ (compile-LuxRT-pm-methods)
+ (compile-LuxRT-adt-methods))]]
(&&/save-class! (second (string/split &&/lux-utils-class #"/"))
(.toByteArray (doto =class .visitEnd)))))
+(defn ^:private compile-jvm-try [compile ?values special-args]
+ (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ :let [$from (new Label)
+ $to (new Label)
+ $handler (new Label)
+ $end (new Label)]
+ :let [_ (doto *writer*
+ (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
+ (.visitLabel $from))]
+ _ (compile ?body)
+ :let [_ (doto *writer*
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $to)
+ (.visitLabel $handler))]
+ _ (compile ?catch)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
+ (.visitInsn Opcodes/SWAP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
+ :let [_ (.visitLabel *writer* $end)]]
+ (return nil)))
+
(do-template [<name> <op> <from-class> <from-method> <from-sig> <to-class> <to-sig>]
(defn <name> [compile _?value special-args]
(|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
@@ -814,29 +897,35 @@
(.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) init-method <to-sig>))]]
(return nil)))
- ^:private compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V"
- ^:private compile-jvm-d2i Opcodes/D2I "java.lang.Double" "doubleValue" "()D" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-d2l Opcodes/D2L "java.lang.Double" "doubleValue" "()D" "java.lang.Long" "(J)V"
-
- ^:private compile-jvm-f2d Opcodes/F2D "java.lang.Float" "floatValue" "()F" "java.lang.Double" "(D)V"
- ^:private compile-jvm-f2i Opcodes/F2I "java.lang.Float" "floatValue" "()F" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-f2l Opcodes/F2L "java.lang.Float" "floatValue" "()F" "java.lang.Long" "(J)V"
-
- ^:private compile-jvm-i2b Opcodes/I2B "java.lang.Integer" "intValue" "()I" "java.lang.Byte" "(B)V"
- ^:private compile-jvm-i2c Opcodes/I2C "java.lang.Integer" "intValue" "()I" "java.lang.Character" "(C)V"
- ^:private compile-jvm-i2d Opcodes/I2D "java.lang.Integer" "intValue" "()I" "java.lang.Double" "(D)V"
- ^:private compile-jvm-i2f Opcodes/I2F "java.lang.Integer" "intValue" "()I" "java.lang.Float" "(F)V"
- ^:private compile-jvm-i2l Opcodes/I2L "java.lang.Integer" "intValue" "()I" "java.lang.Long" "(J)V"
- ^:private compile-jvm-i2s Opcodes/I2S "java.lang.Integer" "intValue" "()I" "java.lang.Short" "(S)V"
-
- ^:private compile-jvm-l2d Opcodes/L2D "java.lang.Long" "longValue" "()J" "java.lang.Double" "(D)V"
- ^:private compile-jvm-l2f Opcodes/L2F "java.lang.Long" "longValue" "()J" "java.lang.Float" "(F)V"
- ^:private compile-jvm-l2i Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Integer" "(I)V"
-
- ^:private compile-jvm-c2b Opcodes/I2B "java.lang.Character" "charValue" "()C" "java.lang.Byte" "(B)V"
- ^:private compile-jvm-c2s Opcodes/I2S "java.lang.Character" "charValue" "()C" "java.lang.Short" "(S)V"
- ^:private compile-jvm-c2i Opcodes/NOP "java.lang.Character" "charValue" "()C" "java.lang.Integer" "(I)V"
- ^:private compile-jvm-c2l Opcodes/I2L "java.lang.Character" "charValue" "()C" "java.lang.Long" "(J)V"
+ ^:private compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V"
+ ^:private compile-jvm-d2i Opcodes/D2I "java.lang.Double" "doubleValue" "()D" "java.lang.Integer" "(I)V"
+ ^:private compile-jvm-d2l Opcodes/D2L "java.lang.Double" "doubleValue" "()D" "java.lang.Long" "(J)V"
+
+ ^:private compile-jvm-f2d Opcodes/F2D "java.lang.Float" "floatValue" "()F" "java.lang.Double" "(D)V"
+ ^:private compile-jvm-f2i Opcodes/F2I "java.lang.Float" "floatValue" "()F" "java.lang.Integer" "(I)V"
+ ^:private compile-jvm-f2l Opcodes/F2L "java.lang.Float" "floatValue" "()F" "java.lang.Long" "(J)V"
+
+ ^:private compile-jvm-i2b Opcodes/I2B "java.lang.Integer" "intValue" "()I" "java.lang.Byte" "(B)V"
+ ^:private compile-jvm-i2c Opcodes/I2C "java.lang.Integer" "intValue" "()I" "java.lang.Character" "(C)V"
+ ^:private compile-jvm-i2d Opcodes/I2D "java.lang.Integer" "intValue" "()I" "java.lang.Double" "(D)V"
+ ^:private compile-jvm-i2f Opcodes/I2F "java.lang.Integer" "intValue" "()I" "java.lang.Float" "(F)V"
+ ^:private compile-jvm-i2l Opcodes/I2L "java.lang.Integer" "intValue" "()I" "java.lang.Long" "(J)V"
+ ^:private compile-jvm-i2s Opcodes/I2S "java.lang.Integer" "intValue" "()I" "java.lang.Short" "(S)V"
+
+ ^:private compile-jvm-l2d Opcodes/L2D "java.lang.Long" "longValue" "()J" "java.lang.Double" "(D)V"
+ ^:private compile-jvm-l2f Opcodes/L2F "java.lang.Long" "longValue" "()J" "java.lang.Float" "(F)V"
+ ^:private compile-jvm-l2i Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Integer" "(I)V"
+ ^:private compile-jvm-l2s Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Short" "(S)V"
+ ^:private compile-jvm-l2b Opcodes/L2I "java.lang.Long" "longValue" "()J" "java.lang.Byte" "(B)V"
+
+ ^:private compile-jvm-c2b Opcodes/I2B "java.lang.Character" "charValue" "()C" "java.lang.Byte" "(B)V"
+ ^:private compile-jvm-c2s Opcodes/I2S "java.lang.Character" "charValue" "()C" "java.lang.Short" "(S)V"
+ ^:private compile-jvm-c2i Opcodes/NOP "java.lang.Character" "charValue" "()C" "java.lang.Integer" "(I)V"
+ ^:private compile-jvm-c2l Opcodes/I2L "java.lang.Character" "charValue" "()C" "java.lang.Long" "(J)V"
+
+ ^:private compile-jvm-s2l Opcodes/I2L "java.lang.Short" "shortValue" "()S" "java.lang.Long" "(J)V"
+
+ ^:private compile-jvm-b2l Opcodes/I2L "java.lang.Byte" "byteValue" "()B" "java.lang.Long" "(J)V"
)
(do-template [<name> <op> <from1-method> <from1-sig> <from1-class> <from2-method> <from2-sig> <from2-class> <to-class> <to-sig>]
@@ -1406,6 +1495,133 @@
(.visitLabel $end))]]
(return nil)))
+(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
+ _ (doto *writer*
+ (.visitInsn <opcode>)
+ (<wrap>))]]
+ (return nil)))
+
+ ^:private compile-nat-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long
+ ^:private compile-nat-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
+ ^:private compile-nat-mul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long
+ )
+
+(do-template [<name> <wrapper-class> <value-method> <value-method-sig> <wrap> <comp-method> <comp-sig>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
+ _ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <comp-method> <comp-sig>)
+ (&&/wrap-long))]]
+ (return nil)))
+
+ ^:private compile-nat-div "java.lang.Long" "longValue" "()J" &&/wrap-long "divideUnsigned" "(JJ)J"
+ ^:private compile-nat-rem "java.lang.Long" "longValue" "()J" &&/wrap-long "remainderUnsigned" "(JJ)J"
+ )
+
+(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig> <comp-method> <comp-sig>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
+ $then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ "compareUnsigned" "(JJ)I")
+ (.visitLdcInsn (int <cmp-output>))
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitLabel $end))]]
+ (return nil)))
+
+ ^:private compile-nat-eq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I"
+ ^:private compile-nat-lt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I"
+ )
+
+(defn ^:private compile-nat-encode [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ "toUnsignedString" "(J)Ljava/lang/String;")
+ (.visitLdcInsn "+")
+ (.visitInsn Opcodes/SWAP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]]
+ (return nil)))
+
+(defn ^:private compile-nat-decode [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;"))]]
+ (return nil)))
+
+(do-template [<name> <instr> <wrapper>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Nil) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ <instr>
+ <wrapper>)]]
+ (return nil)))
+
+ ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long
+ ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long
+ )
+
+(do-template [<name>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)]
+ (return nil)))
+
+ ^:private compile-nat-to-int
+ ^:private compile-int-to-nat
+ ^:private compile-nat-to-char
+ ^:private compile-char-to-nat
+ )
+
(defn compile-host [compile proc-category proc-name ?values special-args]
(case proc-category
"lux"
@@ -1425,6 +1641,33 @@
"array"
(case proc-name
"get" (compile-array-get compile ?values special-args))
+
+ "nat"
+ (case proc-name
+ "add" (compile-nat-add compile ?values special-args)
+ "sub" (compile-nat-sub compile ?values special-args)
+ "mul" (compile-nat-mul compile ?values special-args)
+ "div" (compile-nat-div compile ?values special-args)
+ "rem" (compile-nat-rem compile ?values special-args)
+ "eq" (compile-nat-eq compile ?values special-args)
+ "lt" (compile-nat-lt compile ?values special-args)
+ "encode" (compile-nat-encode compile ?values special-args)
+ "decode" (compile-nat-decode compile ?values special-args)
+ "max-value" (compile-nat-max-value compile ?values special-args)
+ "min-value" (compile-nat-min-value compile ?values special-args)
+ "to-int" (compile-nat-to-int compile ?values special-args)
+ "to-char" (compile-nat-to-char compile ?values special-args)
+ )
+
+ "int"
+ (case proc-name
+ "to-nat" (compile-int-to-nat compile ?values special-args)
+ )
+
+ "char"
+ (case proc-name
+ "to-nat" (compile-char-to-nat compile ?values special-args)
+ )
"jvm"
(case proc-name
@@ -1519,10 +1762,14 @@
"l2d" (compile-jvm-l2d compile ?values special-args)
"l2f" (compile-jvm-l2f compile ?values special-args)
"l2i" (compile-jvm-l2i compile ?values special-args)
+ "l2s" (compile-jvm-l2s compile ?values special-args)
+ "l2b" (compile-jvm-l2b compile ?values special-args)
"c2b" (compile-jvm-c2b compile ?values special-args)
"c2s" (compile-jvm-c2s compile ?values special-args)
"c2i" (compile-jvm-c2i compile ?values special-args)
"c2l" (compile-jvm-c2l compile ?values special-args)
+ "s2l" (compile-jvm-s2l compile ?values special-args)
+ "b2l" (compile-jvm-b2l compile ?values special-args)
;; else
(fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 87113b538..ba031eda7 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -45,6 +45,7 @@
(.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]]
(return nil)))
+ compile-nat "java/lang/Long" "(J)V" long
compile-int "java/lang/Long" "(J)V" long
compile-real "java/lang/Double" "(D)V" double
compile-char "java/lang/Character" "(C)V" char
@@ -188,6 +189,36 @@
_ (compile _body)]
(return nil)))
+(defn compile-record-get [compile _value _path]
+ (|do [^MethodVisitor *writer* &/get-writer
+ _ (compile _value)
+ :let [_ (&/|map (fn [step]
+ (|let [[idx tail?] step]
+ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitLdcInsn (int idx))
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT"
+ (if tail? "product_getRight" "product_getLeft")
+ "([Ljava/lang/Object;I)Ljava/lang/Object;"))))
+ _path)]]
+ (return nil)))
+
+(defn compile-if [compile _test _then _else]
+ (|do [^MethodVisitor *writer* &/get-writer
+ _ (compile _test)
+ :let [$else (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ &&/unwrap-boolean
+ (.visitJumpInsn Opcodes/IFEQ $else))]
+ _ (compile _then)
+ :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]
+ :let [_ (.visitLabel *writer* $else)]
+ _ (compile _else)
+ :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)
+ _ (.visitLabel *writer* $end)]]
+ (return nil)))
+
(defn ^:private compile-def-type [compile ?body]
(|do [:let [?def-type (|case ?body
[[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr ?def-value-type)]
diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj
index bf6ec5539..f51165ea3 100644
--- a/src/lux/compiler/type.clj
+++ b/src/lux/compiler/type.clj
@@ -30,6 +30,7 @@
(<tag> value)))
^:private bool$ &a/$bool "(-> Bool Analysis)"
+ ^:private nat$ &a/$nat "(-> Nat Analysis)"
^:private int$ &a/$int "(-> Int Analysis)"
^:private real$ &a/$real "(-> Real Analysis)"
^:private char$ &a/$char "(-> Char Analysis)"
@@ -109,6 +110,9 @@
(&/$BoolM value)
(variant$ #'&/$BoolM (bool$ value))
+ (&/$NatM value)
+ (variant$ #'&/$NatM (nat$ value))
+
(&/$IntM value)
(variant$ #'&/$IntM (int$ value))
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 213a68cea..de8c6cca1 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -88,14 +88,14 @@
(do-template [<name> <static?>]
(defn <name> [class-loader target field]
- (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)]
+ (|let [target-class (Class/forName target true class-loader)]
(if-let [^Type gtype (first (for [^Field =field (seq (.getDeclaredFields target-class))
:when (and (.equals ^Object field (.getName =field))
(.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))]
(.getGenericType =field)))]
(|let [gvars (->> target-class .getTypeParameters seq &/->list)]
(return (&/T [gvars gtype])))
- (fail (str "[Host Error] Field does not exist: " target "." field)))))
+ (&/fail-with-loc (str "[Host Error] Field does not exist: " target "." field)))))
lookup-static-field true
lookup-field false
@@ -103,33 +103,38 @@
(do-template [<name> <static?> <method-type>]
(defn <name> [class-loader target method-name args]
- (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)]
- (if-let [^Method method (first (for [^Method =method (.getDeclaredMethods target-class)
- :when (and (.equals ^Object method-name (.getName =method))
- (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method)))
- (let [param-types (&/->list (seq (.getParameterTypes =method)))]
- (and (= (&/|length args) (&/|length param-types))
- (&/fold2 #(and %1 (.equals ^Object %2 %3))
- true
- args
- (&/|map #(.getName ^Class %) param-types)))))]
- =method))]
- (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list)
- gvars (->> method .getTypeParameters seq &/->list)
- gargs (->> method .getGenericParameterTypes seq &/->list)]
- (return (&/T [(.getGenericReturnType method)
- (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))
- parent-gvars
- gvars
- gargs])))
- (fail (str "[Host Error] " <method-type> " method does not exist: " target "." method-name)))))
+ (|let [target-class (Class/forName target true class-loader)]
+ (if-let [[^Method method ^Class declarer] (first (for [^Method =method (.getMethods target-class)
+ :when (and (.equals ^Object method-name (.getName =method))
+ (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method)))
+ (let [param-types (&/->list (seq (.getParameterTypes =method)))]
+ (and (= (&/|length args) (&/|length param-types))
+ (&/fold2 #(and %1 (.equals ^Object %2 %3))
+ true
+ args
+ (&/|map #(.getName ^Class %) param-types)))))]
+ [=method
+ (.getDeclaringClass =method)]))]
+ (if (= target-class declarer)
+ (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list)
+ gvars (->> method .getTypeParameters seq &/->list)
+ gargs (->> method .getGenericParameterTypes seq &/->list)
+ _ (when (.getAnnotation method java.lang.Deprecated)
+ (println (str "[Host Warning] Deprecated method: " target "." method-name " " (->> args &/->seq print-str))))]
+ (return (&/T [(.getGenericReturnType method)
+ (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))
+ parent-gvars
+ gvars
+ gargs])))
+ (&/fail-with-loc (str "[Host Error] " <method-type> " method " (pr-str method-name) " for " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")" " belongs to parent " (.getName declarer) " instead of " target)))
+ (&/fail-with-loc (str "[Host Error] " <method-type> " method does not exist: " target "." method-name " " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")")))))
lookup-static-method true "Static"
lookup-virtual-method false "Virtual"
)
(defn lookup-constructor [class-loader target args]
- (let [target-class (Class/forName (&host-type/as-obj target) true class-loader)]
+ (let [target-class (Class/forName target true class-loader)]
(if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class)
:when (let [param-types (&/->list (seq (.getParameterTypes =method)))]
(and (= (&/|length args) (&/|length param-types))
@@ -140,14 +145,16 @@
=method))]
(|let [gvars (->> target-class .getTypeParameters seq &/->list)
gargs (->> ctor .getGenericParameterTypes seq &/->list)
- exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))]
+ exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))
+ _ (when (.getAnnotation ctor java.lang.Deprecated)
+ (println (str "[Host Warning] Deprecated constructor: " target " " (->> args &/->seq print-str))))]
(return (&/T [exs gvars gargs])))
- (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target)))))
+ (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target " " (->> args &/->seq print-str))))))
(defn abstract-methods [class-loader super-class]
"(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))"
(|let [[super-name super-params] super-class]
- (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj super-name) true class-loader))
+ (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName super-name true class-loader))
:when (Modifier/isAbstract (.getModifiers =method))]
(&/T [(.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))]))))))
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index 9754456b9..f52823bfc 100644
--- a/src/lux/lexer.clj
+++ b/src/lux/lexer.clj
@@ -15,6 +15,7 @@
("White_Space" 1)
("Comment" 1)
("Bool" 1)
+ ("Nat" 1)
("Int" 1)
("Real" 1)
("Char" 1)
@@ -157,8 +158,16 @@
(return (&/T [meta (<tag> token)]))))
lex-bool $Bool #"^(true|false)"
- lex-int $Int #"^-?(0|[1-9][0-9]*)"
- lex-real $Real #"^-?(0\.[0-9]+|[1-9][0-9]*\.[0-9]+)(e-?[1-9][0-9]*)?"
+ )
+
+(do-template [<name> <tag> <regex>]
+ (def <name>
+ (|do [[meta _ token] (&reader/read-regex <regex>)]
+ (return (&/T [meta (<tag> (string/replace token #",|_" ""))]))))
+
+ lex-nat $Nat #"^\+(0|[1-9][0-9,_]*)"
+ lex-int $Int #"^-?(0|[1-9][0-9,_]*)"
+ lex-real $Real #"^-?(0\.[0-9,_]+|[1-9][0-9,_]*\.[0-9,_]+)(e-?[1-9][0-9,_]*)?"
)
(def lex-char
@@ -233,6 +242,7 @@
lex-comment
lex-bool
lex-real
+ lex-nat
lex-int
lex-char
lex-text
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index c03515370..56a73060c 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -9,7 +9,9 @@
;; [Tags]
(defvariant
+ ;; These tags just have a one-to-one correspondence with Analysis data-structures.
("bool" 1)
+ ("nat" 1)
("int" 1)
("real" 1)
("char" 1)
@@ -24,27 +26,82 @@
("captured" 3)
("proc" 3)
- ;; Purely for optimizations
+ ;; These other tags represent higher-order constructs that manifest
+ ;; themselves as patterns in the code.
+ ;; Lux doesn't formally provide these features, but some macros
+ ;; expose ways to implement them in terms of the other (primitive)
+ ;; features.
+ ;; The optimizer looks for those usage patterns and transforms them
+ ;; into explicit constructs, which are then subject to specialized optimizations.
+
+ ;; This is a loop, as expected in imperative programming.
("loop" 1)
+ ;; This is a simple let-expression, as opposed to the more general pattern-matching.
("let" 3)
+ ;; This is an access to a record's member. It can be multiple level:
+ ;; e.g. record.l1.l2.l3
+ ;; The record-get token stores the path, for simpler compilation.
+ ("record-get" 2)
+ ;; Regular, run-of-the-mill if expressions.
+ ("if" 3)
)
-;; For pattern-matching
+;; [Utils]
+
+;; [[Pattern-Matching Traversal Optimization]]
+
+;; This represents an alternative way to view pattern-matching.
+;; The PM that Lux provides has declarative semantics, with the user
+;; specifying how his data is shaped, but not how to traverse it.
+;; The optimizer's PM is operational in nature, and relies on
+;; specifying a path of traversal, with a variety of operations that
+;; can be done along the way.
+;; The algorithm relies on looking at pattern-matching as traversing a
+;; (possibly) branching path, where each step along the path
+;; corresponds to a value, the ends of the path are the jumping-off
+;; points for the bodies of branches, and branching decisions can be
+;; backtracked, if they don't result in a valid jump.
(defvariant
+ ;; Throw away the current data-node (CDN). It's useless.
("PopPM" 0)
+ ;; Store the CDN in a register.
("BindPM" 1)
+ ;; Compare the CDN with a boolean value.
("BoolPM" 1)
+ ;; Compare the CDN with a natural value.
+ ("NatPM" 1)
+ ;; Compare the CDN with an integer value.
("IntPM" 1)
+ ;; Compare the CDN with a real value.
("RealPM" 1)
+ ;; Compare the CDN with a character value.
("CharPM" 1)
+ ;; Compare the CDN with a text value.
("TextPM" 1)
+ ;; Compare the CDN with a variant value. If valid, proceed to test
+ ;; the variant's inner value.
("VariantPM" 1)
+ ;; Access a tuple value at a given index, for further examination.
("TuplePM" 1)
+ ;; Creates an instance of the backtracking info, as a preparatory
+ ;; step to exploring one of the branching paths.
("AltPM" 2)
+ ;; Allows to test the CDN, while keeping a copy of it for more
+ ;; tasting later on.
+ ;; If necessary when doing multiple tests on a single value, like
+ ;; when testing multiple parts of a tuple.
("SeqPM" 2)
+ ;; This is the jumping-off point for the PM part, where the PM
+ ;; data-structure is thrown away and the program jumps to the
+ ;; branch's body.
("ExecPM" 1))
-;; [Utils]
+;; This function does a simple transformation from the declarative
+;; model of PM of the analyser, to the operational model of PM of the
+;; optimizer.
+;; You may notice that all branches end in PopPM.
+;; The reason is that testing does not immediately imply throwing away
+;; the data to be tested, which is why a popping step must immediately follow.
(defn ^:private transform-pm* [test]
(|case test
(&a-case/$NoTestAC)
@@ -58,6 +115,10 @@
(&/|list ($BoolPM _value)
$PopPM)
+ (&a-case/$NatTestAC _value)
+ (&/|list ($NatPM _value)
+ $PopPM)
+
(&a-case/$IntTestAC _value)
(&/|list ($IntPM _value)
$PopPM)
@@ -83,12 +144,22 @@
(&a-case/$TupleTestAC _sub-tests)
(|case _sub-tests
+ ;; An empty tuple corresponds to unit, which can't be tested in
+ ;; any meaningful way, so it's just popped.
(&/$Nil)
(&/|list $PopPM)
+ ;; A tuple of a single element is equivalent to the element
+ ;; itself, to the element's PM is generated.
(&/$Cons _only-test (&/$Nil))
(transform-pm* _only-test)
+ ;; Single tuple PM features the tests of each tuple member
+ ;; inlined, it's operational equivalent is interleaving the
+ ;; access to each tuple member, followed by the testing of said
+ ;; member.
+ ;; That is way each sequence of access+subtesting gets generated
+ ;; and later they all get concatenated.
_
(|let [tuple-size (&/|length _sub-tests)]
(&/|++ (&/flat-map (fn [idx+test*]
@@ -101,6 +172,15 @@
_sub-tests))
(&/|list $PopPM))))))
+;; It will be common for pattern-matching on a very nested
+;; data-structure to require popping all the intermediate
+;; data-structures that were visited once it's all done.
+;; However, the PM infrastructure employs a single data-stack to keep
+;; all data nodes in the trajectory, and that data-stack can just be
+;; thrown again entirely, in just one step.
+;; Because of that, any ending POPs prior to throwing away the
+;; data-stack would be completely useless.
+;; This function cleans them all up, to avoid wasteful computation later.
(defn ^:private clean-unnecessary-pops [steps]
(|case steps
(&/$Cons ($PopPM) _steps)
@@ -109,11 +189,19 @@
_
steps))
+;; This transforms a single branch of a PM tree into it's operational
+;; equivalent, while also associating the PM of the branch with the
+;; jump to the branch's body.
(defn ^:private transform-pm [test body-id]
(&/fold (fn [right left] ($SeqPM left right))
($ExecPM body-id)
(clean-unnecessary-pops (&/|reverse (transform-pm* test)))))
+;; This function fuses together the paths of the PM traversal, adding
+;; branching AltPMs where necessary, and fusing similar paths together
+;; as much as possible, when early parts of them coincide.
+;; The goal is to minimize rework as much as possible by sharing as
+;; much of each path as possible.
(defn ^:private fuse-pms [pre post]
(|case (&/T [pre post])
[($PopPM) ($PopPM)]
@@ -129,6 +217,11 @@
($BoolPM _pre-value)
($AltPM pre post))
+ [($NatPM _pre-value) ($NatPM _post-value)]
+ (if (= _pre-value _post-value)
+ ($NatPM _pre-value)
+ ($AltPM pre post))
+
[($IntPM _pre-value) ($IntPM _post-value)]
(if (= _pre-value _post-value)
($IntPM _pre-value)
@@ -181,6 +274,8 @@
($AltPM pre post)
))
+;; This is the top-level function for optimizing PM, which transforms
+;; each branch and then fuses them together.
(defn ^:private optimize-pm [branches]
(|let [;; branches (&/|reverse branches*)
bodies (&/|map &/|second branches)
@@ -199,6 +294,36 @@
bodies])
)))
+;; [[Function-Folding Optimization]]
+
+;; The semantics of Lux establish that all functions are of a single
+;; argument and the multi-argument functions are actually nested
+;; functions being generated and then applied.
+;; This, of course, would generate a lot of waste.
+;; To avoid it, Lux actually folds function definitions together,
+;; thereby creating functions that can be used both
+;; one-argument-at-a-time, and also being called with all, or just a
+;; partial amount of their arguments.
+;; This avoids generating too many artifacts during compilation, since
+;; they get "compressed", and it can also lead to faster execution, by
+;; enabling optimized function calls later.
+
+;; Functions and captured variables have "scopes", which tell which
+;; function they are, or to which function they belong.
+;; During the folding, inner functions dissapear, since their bodies
+;; are merged into their outer "parent" functions.
+;; Their scopes must change accordingy.
+(defn ^:private de-scope [old-scope new-scope scope]
+ "(-> Scope Scope Scope Scope)"
+ (if (identical? new-scope scope)
+ old-scope
+ scope))
+
+;; Also, it must be noted that when folding functions, the indexes of
+;; the registers have to be changed accodingly.
+;; That is what the following "shifting" functions are for.
+
+;; Shifts the registers for PM operations.
(defn ^:private shift-pattern [pattern]
(|case pattern
($BindPM _var-id)
@@ -214,12 +339,7 @@
pattern
))
-(defn ^:private de-scope [old-scope new-scope scope]
- "(-> Scope Scope Scope Scope)"
- (if (identical? new-scope scope)
- old-scope
- scope))
-
+;; Shifts the body of a function after a folding is performed.
(defn shift-function-body [old-scope new-scope own-body? body]
"(-> Scope Scope Bool Optimized Optimized)"
(|let [[meta body-] body]
@@ -266,6 +386,7 @@
body)
body)
+ ;; This special "apply" rule is for handling better recursive calls.
($apply [meta-0 ($var (&/$Local 0))] args)
(if own-body?
(&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))])
@@ -300,11 +421,70 @@
(inc _register)
_register)
(shift-function-body old-scope new-scope own-body? _body))])
+
+ ($record-get _value _path)
+ (&/T [meta ($record-get (shift-function-body old-scope new-scope own-body? _value)
+ _path)])
+
+ ($if _test _then _else)
+ (&/T [meta ($if (shift-function-body old-scope new-scope own-body? _test)
+ (shift-function-body old-scope new-scope own-body? _then)
+ (shift-function-body old-scope new-scope own-body? _else))])
_
body
)))
+;; [[Record-Manipulation Optimizations]]
+
+;; If a pattern-matching tree with a single branch is found, and that
+;; branch corresponds to a tuple PM, and the body corresponds to a
+;; local variable, it's likely that the local refers to some member of
+;; the tuple that is being extracted.
+;; That is the pattern that is to be expected of record read-access,
+;; so this function tries to extract the (possibly nested) path
+;; necessary, ending in the data-node of the wanted member.
+(defn ^:private record-read-path [pms member-idx]
+ "(-> (List PM) Idx (List Idx))"
+ (loop [current-idx 0
+ pms pms]
+ (|case pms
+ (&/$Nil)
+ &/$None
+
+ (&/$Cons _pm _pms)
+ (|case _pm
+ (&a-case/$NoTestAC)
+ (recur (inc current-idx)
+ _pms)
+
+ (&a-case/$StoreTestAC _register)
+ (if (= member-idx _register)
+ (&/|list (&/T [current-idx (&/|empty? _pms)]))
+ (recur (inc current-idx)
+ _pms))
+
+ (&a-case/$TupleTestAC _sub-tests)
+ (let [sub-path (record-read-path _sub-tests member-idx)]
+ (if (not (&/|empty? sub-path))
+ (&/$Cons (&/T [current-idx (&/|empty? _pms)]) sub-path)
+ (recur (inc current-idx)
+ _pms)
+ ))
+
+ _
+ (&/|list))
+ )))
+
+;; [[Loop Optimizations]]
+
+;; Lux doesn't offer any looping constructs, relying instead on
+;; recursion.
+;; Some common usages of recursion can be written more efficiently
+;; just using regular loops/iteration.
+;; This optimization looks for tail-calls in the function body,
+;; rewriting them as jumps to the beginning of the function, while
+;; they also updated the necessary local variables for the next iteration.
(defn ^:private optimize-loop [arity optim]
"(-> Int Optimized Optimized)"
(|let [[meta optim-] optim]
@@ -330,6 +510,12 @@
optim
)))
+;; [[Initial Optimization]]
+
+;; Before any big optimization can be done, the incoming Analysis nodes
+;; must be transformed into Optimized nodes, amenable to further transformations.
+;; This function does the job, while also detecting (and optimizing)
+;; some simple surface patterns it may encounter.
(let [optimize-closure (fn [optimize closure]
(&/|map (fn [capture]
(|let [[_name _analysis] capture]
@@ -342,6 +528,9 @@
(&a/$bool value)
(&/T [meta ($bool value)])
+ (&a/$nat value)
+ (&/T [meta ($nat value)])
+
(&a/$int value)
(&/T [meta ($int value)])
@@ -365,9 +554,34 @@
(&a/$case value branches)
(|case branches
+ ;; The pattern for a let-expression is a single branch,
+ ;; tying the value to a register.
(&/$Cons [(&a-case/$StoreTestAC _register) _body] (&/$Nil))
(&/T [meta ($let (pass-0 value) _register (pass-0 _body))])
+ (&/$Cons [(&a-case/$BoolTestAC false) _else]
+ (&/$Cons [(&a-case/$BoolTestAC true) _then]
+ (&/$Nil)))
+ (&/T [meta ($if (pass-0 value) (pass-0 _then) (pass-0 _else))])
+
+ ;; The pattern for a record-get is a single branch, with a
+ ;; tuple pattern and a body corresponding to a
+ ;; local-variable extracted from the tuple.
+ (&/$Cons [(&a-case/$TupleTestAC _sub-tests) [_ (&a/$var (&/$Local _member-idx))]] (&/$Nil))
+ (|let [_path (record-read-path _sub-tests _member-idx)]
+ (if (&/|empty? _path)
+ ;; If the path is empty, that means it was a
+ ;; false-positive and normal PM optimization should be
+ ;; done instead.
+ (&/T [meta ($case (pass-0 value)
+ (optimize-pm (&/|map (fn [branch]
+ (|let [[_pattern _body] branch]
+ (&/T [_pattern (pass-0 _body)])))
+ branches)))])
+ ;; Otherwise, we've got ourselves a record-get expression.
+ (&/T [meta ($record-get (pass-0 value) _path)])))
+
+ ;; If no special patterns are found, just do normal PM optimization.
_
(&/T [meta ($case (pass-0 value)
(optimize-pm (&/|map (fn [branch]
@@ -377,9 +591,14 @@
(&a/$lambda scope captured body)
(|case (pass-0 body)
+ ;; If the body of a function is another function, that means
+ ;; no work was done in-between and both layers can be folded
+ ;; into one.
[_ ($function _arity _scope _captured _body)]
(&/T [meta ($function (inc _arity) scope (optimize-closure pass-0 captured) (shift-function-body scope _scope true _body))])
+ ;; Otherwise, they're nothing to be done and we've got a
+ ;; 1-arity function.
=body
(&/T [meta ($function 1 scope (optimize-closure pass-0 captured) =body)]))
diff --git a/src/lux/parser.clj b/src/lux/parser.clj
index 5b0bfce57..d5b4a54cd 100644
--- a/src/lux/parser.clj
+++ b/src/lux/parser.clj
@@ -76,6 +76,9 @@
(&lexer/$Bool ?value)
(return (&/|list (&/T [meta (&/$BoolS (Boolean/parseBoolean ?value))])))
+ (&lexer/$Nat ?value)
+ (return (&/|list (&/T [meta (&/$NatS (Long/parseUnsignedLong ?value))])))
+
(&lexer/$Int ?value)
(return (&/|list (&/T [meta (&/$IntS (Long/parseLong ?value))])))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index e79cfe46d..a198fabba 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -28,6 +28,7 @@
(def empty-env &/$Nil)
(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)))
+(def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT "#Nat" &/$Nil)))
(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil)))
(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil)))
(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil)))
@@ -91,13 +92,13 @@
TypePair
(&/$SumT
;; BoundT
- Int
+ Nat
(&/$SumT
;; VarT
- Int
+ Nat
(&/$SumT
;; ExT
- Int
+ Nat
(&/$SumT
;; UnivQ
(&/$ProdT TypeList Type)
@@ -120,25 +121,28 @@
;; BoolM
Bool
(&/$SumT
- ;; IntM
- Int
+ ;; NatM
+ Nat
(&/$SumT
- ;; RealM
- Real
+ ;; IntM
+ Int
(&/$SumT
- ;; CharM
- Char
+ ;; RealM
+ Real
(&/$SumT
- ;; TextM
- Text
+ ;; CharM
+ Char
(&/$SumT
- ;; IdentM
- Ident
+ ;; TextM
+ Text
(&/$SumT
- ;; ListM
- (&/$AppT List DefMetaValue)
- ;; DictM
- (&/$AppT List (&/$ProdT Text DefMetaValue)))))))))
+ ;; IdentM
+ Ident
+ (&/$SumT
+ ;; ListM
+ (&/$AppT List DefMetaValue)
+ ;; DictM
+ (&/$AppT List (&/$ProdT Text DefMetaValue))))))))))
)
&/$VoidT))))
diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj
index 1f451bbdd..75825514e 100644
--- a/src/lux/type/host.clj
+++ b/src/lux/type/host.clj
@@ -16,6 +16,7 @@
;; [Exports]
(def array-data-tag "#Array")
(def null-data-tag "#Null")
+(def nat-data-tag "#Nat")
;; [Utils]
(defn ^:private trace-lineage* [^Class super-class ^Class sub-class]
@@ -267,7 +268,15 @@
(and (= array-data-tag e!name)
(not= array-data-tag a!name))
(check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))
-
+
+ (and (= nat-data-tag e!name)
+ (= nat-data-tag a!name))
+ (return fixpoints)
+
+ (or (= nat-data-tag e!name)
+ (= nat-data-tag a!name))
+ (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))
+
:else
(let [e!name (as-obj e!name)
a!name (as-obj a!name)]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 13:27:17 +0000