aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux.clj2
-rw-r--r--src/lux/analyser.clj10
-rw-r--r--src/lux/analyser/base.clj34
-rw-r--r--src/lux/analyser/case.clj25
-rw-r--r--src/lux/analyser/host.clj4
-rw-r--r--src/lux/analyser/lux.clj106
-rw-r--r--src/lux/base.clj38
-rw-r--r--src/lux/compiler.clj8
-rw-r--r--src/lux/compiler/base.clj12
-rw-r--r--src/lux/compiler/case.clj47
-rw-r--r--src/lux/compiler/host.clj31
-rw-r--r--src/lux/compiler/lux.clj21
-rw-r--r--src/lux/host.clj17
-rw-r--r--src/lux/lexer.clj50
-rw-r--r--src/lux/macro.clj1
-rw-r--r--src/lux/type.clj16
16 files changed, 242 insertions, 180 deletions
diff --git a/src/lux.clj b/src/lux.clj
index b0a9a3c94..9f48294c6 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -15,6 +15,8 @@
;; TODO: Take module-name aliasing into account.
;; TODO:
+ ;; Finish total-locals
+
(time (&compiler/compile-all (&/|list "lux")))
(time (&compiler/compile-all (&/|list "lux" "test2")))
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index f9c104378..a4c1a3836 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -53,11 +53,11 @@
[["Tag" ?tag]]
(let [tuple-type (&/V "Tuple" (&/V "Nil" nil))]
- (return (&/|list [&/V "Expression" (&/T (&/V "variant" (&/T ?tag (&/V "Expression" (&/T (&/V "tuple" (&/|list)) tuple-type))))
- (&/V "Variant" (&/V "Cons" (&/T (&/T ?tag tuple-type) (&/V "Nil" nil)))))])))
+ (return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag (&/V "Expression" (&/T (&/V "tuple" (&/|list)) tuple-type))))
+ (&/V "Variant" (&/V "Cons" (&/T (&/T ?tag tuple-type) (&/V "Nil" nil)))))))))
[["Symbol" "jvm-null"]]
- (return (&/|list [&/V "Expression" (&/T (&/V "jvm-null" nil) (&/V "Data" (&/T "null" (&/V "Nil" nil))))]))
+ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-null" nil) (&/V "Data" (&/T "null" (&/V "Nil" nil)))))))
[["Symbol" ?ident]]
(&&lux/analyse-ident analyse ?ident)
@@ -403,12 +403,14 @@
[["Form" ["Cons" [?fn ?args]]]]
(fn [state]
+ (prn '(&/show-ast ?fn) (&/show-ast ?fn))
(matchv ::M/objects [((&&/analyse-1 (analyse-ast eval!) ?fn) state)]
[["Right" [state* =fn]]]
((&&lux/analyse-apply (analyse-ast eval!) =fn ?args) state*)
[_]
- ((analyse-basic-ast (analyse-ast eval!) eval! token) state)))
+ (do (prn 'analyse-ast/token (aget token 0) (&/show-state state))
+ ((analyse-basic-ast (analyse-ast eval!) eval! token) state))))
[_]
(analyse-basic-ast (analyse-ast eval!) eval! token))))
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 256acd346..f67b7e281 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -7,30 +7,34 @@
;; [Resources]
(defn expr-type [syntax+]
;; (prn 'expr-type syntax+)
+ ;; (prn 'expr-type (aget syntax+ 0))
(matchv ::M/objects [syntax+]
[["Expression" [_ type]]]
- (return type)
-
- [_]
- (fail (str "[Analyser Error] Can't retrieve the type of a non-expression: " (pr-str syntax+)))))
+ (do ;; (prn 'expr-type (&type/show-type type))
+ (return type))
+
+ [["Statement" _]]
+ (fail (str "[Analyser Error] Can't retrieve the type of a statement: " (pr-str syntax+)))))
(defn analyse-1 [analyse elem]
(exec [output (analyse elem)]
- (matchv ::M/objects [output]
- [["Cons" [x ["Nil" _]]]]
- (return x)
+ (do ;; (prn 'analyse-1 (aget output 0))
+ (matchv ::M/objects [output]
+ [["Cons" [x ["Nil" _]]]]
+ (return x)
- [_]
- (fail "[Analyser Error] Can't expand to other than 1 element."))))
+ [_]
+ (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))]
- (matchv ::M/objects [output]
- [["Cons" [x ["Cons" [y ["Nil" _]]]]]]
- (return [x y])
+ (exec [output (&/flat-map% analyse (&/|list el1 el2))]
+ (do ;; (prn 'analyse-2 (aget output 0))
+ (matchv ::M/objects [output]
+ [["Cons" [x ["Cons" [y ["Nil" _]]]]]]
+ (return [x y])
- [_]
- (fail "[Analyser Error] Can't expand to other than 2 elements."))))
+ [_]
+ (fail "[Analyser Error] Can't expand to other than 2 elements.")))))
(defn with-var [k]
(exec [=var &type/fresh-var
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 1574218c3..93036daa6 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -1,7 +1,7 @@
(ns lux.analyser.case
(:require [clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- (lux [base :as & :refer [exec return fail]]
+ (lux [base :as & :refer [exec return fail |let]]
[parser :as &parser]
[type :as &type])
(lux.analyser [base :as &&]
@@ -22,14 +22,15 @@
[_]
(&/|list)))
-(defn analyse-branch [analyse max-registers [bindings body]]
- ;; (prn 'analyse-branch max-registers bindings body)
- (reduce (fn [body* name]
- (&&/with-var
- (fn [=var]
- (&env/with-local name =var body*))))
- (reduce (fn [body* _]
- (&env/with-local "" &type/+dont-care+ body*))
- (&&/analyse-1 analyse body)
- (range (- max-registers (count bindings))))
- (reverse bindings)))
+(defn analyse-branch [analyse max-registers bindings+body]
+ (|let [[bindings body] bindings+body]
+ (do (prn 'analyse-branch max-registers (&/|length 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)))))
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 6fff76590..5379b225e 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -99,7 +99,7 @@
(defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args]
(exec [=class (&host/full-class-name ?class)
=classes (&/map% &host/extract-jvm-param ?classes)
- =return (&host/lookup-virtual-method =class ?method =classes)
+ =return (&host/lookup-static-method =class ?method =classes)
=args (&/flat-map% analyse ?args)]
(return (&/|list (&/V "Expression" (&/T (&/V "jvm-invokestatic" (&/T =class ?method =classes =args)) =return))))))
@@ -109,7 +109,7 @@
;; :let [_ (prn 'analyse-jvm-invokevirtual/=class =class)]
=classes (&/map% &host/extract-jvm-param ?classes)
;; :let [_ (prn 'analyse-jvm-invokevirtual/=classes =classes)]
- [=method-args =return] (&host/lookup-virtual-method =class ?method =classes)
+ =return (&host/lookup-virtual-method =class ?method =classes)
;; :let [_ (prn 'analyse-jvm-invokevirtual/=return =return)]
=object (&&/analyse-1 analyse ?object)
;; :let [_ (prn 'analyse-jvm-invokevirtual/=object =object)]
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index daec2bd0a..edf707adc 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -38,18 +38,23 @@
]
(return (&/|list (&/V "Expression" (&/T (&/V "record" =elems) (&/V "Record" =elems-types)))))))
+(defn ^:private resolve-global [ident state]
+ (if-let [global (->> state (&/get$ "global-env") &/from-some (&/get$ "locals") (&/get$ "mappings") (&/|get ident))]
+ (return* state (&/|list global))
+ (fail* (str "[Analyser Error] Unresolved identifier: " ident))))
+
(defn analyse-ident [analyse ident]
- (prn 'analyse-ident ident)
+ ;; (prn 'analyse-ident ident)
(exec [module-name &/get-module-name]
(fn [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))
+ ;; (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$ "local-envs" state)]
- (matchv ::M/objects [(&/get$ "local-envs" state)]
+ (matchv ::M/objects [stack]
[["Nil" _]]
- (fail* (str "[Analyser Error] Unresolved identifier: " ident))
+ (resolve-global ident state)
[["Cons" [top stack*]]]
(if-let [=bound (or (->> stack &/|head (&/get$ "locals") (&/get$ "mappings") (&/|get ident))
@@ -58,48 +63,49 @@
(|let [no-binding? #(and (->> % (&/get$ "locals") (&/get$ "mappings") (&/|contains? ident) not)
(->> % (&/get$ "closure") (&/get$ "mappings") (&/|contains? ident) not))
[inner outer] (&/|split-with no-binding? stack*)]
- (matchv ::M/objects [outer]
- [["Nil" _]]
- (if-let [global (->> state (&/get$ "global-env") &/from-some (&/get$ "locals") (&/get$ "mappings") (&/|get ident))]
- (return* state (&/|list global))
- (fail* (str "[Analyser Error] Unresolved identifier: " ident)))
-
- [["Cons" [top-outer _]]]
- (let [in-stack (&/|cons top inner)
- scopes (&/|tail (&/folds #(&/|cons (&/get$ "name" %2) %1)
- (&/|map #(&/get$ "name" %) outer)
- (&/|reverse in-stack)))
- _ (prn 'in-stack module-name ident (&/->seq (&/|map #(&/get$ "name" %) in-stack)) 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)) ident register frame)]
- (&/T register* (&/|cons frame* new-inner))))
- (&/T (or (->> top-outer (&/get$ "locals") (&/get$ "mappings") (&/|get ident))
- (->> top-outer (&/get$ "closure") (&/get$ "mappings") (&/|get ident)))
- (&/|list))
- (&/zip2 (&/|reverse in-stack) scopes))]
- (return* (&/set$ "local-envs" (&/|++ inner* outer) state) (&/|list =local)))
- )))
+ (matchv ::M/objects [outer]
+ [["Nil" _]]
+ (resolve-global ident state)
+
+ [["Cons" [top-outer _]]]
+ (let [in-stack (&/|cons top inner)
+ scopes (&/|tail (&/folds #(&/|cons (&/get$ "name" %2) %1)
+ (&/|map #(&/get$ "name" %) outer)
+ (&/|reverse in-stack)))
+ ;; _ (prn 'in-stack module-name ident (&/->seq (&/|map #(&/get$ "name" %) in-stack)) 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)) ident register frame)]
+ (&/T register* (&/|cons frame* new-inner))))
+ (&/T (or (->> top-outer (&/get$ "locals") (&/get$ "mappings") (&/|get ident))
+ (->> top-outer (&/get$ "closure") (&/get$ "mappings") (&/|get ident)))
+ (&/|list))
+ (&/zip2 (&/|reverse in-stack) scopes))]
+ (return* (&/set$ "local-envs" (&/|++ inner* outer) state) (&/|list =local)))
+ )))
))
)))
(defn ^:private analyse-apply* [analyse =fn ?args]
(exec [=args (&/flat-map% analyse ?args)
=fn-type (&&/expr-type =fn)
- =apply+=apply-type (&/fold (fn [[=fn =fn-type] =input]
- (exec [=input-type (&&/expr-type =input)
- =output-type (&type/apply-lambda =fn-type =input-type)]
- (return [(&/V "apply" (&/T =fn =input)) =output-type])))
- [=fn =fn-type]
- =args)
- :let [[=apply =apply-type] (matchv ::M/objects [=apply+=apply-type]
- [[=apply =apply-type]]
- [=apply =apply-type])]]
- (return (&/|list (&/V "Expression" (&/T =apply =apply-type))))))
+ [=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)]
+ (return (&/|list =apply))))
(defn analyse-apply [analyse =fn ?args]
- (prn 'analyse-apply (aget =fn 0))
+ ;; (prn 'analyse-apply (aget =fn 0))
(exec [loader &/loader]
(matchv ::M/objects [=fn]
[["Expression" [=fn-form =fn-type]]]
@@ -121,11 +127,15 @@
))
(defn analyse-case [analyse ?value ?branches]
- ;; (prn 'analyse-case ?value ?branches)
- (exec [:let [num-branches (&/|length ?branches)]
+ (prn 'analyse-case (aget ?branches 0) (aget ?branches 1 1 0)
+ (&/->seq ?branches))
+ (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])]
@@ -138,9 +148,10 @@
;; :let [_ (prn '=bodies =bodies)]
;; :let [_ (prn 'analyse-case/=bodies =bodies)]
=body-types (&/map% &&/expr-type =bodies)
- :let [=case-type (&/fold &type/merge (&/|table) =body-types)]
+ =case-type (&/fold% &type/merge (&/V "Nothing" 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))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "case" (&/T =value base-register max-locals =branches))
+ =case-type))))))
(defn analyse-lambda [analyse ?self ?arg ?body]
(exec [=lambda-type* &type/fresh-lambda]
@@ -150,9 +161,12 @@
?arg =arg
(&&/analyse-1 analyse ?body))
=body-type (&&/expr-type =body)
+ ;; _ =body-type
=lambda-type (exec [_ (&type/solve =return =body-type)
=lambda-type** (&type/clean =return =lambda-type*)]
- (&type/clean =arg =lambda-type**))]
+ (&type/clean =arg =lambda-type**))
+ ;; :let [_ (prn '=lambda-type =lambda-type)]
+ ]
(return (&/|list (&/V "Expression" (&/T (&/V "lambda" (&/T =scope =captured ?arg =body)) =lambda-type))))))))
(defn analyse-get [analyse ?slot ?record]
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 74b1a6d9e..661451714 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -58,7 +58,7 @@
(reduce (fn [tail head]
`(V "Cons" (T ~head ~tail)))
`(V "Nil" nil)
- elems))
+ (reverse elems)))
(defmacro |table [& elems]
(reduce (fn [table [k v]]
@@ -67,7 +67,7 @@
(partition 2 elems)))
(defn |get [slot table]
- (prn '|get slot (aget table 0))
+ ;; (prn '|get slot (aget table 0))
(matchv ::M/objects [table]
[["Nil" _]]
nil
@@ -88,7 +88,7 @@
(V "Cons" (T (T k v) (|put slot value table*))))))
(defn |merge [table1 table2]
- (prn '|merge (aget table1 0) (aget table2 0))
+ ;; (prn '|merge (aget table1 0) (aget table2 0))
(matchv ::M/objects [table2]
[["Nil" _]]
table1
@@ -168,7 +168,7 @@
(V "Cons" (T head tail)))
(defn |++ [xs ys]
- (prn '|++ (and xs (aget xs 0)) (and ys (aget ys 0)))
+ ;; (prn '|++ (and xs (aget xs 0)) (and ys (aget ys 0)))
(matchv ::M/objects [xs]
[["Nil" _]]
ys
@@ -220,6 +220,15 @@
[["Cons" [x xs*]]]
(fold f (f init x) xs*)))
+(defn fold% [f init xs]
+ (matchv ::M/objects [xs]
+ [["Nil" _]]
+ (return init)
+
+ [["Cons" [x xs*]]]
+ (exec [init* (f init x)]
+ (fold% f init* xs*))))
+
(defn folds [f init xs]
(matchv ::M/objects [xs]
[["Nil" _]]
@@ -229,7 +238,7 @@
(|cons init (folds f (f init x) xs*))))
(defn |length [xs]
- (prn '|length (aget xs 0))
+ ;; (prn '|length (aget xs 0))
(fold (fn [acc _] (inc acc)) 0 xs))
(let [|range* (fn |range* [from to]
@@ -290,7 +299,7 @@
(defn |as-pairs [xs]
(matchv ::M/objects [xs]
- [["Cons" [x [["Cons" [y xs*]]]]]]
+ [["Cons" [x ["Cons" [y xs*]]]]]
(V "Cons" (T (T x y) (|as-pairs xs*)))
[_]
@@ -302,6 +311,15 @@
(|list)
xs))
+(defn show-table [table]
+ (prn 'show-table (aget table 0))
+ (str "{{"
+ (->> table
+ (|map (fn [kv] (|let [[k v] kv] (str k " = ???"))))
+ (|interpose " ")
+ (fold str ""))
+ "}}"))
+
(defn if% [text-m then-m else-m]
(exec [? text-m]
(if ?
@@ -469,7 +487,7 @@
(str "#" slot " " (case slot
"source" "???"
"modules" "???"
- "global-env" "???"
+ "global-env" (->> value from-some (get$ "locals") (get$ "mappings") show-table)
"local-envs" (|length value)
"types" "???"
"writer" "???"
@@ -486,8 +504,8 @@
(def get-writer
(fn [state]
(let [writer* (get$ "writer" state)]
- (prn 'get-writer (class writer*))
- (prn 'get-writer (aget writer* 0))
+ ;; (prn 'get-writer (class writer*))
+ ;; (prn 'get-writer (aget writer* 0))
(matchv ::M/objects [writer*]
[["Some" datum]]
(return* state datum)
@@ -502,7 +520,7 @@
(def get-current-module-env
(fn [state]
(let [global-env* (get$ "global-env" state)]
- (prn 'get-current-module-env (aget global-env* 0))
+ ;; (prn 'get-current-module-env (aget global-env* 0))
(matchv ::M/objects [global-env*]
[["Some" datum]]
(return* state datum)
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 1489cceb2..586727b15 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -28,10 +28,10 @@
;; [Utils/Compilers]
(defn ^:private compile-expression [syntax]
- (prn 'compile-expression (aget syntax 0))
+ ;; (prn 'compile-expression (aget syntax 0))
(matchv ::M/objects [syntax]
[["Expression" [?form ?type]]]
- (do (prn 'compile-expression2 (aget ?form 0))
+ (do ;; (prn 'compile-expression2 (aget ?form 0))
(matchv ::M/objects [?form]
[["bool" ?value]]
(&&lux/compile-bool compile-expression ?type ?value)
@@ -63,8 +63,8 @@
[["global" [?owner-class ?name]]]
(&&lux/compile-global compile-expression ?type ?owner-class ?name)
- [["call" [?fn ?args]]]
- (&&lux/compile-call compile-expression ?type ?fn ?args)
+ [["apply" [?fn ?arg]]]
+ (&&lux/compile-apply compile-expression ?type ?fn ?arg)
[["variant" [?tag ?members]]]
(&&lux/compile-variant compile-expression ?type ?tag ?members)
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 09fc811d8..7fcda55a3 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -32,10 +32,10 @@
(return nil)))
(defn total-locals [expr]
- (prn 'total-locals1 (aget expr 0))
+ ;; (prn 'total-locals1 (aget expr 0))
(matchv ::M/objects [expr]
[["Expression" [?struct ?type]]]
- (do (prn 'total-locals2 (aget ?struct 0))
+ (do ;; (prn 'total-locals2 (aget ?struct 0))
(matchv ::M/objects [?struct]
[["case" [?variant ?base-register ?num-registers ?branches]]]
(+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches)))
@@ -127,9 +127,9 @@
[["jvm-aaload" [?array ?idx]]]
(total-locals ?array)
- [["lambda" _]]
- 0
-
- ;; [_]
+ ;; [["lambda" _]]
;; 0
+
+ [_]
+ 0
))))
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index 336d0c645..22349bbca 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -17,48 +17,51 @@
;; [Utils]
(defn ^:private ->match [$body register token]
- (prn '->match token)
- (prn '->match (aget token 0))
+ ;; (prn '->match token)
+ ;; (prn '->match (aget token 0))
(matchv ::M/objects [token]
[["Symbol" ?name]]
- (&/T (inc register) (&/V "Pattern" (&/T $body [&/V "StoreMatch" register])))
+ (&/T (inc register) (&/V "Pattern" (&/T $body (&/V "StoreMatch" register))))
[["Bool" ?value]]
- (&/T register (&/V "Pattern" (&/T $body [&/V "BoolMatch" ?value])))
+ (&/T register (&/V "Pattern" (&/T $body (&/V "BoolMatch" ?value))))
[["Int" ?value]]
- (&/T register (&/V "Pattern" (&/T $body [&/V "IntMatch" ?value])))
+ (&/T register (&/V "Pattern" (&/T $body (&/V "IntMatch" ?value))))
[["Real" ?value]]
- (&/T register (&/V "Pattern" (&/T $body [&/V "RealMatch" ?value])))
+ (&/T register (&/V "Pattern" (&/T $body (&/V "RealMatch" ?value))))
[["Char" ?value]]
- (&/T register (&/V "Pattern" (&/T $body [&/V "CharMatch" ?value])))
+ (&/T register (&/V "Pattern" (&/T $body (&/V "CharMatch" ?value))))
[["Text" ?value]]
- (&/T register (&/V "Pattern" (&/T $body [&/V "TextMatch" ?value])))
+ (&/T register (&/V "Pattern" (&/T $body (&/V "TextMatch" ?value))))
[["Tuple" ?members]]
- (|let [[register* =members] (&/fold (fn [[register =members] member]
- (|let [[register* =member] (->match $body register member)]
- (&/T register* (&/|cons =member =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)]))))
+ (&/T register* (&/V "Pattern" (&/T $body (&/V "TupleMatch" (&/|reverse =members))))))
[["Tag" ?tag]]
- (&/T register (&/V "Pattern" (&/T $body [&/V "VariantMatch" (&/T ?tag [&/V "Pattern" (&/T $body [&/V "TupleMatch" (list)])])])))
+ (&/T register (&/V "Pattern" (&/T $body (&/V "VariantMatch" (&/T ?tag (&/V "Pattern" (&/T $body (&/V "TupleMatch" (&/|list)))))))))
[["Form" ["Cons" [["Tag" ?tag]
["Cons" [?value
["Nil" _]]]]]]]
(|let [[register* =value] (->match $body register ?value)]
-
- (&/T register* (&/V "Pattern" (&/T $body [&/V "VariantMatch" (&/T ?tag =value)]))))
+ (&/T register* (&/V "Pattern" (&/T $body (&/V "VariantMatch" (&/T ?tag =value))))))
))
(defn ^:private process-branches [base-register branches]
- (prn '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
@@ -72,6 +75,7 @@
+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)
(matchv ::M/objects [?match]
[["StoreMatch" ?register]]
(doto writer
@@ -136,7 +140,7 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $else)
(.visitLabel $next))
- (->> (|let [[idx [_ _ member]] idx+member
+ (->> (|let [[idx ["Pattern" [_ member]]] idx+member
$next (new Label)
$sub-else (new Label)])
(doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))])))
@@ -168,7 +172,7 @@
(let [ex-class (&host/->class "java.lang.IllegalStateException")]
(defn ^:private compile-pattern-matching [writer compile mappings patterns $end]
- (prn 'compile-pattern-matching mappings patterns $end)
+ ;; (prn 'compile-pattern-matching mappings (&/|length patterns) $end)
(let [entries (&/|map (fn [?branch+?body]
(|let [[?branch ?body] ?branch+?body
label (new Label)]
@@ -179,9 +183,10 @@
(doto writer
(-> (doto (compile-match ?match (&/|get ?body mappings*) $else)
(.visitLabel $else))
- (->> (|let [[_ ?body ?match] ?body+?match])
+ (->> (|let [["Pattern" [?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))
$else (new Label)]])))
(.visitInsn Opcodes/POP)
(.visitTypeInsn Opcodes/NEW ex-class)
@@ -199,10 +204,12 @@
;; [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)]
+ (|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)))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index c14924efd..09e772ff8 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*]]
+ (lux [base :as & :refer [exec return* return fail fail* |let]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
@@ -171,10 +171,10 @@
(exec [*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)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- (map vector ?classes ?args))
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (map vector ?classes ?args))
:let [_ (doto *writer*
(.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig)
(prepare-return! *type*))]]
@@ -184,14 +184,15 @@
(defn <name> [compile *type* ?class ?method ?classes ?object ?args]
;; (prn 'compile-jvm-invokevirtual ?classes *type*)
(exec [*writer* &/get-writer
- :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
+ :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]]
- (exec [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- (map vector ?classes ?args))
+ _ (&/map% (fn [class-name+arg]
+ (|let [[class-name arg] class-name+arg]
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret))))
+ (&/zip2 ?classes ?args))
:let [_ (doto *writer*
(.visitMethodInsn <op> (&host/->class ?class) ?method method-sig)
(prepare-return! *type*))]]
@@ -229,10 +230,10 @@
(.visitTypeInsn Opcodes/NEW class*)
(.visitInsn Opcodes/DUP))]
_ (&/map% (fn [[class-name arg]]
- (exec [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- (map vector ?classes ?args))
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (map vector ?classes ?args))
:let [_ (doto *writer*
(.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
(return nil)))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 22018808a..c1763818d 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -13,7 +13,8 @@
[lux.analyser.base :as &a]
(lux.compiler [base :as &&]
[lambda :as &&lambda])
- :reload)
+ ;; :reload
+ )
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -124,14 +125,11 @@
:let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]]
(return nil)))
-(defn compile-call [compile *type* ?fn ?args]
+(defn compile-apply [compile *type* ?fn ?arg]
(exec [*writer* &/get-writer
_ (compile ?fn)
- _ (&/map% (fn [arg]
- (exec [ret (compile arg)
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]]
- (return ret)))
- ?args)]
+ _ (compile ?arg)
+ :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]]
(return nil)))
(defn compile-get [compile *type* ?slot ?record]
@@ -239,7 +237,7 @@
current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)]))
(-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil)
(doto (.visitEnd))))]
- :let [_ (prn 'compile-def/pre-body)]
+ ;; :let [_ (prn 'compile-def/pre-body)]
_ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
(exec [*writer* &/get-writer
:let [_ (.visitCode *writer*)]
@@ -252,9 +250,10 @@
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil)))
- :let [_ (prn 'compile-def/post-body)]
+ ;; :let [_ (prn 'compile-def/post-body)]
:let [_ (.visitEnd *writer*)]
- :let [_ (prn 'compile-def/_1 ?name current-class)]
+ ;; :let [_ (prn 'compile-def/_1 ?name current-class)]
_ (&&/save-class! current-class (.toByteArray =class))
- :let [_ (prn 'compile-def/_2 ?name)]]
+ ;; :let [_ (prn 'compile-def/_2 ?name)]
+ ]
(return nil)))
diff --git a/src/lux/host.clj b/src/lux/host.clj
index e76f6625f..267f77eb6 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*]]
+ (lux [base :as & :refer [exec return* return fail fail* |let]]
[parser :as &parser]
[type :as &type])))
@@ -30,9 +30,9 @@
)))
(defn ^:private method->type [method]
- (exec [=args (&/map% class->type (seq (.getParameterTypes method)))
+ (exec [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method))))
=return (class->type (.getReturnType method))]
- (return [=args =return])))
+ (return =return)))
;; [Resources]
(defn full-class [class-name]
@@ -130,10 +130,15 @@
:when (and (= target (.getDeclaringClass =method))
(= method-name (.getName =method))
(= <static?> (java.lang.reflect.Modifier/isStatic (.getModifiers =method)))
- (= args (mapv #(.getName %) (.getParameterTypes =method))))]
+ (&/fold #(and %1 %2)
+ true
+ (&/|map (fn [xy]
+ (|let [[x y] xy]
+ (= x y)))
+ (&/zip2 args
+ (&/|map #(.getName %) (&/->list (seq (.getParameterTypes =method))))))))]
=method))]
- (exec [=method (method->type method)]
- (return =method))
+ (method->type method)
(fail (str "[Analyser Error] Method does not exist: " target method-name)))))
lookup-static-method true
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index bebf9423e..cbdf24ff4 100644
--- a/src/lux/lexer.clj
+++ b/src/lux/lexer.clj
@@ -35,10 +35,10 @@
(def ^:private lex-text-body
(&/try-all% (&/|list (exec [[prefix escaped] (lex-regex2 #"(?s)^([^\"\\]*)(\\.)")
- unescaped (escape-char escaped)
- postfix lex-text-body]
- (return (str prefix unescaped postfix)))
- (lex-regex #"(?s)^([^\"\\]*)"))))
+ unescaped (escape-char escaped)
+ postfix lex-text-body]
+ (return (str prefix unescaped postfix)))
+ (lex-regex #"(?s)^([^\"\\]*)"))))
(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)(;[0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]+)?")
@@ -56,16 +56,16 @@
(def ^:private lex-multi-line-comment
(exec [_ (lex-prefix "#(")
comment (&/try-all% (&/|list (lex-regex #"(?is)^((?!#\().)*?(?=\)#)")
- (exec [pre (lex-regex #"(?is)^(.+?(?=#\())")
- [_ inner] lex-multi-line-comment
- post (lex-regex #"(?is)^(.+?(?=\)#))")]
- (return (str pre "#(" inner ")#" post)))))
+ (exec [pre (lex-regex #"(?is)^(.+?(?=#\())")
+ [_ inner] lex-multi-line-comment
+ post (lex-regex #"(?is)^(.+?(?=\)#))")]
+ (return (str pre "#(" inner ")#" post)))))
_ (lex-prefix ")#")]
(return (&/V "Comment" comment))))
(def ^:private lex-comment
(&/try-all% (&/|list lex-single-line-comment
- lex-multi-line-comment)))
+ lex-multi-line-comment)))
(do-template [<name> <tag> <regex>]
(def <name>
@@ -80,8 +80,8 @@
(def ^:private lex-char
(exec [_ (lex-prefix "#\"")
token (&/try-all% (&/|list (exec [escaped (lex-regex #"^(\\.)")]
- (escape-char escaped))
- (lex-regex #"^(.)")))
+ (escape-char escaped))
+ (lex-regex #"^(.)")))
_ (lex-prefix "\"")]
(return (&/V "Char" token))))
@@ -111,21 +111,21 @@
(def ^:private lex-delimiter
(&/try-all% (&/|list lex-open-paren
- lex-close-paren
- lex-open-bracket
- lex-close-bracket
- lex-open-brace
- lex-close-brace)))
+ lex-close-paren
+ lex-open-bracket
+ lex-close-bracket
+ lex-open-brace
+ lex-close-brace)))
;; [Exports]
(def lex
(&/try-all% (&/|list lex-white-space
- lex-comment
- lex-bool
- lex-real
- lex-int
- lex-char
- lex-text
- lex-ident
- lex-tag
- lex-delimiter)))
+ lex-comment
+ lex-bool
+ lex-real
+ lex-int
+ lex-char
+ lex-text
+ lex-ident
+ lex-tag
+ lex-delimiter)))
diff --git a/src/lux/macro.clj b/src/lux/macro.clj
index b822426ff..91d71cf39 100644
--- a/src/lux/macro.clj
+++ b/src/lux/macro.clj
@@ -6,6 +6,7 @@
;; [Resources]
(defn expand [loader macro-class tokens]
(fn [state]
+ (prn 'expand macro-class tokens state)
(-> (.loadClass loader macro-class)
(.getField "_datum")
(.get nil)
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 927110cc6..a77baf191 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -160,7 +160,7 @@
(return type)
)))
-(defn ^:private show-type [type]
+(defn show-type [type]
(prn 'show-type (aget type 0))
(matchv ::M/objects [type]
[["Any" _]]
@@ -217,7 +217,8 @@
(str "Type " (show-type expected) " does not subsume type " (show-type actual)))
(defn solve [expected actual]
- (prn 'solve (aget expected 0) (aget actual 0))
+ ;; (prn 'solve expected actual)
+ ;; (prn 'solve (aget expected 0) (aget actual 0))
(matchv ::M/objects [expected actual]
[["Any" _] _]
success
@@ -289,6 +290,11 @@
[["Nothing" _] _]
(return y)
+ ;;;
+
+ [_ _]
+ (return x)
+
;; [["Variant" x!cases] ["Variant" y!cases]]
;; (if (and (reduce && true
;; (for [[xslot xtype] (keys x!cases)]
@@ -312,7 +318,7 @@
;; (fail (str "Incompatible records: " (pr-str x) " and " (pr-str y))))
[_ _]
- (fail (str "Can't merge types: " (pr-str x) " and " (pr-str y))))))
+ (fail (str "[Type System] Can't merge types: " (pr-str x) " and " (pr-str y))))))
(defn apply-lambda [func param]
(matchv ::M/objects [func]
@@ -321,7 +327,9 @@
(return output))
[_]
- (fail (str "Can't apply type " (str func) " to type " (str param)))))
+ (return (&/V "Any" nil))
+ ;; (fail (str "[Type System] Can't apply type " (str func) " to type " (str param)))
+ ))
(defn slot-type [record slot]
(fn [state]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 08:11:47 +0000