aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/lux.clj31
-rw-r--r--src/lux/analyser.clj836
-rw-r--r--src/lux/analyser/base.clj30
-rw-r--r--src/lux/analyser/case.clj348
-rw-r--r--src/lux/analyser/env.clj30
-rw-r--r--src/lux/analyser/host.clj445
-rw-r--r--src/lux/analyser/lambda.clj15
-rw-r--r--src/lux/analyser/lux.clj498
-rw-r--r--src/lux/analyser/module.clj247
-rw-r--r--src/lux/base.clj306
-rw-r--r--src/lux/compiler.clj668
-rw-r--r--src/lux/compiler/base.clj190
-rw-r--r--src/lux/compiler/cache.clj138
-rw-r--r--src/lux/compiler/case.clj108
-rw-r--r--src/lux/compiler/host.clj434
-rw-r--r--src/lux/compiler/lambda.clj67
-rw-r--r--src/lux/compiler/lux.clj176
-rw-r--r--src/lux/compiler/package.clj61
-rw-r--r--src/lux/compiler/type.clj97
-rw-r--r--src/lux/host.clj107
-rw-r--r--src/lux/lexer.clj140
-rw-r--r--src/lux/optimizer.clj13
-rw-r--r--src/lux/parser.clj95
-rw-r--r--src/lux/reader.clj168
-rw-r--r--src/lux/type.clj897
25 files changed, 3518 insertions, 2627 deletions
diff --git a/src/lux.clj b/src/lux.clj
index de302b260..7e3627cd7 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -1,25 +1,24 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux
(:gen-class)
(:require [lux.base :as &]
[lux.compiler :as &compiler]
:reload-all))
-(defn -main [& _]
- (time (&compiler/compile-all (&/|list "program")))
- (System/exit 0))
+(defn -main [& [program-module & _]]
+ (if program-module
+ (time (&compiler/compile-program program-module))
+ (println "Please provide a module name to compile."))
+ (System/exit 0)
+ )
(comment
- ;; TODO: Finish total-locals
-
- (time (&compiler/compile-all (&/|list "program")))
-
- (time (&compiler/compile-all (&/|list "lux")))
- (System/gc)
- (time (&compiler/compile-all (&/|list "lux" "test2")))
-
- ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
- ;; jar cvf program.jar output/*.class output/program && java -cp "program.jar" program
- ;; cd output && jar cvf test2.jar * && java -cp "test2.jar" test2 && cd ..
-
- ;; cd output && jar cvf program.jar * && java -cp "program.jar" program && cd ..
+ (-main "program")
)
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index e2cdb83ce..de7fc8497 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -1,8 +1,16 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.analyser
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [|do return fail return* fail* |list]]
+ (lux [base :as & :refer [|let |do return fail return* fail*]]
[reader :as &reader]
[parser :as &parser]
[type :as &type]
@@ -14,515 +22,533 @@
;; [Utils]
(defn ^:private parse-handler [[catch+ finally+] token]
(matchv ::M/objects [token]
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-catch"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?ex-class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?ex-arg]]]]
- ["lux;Cons" [?catch-body
- ["lux;Nil" _]]]]]]]]]]]]]
- (&/T (&/|++ catch+ (|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-finally"]]]]
- ["lux;Cons" [?finally-body
- ["lux;Nil" _]]]]]]]]]
- (&/T catch+ ?finally-body)))
-
-(defn ^:private _meta [token]
- (&/V "lux;Meta" (&/T (&/T "" -1 -1) token)))
-
-(defn ^:private aba1 [analyse eval! exo-type token]
+ [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]]
+ ["lux;Cons" [?catch-body
+ ["lux;Nil" _]]]]]]]]]]]]]
+ (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)
+
+ [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]]
+ ["lux;Cons" [?finally-body
+ ["lux;Nil" _]]]]]]]]]
+ (&/T catch+ (&/V "lux;Some" ?finally-body))))
+
+(defn ^:private aba7 [analyse eval! compile-module exo-type token]
(matchv ::M/objects [token]
- ;; Standard special forms
- [["lux;Meta" [meta ["lux;Bool" ?value]]]]
- (|do [_ (&type/check exo-type &type/Bool)]
- (return (&/|list (&/T (&/V "bool" ?value) exo-type))))
+ ;; Arrays
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]]
+ ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-new-array analyse ?class ?length)
- [["lux;Meta" [meta ["lux;Int" ?value]]]]
- (|do [_ (&type/check exo-type &type/Int)]
- (return (&/|list (&/T (&/V "int" ?value) exo-type))))
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]]
+ ["lux;Cons" [?array
+ ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]]
+ ["lux;Cons" [?elem
+ ["lux;Nil" _]]]]]]]]]]]
+ (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem)
- [["lux;Meta" [meta ["lux;Real" ?value]]]]
- (|do [_ (&type/check exo-type &type/Real)]
- (return (&/|list (&/T (&/V "real" ?value) exo-type))))
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]]
+ ["lux;Cons" [?array
+ ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]]
+ ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-aaload analyse ?array ?idx)
- [["lux;Meta" [meta ["lux;Char" ?value]]]]
- (|do [_ (&type/check exo-type &type/Char)]
- (return (&/|list (&/T (&/V "char" ?value) exo-type))))
+ ;; Classes & interfaces
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]]
+ ["lux;Nil" _]]]]]]]]]]]]]]]
+ (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]]
+ ?methods]]]]]]]]
+ (&&host/analyse-jvm-interface analyse ?name ?supers ?methods)
- [["lux;Meta" [meta ["lux;Text" ?value]]]]
- (|do [_ (&type/check exo-type &type/Text)]
- (return (&/|list (&/T (&/V "text" ?value) exo-type))))
+ ;; Programs
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]]
+ ["lux;Cons" [?body
+ ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-program analyse ?args ?body)
+
+ [_]
+ (fail "")))
- [["lux;Meta" [meta ["lux;Tuple" ?elems]]]]
- (&&lux/analyse-tuple analyse exo-type ?elems)
+(defn ^:private aba6 [analyse eval! compile-module exo-type token]
+ (matchv ::M/objects [token]
+ ;; Primitive conversions
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-d2f analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Record" ?elems]]]]
- (&&lux/analyse-record analyse exo-type ?elems)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-d2i analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Tag" ?ident]]]]
- (&&lux/analyse-variant analyse exo-type ?ident (_meta (&/V "lux;Tuple" (|list))))
-
- [["lux;Meta" [meta ["lux;Symbol" [_ "jvm-null"]]]]]
- (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null"))))
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-d2l analyse exo-type ?value)
- [_]
- (fail "")
- ))
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-f2d analyse exo-type ?value)
-(defn ^:private aba2 [analyse eval! exo-type token]
- (matchv ::M/objects [token]
- [["lux;Meta" [meta ["lux;Symbol" ?ident]]]]
- (&&lux/analyse-symbol analyse exo-type ?ident)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-f2i analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "case'"]]]]
- ["lux;Cons" [?value ?branches]]]]]]]]
- (&&lux/analyse-case analyse exo-type ?value ?branches)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "lambda'"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?self]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?arg]]]
- ["lux;Cons" [?body
- ["lux;Nil" _]]]]]]]]]]]]]
- (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-f2l analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "def'"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]]
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]]]]]
- (do ;; (when (= "if" ?name)
- ;; (prn "if" (&/show-ast ?value)))
- (&&lux/analyse-def analyse ?name ?value))
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "declare-macro'"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]]
- ["lux;Nil" _]]]]]]]]]
- (&&lux/analyse-declare-macro analyse ?name)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-i2b analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "import'"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?path]]]
- ["lux;Nil" _]]]]]]]]]
- (&&lux/analyse-import analyse ?path)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-i2c analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ":'"]]]]
- ["lux;Cons" [?type
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]]]]]
- (&&lux/analyse-check analyse eval! exo-type ?type ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-i2d analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ":!'"]]]]
- ["lux;Cons" [?type
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]]]]]
- (&&lux/analyse-coerce analyse eval! ?type ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-i2f analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "export'"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?ident]]]]
- ["lux;Nil" _]]]]]]]]]
- (&&lux/analyse-export analyse ?ident)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-i2l analyse exo-type ?value)
- [_]
- (fail "")))
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-i2s analyse exo-type ?value)
-(defn ^:private aba3 [analyse eval! exo-type token]
- (matchv ::M/objects [token]
- ;; Host special forms
- ;; Integer arithmetic
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-iadd analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-l2d analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-isub analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-l2f analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-imul analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-l2i analyse exo-type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-idiv analyse ?x ?y)
+ ;; Bitwise operators
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-iand analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-irem analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-ior analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-ieq analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-land analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-ilt analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-lor analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-igt analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-lxor analyse exo-type ?x ?y)
- ;; Long arithmetic
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-ladd analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-lshl analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-lsub analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-lshr analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-lmul analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-lushr analyse exo-type ?x ?y)
+
+ [_]
+ (aba7 analyse eval! compile-module exo-type token)))
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-ldiv analyse ?x ?y)
+(defn ^:private aba5 [analyse eval! compile-module exo-type token]
+ (matchv ::M/objects [token]
+ ;; Objects
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]]
+ ["lux;Cons" [?object
+ ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-null? analyse exo-type ?object)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [?object
+ ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]]
+ ["lux;Nil" _]]]]]]]]]]]
+ (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]]
+ ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]]
+ ["lux;Cons" [?object
+ ["lux;Nil" _]]]]]]]]]]]
+ (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]]
+ ["lux;Cons" [?value
+ ["lux;Nil" _]]]]]]]]]]]
+ (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]]
+ ["lux;Cons" [?object
+ ["lux;Cons" [?value
+ ["lux;Nil" _]]]]]]]]]]]]]
+ (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]]
+ ["lux;Nil" _]]]]]]]]]]]]]
+ (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]]
+ ["lux;Cons" [?object
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]]
+ ["lux;Nil" _]]]]]]]]]]]]]]]
+ (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]]
+ ["lux;Cons" [?object
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]]
+ ["lux;Nil" _]]]]]]]]]]]]]]]
+ (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]]
+ ["lux;Cons" [?object
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]]
+ ["lux;Nil" _]]]]]]]]]]]]]]]
+ (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-lrem analyse ?x ?y)
+ ;; Exceptions
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]]
+ ["lux;Cons" [?body
+ ?handlers]]]]]]
+ (&&host/analyse-jvm-try analyse exo-type ?body (&/fold parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers))
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-leq analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]]
+ ["lux;Cons" [?ex
+ ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-throw analyse exo-type ?ex)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-llt analyse ?x ?y)
+ ;; Syncronization/monitos
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]]
+ ["lux;Cons" [?monitor
+ ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-lgt analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]]
+ ["lux;Cons" [?monitor
+ ["lux;Nil" _]]]]]]]
+ (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor)
[_]
- (fail "")))
+ (aba6 analyse eval! compile-module exo-type token)))
-(defn ^:private aba4 [analyse eval! exo-type token]
+(defn ^:private aba4 [analyse eval! compile-module exo-type token]
(matchv ::M/objects [token]
;; Float arithmetic
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-fadd analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-fadd analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-fsub analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-fsub analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-fmul analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-fmul analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-fdiv analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-frem analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-frem analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-feq analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-feq analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-flt analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-flt analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-fgt analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-fgt analyse exo-type ?x ?y)
;; Double arithmetic
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-dadd analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-dadd analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-dsub analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-dsub analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-dmul analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-dmul analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-ddiv analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-drem analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-drem analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-deq analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-deq analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-dlt analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-dlt analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-dgt analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-dgt analyse exo-type ?x ?y)
[_]
- (fail "")))
+ (aba5 analyse eval! compile-module exo-type token)))
-(defn ^:private aba5 [analyse eval! exo-type token]
+(defn ^:private aba3 [analyse eval! compile-module exo-type token]
(matchv ::M/objects [token]
- ;; Objects
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-null?"]]]]
- ["lux;Cons" [?object
- ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-null? analyse ?object)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-new"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]]
- ["lux;Nil" _]]]]]]]]]]]]]
- (&&host/analyse-jvm-new analyse ?class ?classes ?args)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-getstatic"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]]
- ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-getstatic analyse ?class ?field)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-getfield"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]]
- ["lux;Cons" [?object
- ["lux;Nil" _]]]]]]]]]]]]]
- (&&host/analyse-jvm-getfield analyse ?class ?field ?object)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-putstatic"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]]
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]]]]]]]
- (&&host/analyse-jvm-putstatic analyse ?class ?field ?value)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-putfield"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]]
- ["lux;Cons" [?object
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]]]]]]]]]
- (&&host/analyse-jvm-putfield analyse ?class ?field ?object ?value)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokestatic"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]]
- ["lux;Nil" _]]]]]]]]]]]]]]]
- (&&host/analyse-jvm-invokestatic analyse ?class ?method ?classes ?args)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokevirtual"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]]
- ["lux;Cons" [?object
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]]
- ["lux;Nil" _]]]]]]]]]]]]]]]]]
- (&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokeinterface"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]]
- ["lux;Cons" [?object
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]]
- ["lux;Nil" _]]]]]]]]]]]]]]]]]
- (&&host/analyse-jvm-invokeinterface analyse ?class ?method ?classes ?object ?args)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokespecial"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]]
- ["lux;Cons" [?object
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]]
- ["lux;Nil" _]]]]]]]]]]]]]]]]]
- (&&host/analyse-jvm-invokespecial analyse ?class ?method ?classes ?object ?args)
-
- ;; Exceptions
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-try"]]]]
- ["lux;Cons" [?body
- ?handlers]]]]]]]]
- (&&host/analyse-jvm-try analyse ?body (&/fold parse-handler [(list) nil] ?handlers))
+ ;; Host special forms
+ ;; Characters
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-ceq analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-throw"]]]]
- ["lux;Cons" [?ex
- ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-throw analyse ?ex)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-clt analyse exo-type ?x ?y)
- ;; Syncronization/monitos
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-monitorenter"]]]]
- ["lux;Cons" [?monitor
- ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-monitorenter analyse ?monitor)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-cgt analyse exo-type ?x ?y)
+
+ ;; Integer arithmetic
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-iadd analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-monitorexit"]]]]
- ["lux;Cons" [?monitor
- ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-monitorexit analyse ?monitor)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-isub analyse exo-type ?x ?y)
- [_]
- (fail "")))
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-imul analyse exo-type ?x ?y)
-(defn ^:private aba6 [analyse eval! exo-type token]
- (matchv ::M/objects [token]
- ;; Primitive conversions
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-d2f analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-idiv analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-d2i analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-irem analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-d2l analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-ieq analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-f2d analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-ilt analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-f2i analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-igt analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-f2l analyse ?value)
+ ;; Long arithmetic
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-ladd analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-i2b analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-lsub analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-i2c analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-lmul analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-i2d analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-i2f analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-lrem analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-i2l analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-leq analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-i2s analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-llt analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-l2d analyse ?value)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&&host/analyse-jvm-lgt analyse exo-type ?x ?y)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-l2f analyse ?value)
+ [_]
+ (aba4 analyse eval! compile-module exo-type token)))
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]
- (&&host/analyse-jvm-l2i analyse ?value)
+(defn ^:private aba2 [analyse eval! compile-module exo-type token]
+ (matchv ::M/objects [token]
+ [["lux;SymbolS" ?ident]]
+ (&&lux/analyse-symbol analyse exo-type ?ident)
- ;; Bitwise operators
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-iand analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]]
+ ["lux;Cons" [?value ?branches]]]]]]
+ (&&lux/analyse-case analyse exo-type ?value ?branches)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]]
+ ["lux;Cons" [?body
+ ["lux;Nil" _]]]]]]]]]]]
+ (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-ior analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]]
+ ["lux;Cons" [?value
+ ["lux;Nil" _]]]]]]]]]
+ (&&lux/analyse-def analyse ?name ?value)
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]]
+ ["lux;Nil" _]]]]]]]
+ (&&lux/analyse-declare-macro analyse ?name)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-land analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]]
+ ["lux;Nil" _]]]]]]]
+ (&&lux/analyse-import analyse compile-module ?path)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-lor analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]]
+ ["lux;Cons" [?type
+ ["lux;Cons" [?value
+ ["lux;Nil" _]]]]]]]]]
+ (&&lux/analyse-check analyse eval! exo-type ?type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-lxor analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]]
+ ["lux;Cons" [?type
+ ["lux;Cons" [?value
+ ["lux;Nil" _]]]]]]]]]
+ (&&lux/analyse-coerce analyse eval! exo-type ?type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-lshl analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]]
+ ["lux;Nil" _]]]]]]]
+ (&&lux/analyse-export analyse ?ident)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-lshr analyse ?x ?y)
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]]
+ ["lux;Nil" _]]]]]]]]]
+ (&&lux/analyse-alias analyse ?alias ?module)
+
+ [_]
+ (aba3 analyse eval! compile-module exo-type token)))
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-lushr analyse ?x ?y)
+(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))]
+ (defn ^:private aba1 [analyse eval! compile-module exo-type token]
+ (matchv ::M/objects [token]
+ ;; Standard special forms
+ [["lux;BoolS" ?value]]
+ (|do [_ (&type/check exo-type &type/Bool)]
+ (return (&/|list (&/T (&/V "bool" ?value) exo-type))))
- [_]
- (fail "")))
+ [["lux;IntS" ?value]]
+ (|do [_ (&type/check exo-type &type/Int)]
+ (return (&/|list (&/T (&/V "int" ?value) exo-type))))
-(defn ^:private aba7 [analyse eval! exo-type token]
- (matchv ::M/objects [token]
- ;; Arrays
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-new-array"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?length]]]
- ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-new-array analyse ?class ?length)
+ [["lux;RealS" ?value]]
+ (|do [_ (&type/check exo-type &type/Real)]
+ (return (&/|list (&/T (&/V "real" ?value) exo-type))))
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-aastore"]]]]
- ["lux;Cons" [?array
- ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?idx]]]
- ["lux;Cons" [?elem
- ["lux;Nil" _]]]]]]]]]]]]]
- (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem)
+ [["lux;CharS" ?value]]
+ (|do [_ (&type/check exo-type &type/Char)]
+ (return (&/|list (&/T (&/V "char" ?value) exo-type))))
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-aaload"]]]]
- ["lux;Cons" [?array
- ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?idx]]]
- ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-aaload analyse ?array ?idx)
+ [["lux;TextS" ?value]]
+ (|do [_ (&type/check exo-type &type/Text)]
+ (return (&/|list (&/T (&/V "text" ?value) exo-type))))
- ;; Classes & interfaces
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-class"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?super-class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?fields]]]
- ["lux;Nil" _]]]]]]]]]]]]]
- (&&host/analyse-jvm-class analyse ?name ?super-class ?fields)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-interface"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]]
- ?members]]]]]]]]
- (&&host/analyse-jvm-interface analyse ?name ?members)
+ [["lux;TupleS" ?elems]]
+ (&&lux/analyse-tuple analyse exo-type ?elems)
- ;; Programs
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-program"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?args]]]]
- ["lux;Cons" [?body
- ["lux;Nil" _]]]]]]]]]]]
- (&&host/analyse-jvm-program analyse ?args ?body)
-
- [_]
- (fail "")))
+ [["lux;RecordS" ?elems]]
+ (&&lux/analyse-record analyse exo-type ?elems)
-(defn ^:private analyse-basic-ast [analyse eval! exo-type token]
- ;; (prn 'analyse-basic-ast (aget token 0))
- ;; (when (= "lux;Tag" (aget token 0))
- ;; (prn 'analyse-basic-ast/tag (aget token 1)))
- ;; (prn 'analyse-basic-ast token (&/show-ast token))
- (fn [state]
- (matchv ::M/objects [((aba1 analyse eval! exo-type token) state)]
- [["lux;Right" [state* output]]]
- (return* state* output)
+ [["lux;TagS" ?ident]]
+ (&&lux/analyse-variant analyse exo-type ?ident unit)
+
+ [["lux;SymbolS" [_ "_jvm_null"]]]
+ (&&host/analyse-jvm-null analyse exo-type)
[_]
- (matchv ::M/objects [((aba2 analyse eval! exo-type token) state)]
+ (aba2 analyse eval! compile-module exo-type token)
+ )))
+
+(defn ^:private add-loc [meta ^String msg]
+ (if (.startsWith msg "@")
+ msg
+ (|let [[file line col] meta]
+ (str "@ " file "," line "," col "\n" msg))))
+
+(defn ^:private analyse-basic-ast [analyse eval! compile-module exo-type token]
+ ;; (prn 'analyse-basic-ast (&/show-ast token))
+ (matchv ::M/objects [token]
+ [["lux;Meta" [meta ?token]]]
+ (fn [state]
+ (matchv ::M/objects [((aba1 analyse eval! compile-module exo-type ?token) state)]
[["lux;Right" [state* output]]]
(return* state* output)
- [_]
- (matchv ::M/objects [((aba3 analyse eval! exo-type token) state)]
- [["lux;Right" [state* output]]]
- (return* state* output)
-
- [_]
- (matchv ::M/objects [((aba4 analyse eval! exo-type token) state)]
- [["lux;Right" [state* output]]]
- (return* state* output)
-
- [_]
- (matchv ::M/objects [((aba5 analyse eval! exo-type token) state)]
- [["lux;Right" [state* output]]]
- (return* state* output)
-
- [_]
- (matchv ::M/objects [((aba6 analyse eval! exo-type token) state)]
- [["lux;Right" [state* output]]]
- (return* state* output)
-
- [_]
- (matchv ::M/objects [((aba7 analyse eval! exo-type token) state)]
- [["lux;Right" [state* output]]]
- (return* state* output)
-
- [_]
- (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token))))))))))))
-
-(defn ^:private analyse-ast [eval! exo-type token]
- ;; (prn 'analyse-ast (aget token 0))
+ [["lux;Left" ""]]
+ (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token))))
+
+ [["lux;Left" msg]]
+ (fail* (add-loc meta msg))
+ ))
+
+ ;; [_]
+ ;; (assert false (aget token 0))
+ ))
+
+(defn ^:private just-analyse [analyse-ast eval! compile-module syntax]
+ (&type/with-var
+ (fn [?var]
+ (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)]
+ (matchv ::M/objects [?var ?output-type]
+ [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]]
+ (if (= ?e-id ?a-id)
+ (|do [?output-type* (&type/deref ?e-id)]
+ (return (&/T ?output-term ?output-type*)))
+ (return (&/T ?output-term ?output-type)))
+
+ [_ _]
+ (return (&/T ?output-term ?output-type)))
+ ))))
+
+(defn ^:private analyse-ast [eval! compile-module exo-type token]
(matchv ::M/objects [token]
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]] ?values]]]]]]
- (do (assert (= 1 (&/|length ?values)) "[Analyser Error] Can only tag 1 value.")
- (&&lux/analyse-variant (partial analyse-ast eval!) exo-type ?ident (&/|head ?values)))
+ [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]]
+ (do (assert (.equals ^Object (&/|length ?values) 1) "[Analyser Error] Can only tag 1 value.")
+ (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident (&/|head ?values)))
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [?fn ?args]]]]]]
+ [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]]
(fn [state]
- ;; (prn 'analyse-ast '(&/show-ast ?fn) (&/show-ast ?fn))
- (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval!) % ?fn)) state)]
+ (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state)
+ ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)
+ ]
[["lux;Right" [state* =fn]]]
- ((&&lux/analyse-apply (partial analyse-ast eval!) exo-type =fn ?args) state*)
+ (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0))
+ ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*))
[_]
- (do ;; (prn 'analyse-ast/token (aget token 0) (&/show-state state))
- ;; (prn 'NOT_A_FUNCTION (&/show-ast ?fn))
- ((analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token) state))))
+ ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state)))
[_]
- (analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token)))
+ (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token)))
;; [Resources]
-(defn analyse [eval!]
+(defn analyse [eval! compile-module]
(|do [asts &parser/parse]
- (&/flat-map% (partial analyse-ast eval! &type/$Void) asts)))
+ (&/flat-map% (partial analyse-ast eval! compile-module &type/$Void) asts)))
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 9913da4ae..9fc3f1030 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.analyser.base
(:require [clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
@@ -6,32 +14,22 @@
;; [Exports]
(defn expr-type [syntax+]
- ;; (prn 'expr-type syntax+)
- ;; (prn 'expr-type (aget syntax+ 0))
(matchv ::M/objects [syntax+]
[[_ type]]
(return type)))
(defn analyse-1 [analyse exo-type elem]
(|do [output (analyse exo-type elem)]
- (do ;; (prn 'analyse-1 (aget output 0))
- (matchv ::M/objects [output]
- [["lux;Cons" [x ["lux;Nil" _]]]]
- (return x)
+ (matchv ::M/objects [output]
+ [["lux;Cons" [x ["lux;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 resolved-ident [ident]
(|let [[?module ?name] ident]
- (|do [module* (if (= "" ?module)
+ (|do [module* (if (.equals "" ?module)
&/get-module-name
(return ?module))]
(return (&/ident->text (&/T module* ?name))))))
-
-(defn resolved-ident* [ident]
- (|let [[?module ?name] ident]
- (|do [module* (if (= "" ?module)
- &/get-module-name
- (return ?module))]
- (return (&/T module* ?name)))))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index ea767d11c..ebbb6911a 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.analyser.case
(:require [clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
@@ -15,109 +23,196 @@
(fail "##9##")))]
(resolve-type type*))
+ [["lux;AllT" [_aenv _aname _aarg _abody]]]
+ ;; (&type/actual-type _abody)
+ (|do [$var &type/existential
+ =type (&type/apply-type type $var)]
+ (&type/actual-type =type))
+ ;; (&type/with-var
+ ;; (fn [$var]
+ ;; (|do [=type (&type/apply-type type $var)]
+ ;; (&type/actual-type =type))))
+
[_]
(&type/actual-type type)))
+(defn adjust-type* [up type]
+ "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))"
+ (matchv ::M/objects [type]
+ [["lux;AllT" [_aenv _aname _aarg _abody]]]
+ (&type/with-var
+ (fn [$var]
+ (|do [=type (&type/apply-type type $var)]
+ (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type))))
+
+ [["lux;TupleT" ?members]]
+ (|do [["lux;TupleT" ?members*] (&/fold% (fn [_abody ena]
+ (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena]
+ (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))]
+ (&type/clean* _avar _abody))))
+ type
+ up)]
+ (return (&/V "lux;TupleT" (&/|map (fn [v]
+ (&/fold (fn [_abody ena]
+ (|let [[_aenv _aname _aarg _avar] ena]
+ (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody))))
+ v
+ up))
+ ?members*))))
+
+ [["lux;RecordT" ?fields]]
+ (|do [["lux;RecordT" ?fields*] (&/fold% (fn [_abody ena]
+ (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena]
+ (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))]
+ (&type/clean* _avar _abody))))
+ type
+ up)]
+ (return (&/V "lux;RecordT" (&/|map (fn [kv]
+ (|let [[k v] kv]
+ (&/T k (&/fold (fn [_abody ena]
+ (|let [[_aenv _aname _aarg _avar] ena]
+ (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody))))
+ v
+ up))))
+ ?fields*))))
+
+ [["lux;VariantT" ?cases]]
+ (|do [["lux;VariantT" ?cases*] (&/fold% (fn [_abody ena]
+ (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena]
+ (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))]
+ (&type/clean* _avar _abody))))
+ type
+ up)]
+ (return (&/V "lux;VariantT" (&/|map (fn [kv]
+ (|let [[k v] kv]
+ (&/T k (&/fold (fn [_abody ena]
+ (|let [[_aenv _aname _aarg _avar] ena]
+ (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody))))
+ v
+ up))))
+ ?cases*))))
+
+ [["lux;AppT" [?tfun ?targ]]]
+ (|do [=type (&type/apply-type ?tfun ?targ)]
+ (adjust-type* up =type))
+
+ [["lux;VarT" ?id]]
+ (|do [type* (&/try-all% (&/|list (&type/deref ?id)
+ (fail "##9##")))]
+ (adjust-type* up type*))
+
+ ;; [_]
+ ;; (assert false (aget type 0))
+ ))
+
+(defn adjust-type [type]
+ "(-> Type (Lux Type))"
+ (adjust-type* (&/|list) type))
+
(defn ^:private analyse-pattern [value-type pattern kont]
- ;; (prn 'analyse-pattern/pattern (aget pattern 0) (aget pattern 1) (alength (aget pattern 1)))
(matchv ::M/objects [pattern]
[["lux;Meta" [_ pattern*]]]
- ;; (assert false)
- (do ;; (prn 'analyse-pattern/pattern* (aget pattern* 0))
- (matchv ::M/objects [pattern*]
- [["lux;Symbol" ?ident]]
- (|do [=kont (&env/with-local (&/ident->text ?ident) value-type
- kont)
- idx &env/next-local-idx]
- (return (&/T (&/V "StoreTestAC" idx) =kont)))
-
- [["lux;Bool" ?value]]
- (|do [_ (&type/check value-type &type/Bool)
- =kont kont]
- (return (&/T (&/V "BoolTestAC" ?value) =kont)))
-
- [["lux;Int" ?value]]
- (|do [_ (&type/check value-type &type/Int)
- =kont kont]
- (return (&/T (&/V "IntTestAC" ?value) =kont)))
-
- [["lux;Real" ?value]]
- (|do [_ (&type/check value-type &type/Real)
- =kont kont]
- (return (&/T (&/V "RealTestAC" ?value) =kont)))
-
- [["lux;Char" ?value]]
- (|do [_ (&type/check value-type &type/Char)
- =kont kont]
- (return (&/T (&/V "CharTestAC" ?value) =kont)))
-
- [["lux;Text" ?value]]
- (|do [_ (&type/check value-type &type/Text)
- =kont kont]
- (return (&/T (&/V "TextTestAC" ?value) =kont)))
-
- [["lux;Tuple" ?members]]
- (matchv ::M/objects [value-type]
- [["lux;TupleT" ?member-types]]
- (if (not (= (&/|length ?member-types) (&/|length ?members)))
- (fail (str "[Analyser error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]"))
- (|do [[=tests =kont] (&/fold (fn [kont* vm]
- (|let [[v m] vm]
- (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)]
- (return (&/T (&/|cons =test =tests) =kont)))))
+ (matchv ::M/objects [pattern*]
+ [["lux;SymbolS" ?ident]]
+ (|do [=kont (&env/with-local (&/ident->text ?ident) value-type
+ kont)
+ idx &env/next-local-idx]
+ (return (&/T (&/V "StoreTestAC" idx) =kont)))
+
+ [["lux;BoolS" ?value]]
+ (|do [_ (&type/check value-type &type/Bool)
+ =kont kont]
+ (return (&/T (&/V "BoolTestAC" ?value) =kont)))
+
+ [["lux;IntS" ?value]]
+ (|do [_ (&type/check value-type &type/Int)
+ =kont kont]
+ (return (&/T (&/V "IntTestAC" ?value) =kont)))
+
+ [["lux;RealS" ?value]]
+ (|do [_ (&type/check value-type &type/Real)
+ =kont kont]
+ (return (&/T (&/V "RealTestAC" ?value) =kont)))
+
+ [["lux;CharS" ?value]]
+ (|do [_ (&type/check value-type &type/Char)
+ =kont kont]
+ (return (&/T (&/V "CharTestAC" ?value) =kont)))
+
+ [["lux;TextS" ?value]]
+ (|do [_ (&type/check value-type &type/Text)
+ =kont kont]
+ (return (&/T (&/V "TextTestAC" ?value) =kont)))
+
+ [["lux;TupleS" ?members]]
+ (|do [value-type* (adjust-type value-type)]
+ (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*))
+ (matchv ::M/objects [value-type*]
+ [["lux;TupleT" ?member-types]]
+ (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members))
+ (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members)))
+ (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]"))
+ (|do [[=tests =kont] (&/fold (fn [kont* vm]
+ (|let [[v m] vm]
+ (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)]
+ (return (&/T (&/|cons =test =tests) =kont)))))
+ (|do [=kont kont]
+ (return (&/T (&/|list) =kont)))
+ (&/|reverse (&/zip2 ?member-types ?members)))]
+ (return (&/T (&/V "TupleTestAC" =tests) =kont)))))
+
+ [_]
+ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*))))))
+
+ [["lux;RecordS" ?slots]]
+ (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))]
+ value-type* (adjust-type value-type)
+ ;; :let [_ (prn 'POST (&type/show-type value-type*))]
+ ;; value-type* (resolve-type value-type)
+ ]
+ (matchv ::M/objects [value-type*]
+ [["lux;RecordT" ?slot-types]]
+ (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots)))
+ (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]"))
+ (|do [[=tests =kont] (&/fold (fn [kont* slot]
+ (|let [[sn sv] slot]
+ (matchv ::M/objects [sn]
+ [["lux;Meta" [_ ["lux;TagS" ?ident]]]]
+ (|do [=tag (&&/resolved-ident ?ident)]
+ (if-let [=slot-type (&/|get =tag ?slot-types)]
+ (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)]
+ (return (&/T (&/|put =tag =test =tests) =kont)))
+ (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag))))
+
+ [_]
+ (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn))))))
(|do [=kont kont]
- (return (&/T (&/|list) =kont)))
- (&/|reverse (&/zip2 ?member-types ?members)))]
- (return (&/T (&/V "TupleTestAC" =tests) =kont))))
+ (return (&/T (&/|table) =kont)))
+ (&/|reverse ?slots))]
+ (return (&/T (&/V "RecordTestAC" =tests) =kont))))
[_]
- (fail "[Analyser Error] Tuple requires tuple-type."))
-
- [["lux;Record" ?slots]]
- (|do [value-type* (resolve-type value-type)]
- (matchv ::M/objects [value-type*]
- [["lux;RecordT" ?slot-types]]
- (if (not (= (&/|length ?slot-types) (&/|length ?slots)))
- (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]"))
- (|do [[=tests =kont] (&/fold (fn [kont* slot]
- (|let [[sn sv] slot]
- (matchv ::M/objects [sn]
- [["lux;Meta" [_ ["lux;Tag" ?ident]]]]
- (|do [=tag (&&/resolved-ident ?ident)]
- (if-let [=slot-type (&/|get =tag ?slot-types)]
- (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)]
- (return (&/T (&/|put =tag =test =tests) =kont)))
- (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag))))
-
- [_]
- (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn))))))
- (|do [=kont kont]
- (return (&/T (&/|table) =kont)))
- (&/|reverse ?slots))]
- (return (&/T (&/V "RecordTestAC" =tests) =kont))))
-
- [_]
- (fail "[Analyser Error] Record requires record-type.")))
-
- [["lux;Tag" ?ident]]
- (|do [=tag (&&/resolved-ident ?ident)
- value-type* (resolve-type value-type)
- case-type (&type/variant-case =tag value-type*)
- [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1)
- (&/V "lux;Tuple" (&/|list))))
- kont)]
- (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
-
- [["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]]
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]
- (|do [=tag (&&/resolved-ident ?ident)
- value-type* (resolve-type value-type)
- case-type (&type/variant-case =tag value-type*)
- [=test =kont] (analyse-pattern case-type ?value
- kont)]
- (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
- ))))
+ (fail "[Pattern-matching Error] Record requires record-type.")))
+
+ [["lux;TagS" ?ident]]
+ (|do [=tag (&&/resolved-ident ?ident)
+ value-type* (adjust-type value-type)
+ case-type (&type/variant-case =tag value-type*)
+ [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1)
+ (&/V "lux;TupleS" (&/|list))))
+ kont)]
+ (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
+
+ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]]
+ ["lux;Cons" [?value
+ ["lux;Nil" _]]]]]]]
+ (|do [=tag (&&/resolved-ident ?ident)
+ value-type* (adjust-type value-type)
+ case-type (&type/variant-case =tag value-type*)
+ [=test =kont] (analyse-pattern case-type ?value
+ kont)]
+ (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
+ )))
(defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns]
(|do [pattern+body (analyse-pattern value-type pattern
@@ -171,13 +266,12 @@
(return (&/V "TupleTotal" (&/T total? structs))))
[["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]]
- (if (= (&/|length ?values) (&/|length ?tests))
- (|do [structs (&/map% (fn [vt]
- (|let [[v t] vt]
- (merge-total v (&/T t ?body))))
- (&/zip2 ?values ?tests))]
+ (if (.equals ^Object (&/|length ?values) (&/|length ?tests))
+ (|do [structs (&/map2% (fn [v t]
+ (merge-total v (&/T t ?body)))
+ ?values ?tests)]
(return (&/V "TupleTotal" (&/T total? structs))))
- (fail "[Pattern-matching error] Inconsistent tuple-size."))
+ (fail "[Pattern-matching Error] Inconsistent tuple-size."))
[["DefaultTotal" total?] ["RecordTestAC" ?tests]]
(|do [structs (&/map% (fn [t]
@@ -191,20 +285,21 @@
(return (&/V "RecordTotal" (&/T total? structs))))
[["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]]
- (if (= (&/|length ?values) (&/|length ?tests))
- (|do [structs (&/map% (fn [lr]
- (|let [[[lslot sub-struct] [rslot value]] lr]
- (if (= lslot rslot)
- (|do [sub-struct* (merge-total sub-struct (&/T value ?body))]
- (return (&/T lslot sub-struct*)))
- (fail "[Pattern-matching error] Record slots mismatch."))))
- (&/zip2 ?values
- (->> ?tests
- &/->seq
- (sort compare-kv)
- &/->list)))]
+ (if (.equals ^Object (&/|length ?values) (&/|length ?tests))
+ (|do [structs (&/map2% (fn [left right]
+ (|let [[lslot sub-struct] left
+ [rslot value]right]
+ (if (.equals ^Object lslot rslot)
+ (|do [sub-struct* (merge-total sub-struct (&/T value ?body))]
+ (return (&/T lslot sub-struct*)))
+ (fail "[Pattern-matching Error] Record slots mismatch."))))
+ ?values
+ (->> ?tests
+ &/->seq
+ (sort compare-kv)
+ &/->list))]
(return (&/V "RecordTotal" (&/T total? structs))))
- (fail "[Pattern-matching error] Inconsistent record-size."))
+ (fail "[Pattern-matching Error] Inconsistent record-size."))
[["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]]
(|do [sub-struct (merge-total (&/V "DefaultTotal" total?)
@@ -219,7 +314,6 @@
))))
(defn ^:private check-totality [value-type struct]
- ;; (prn 'check-totality (aget value-type 0) (aget struct 0) (&type/show-type value-type))
(matchv ::M/objects [struct]
[["BoolTotal" [?total ?values]]]
(return (or ?total
@@ -240,16 +334,16 @@
[["TupleTotal" [?total ?structs]]]
(if ?total
(return true)
- (matchv ::M/objects [value-type]
- [["lux;TupleT" ?members]]
- (|do [totals (&/map% (fn [sv]
- (|let [[sub-struct ?member] sv]
- (check-totality ?member sub-struct)))
- (&/zip2 ?structs ?members))]
- (return (&/fold #(and %1 %2) true totals)))
+ (|do [value-type* (resolve-type value-type)]
+ (matchv ::M/objects [value-type*]
+ [["lux;TupleT" ?members]]
+ (|do [totals (&/map2% (fn [sub-struct ?member]
+ (check-totality ?member sub-struct))
+ ?structs ?members)]
+ (return (&/fold #(and %1 %2) true totals)))
- [_]
- (fail "")))
+ [_]
+ (fail "[Pattern-maching Error] Tuple is not total."))))
[["RecordTotal" [?total ?structs]]]
(if ?total
@@ -266,7 +360,7 @@
(return (&/fold #(and %1 %2) true totals)))
[_]
- (fail ""))))
+ (fail "[Pattern-maching Error] Record is not total."))))
[["VariantTotal" [?total ?structs]]]
(if ?total
@@ -283,7 +377,7 @@
(return (&/fold #(and %1 %2) true totals)))
[_]
- (fail ""))))
+ (fail "[Pattern-maching Error] Variant is not total."))))
[["DefaultTotal" ?total]]
(return ?total)
@@ -296,10 +390,8 @@
(analyse-branch analyse exo-type value-type pattern body patterns)))
(&/|list)
branches)
- ;; :let [_ (prn 'PRE_MERGE_TOTALS)]
struct (&/fold% merge-total (&/V "DefaultTotal" false) patterns)
? (check-totality value-type struct)]
(if ?
- ;; (return (&/|reverse patterns))
(return patterns)
- (fail "[Pattern-maching error] Pattern-matching is non-total."))))
+ (fail "[Pattern-maching Error] Pattern-matching is non-total."))))
diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj
index 77fba3ca0..cac0f8cd4 100644
--- a/src/lux/analyser/env.clj
+++ b/src/lux/analyser/env.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.analyser.env
(:require [clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
@@ -16,30 +24,26 @@
=return (body (&/update$ &/$ENVS
(fn [stack]
(let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))]
- (&/|cons (->> (&/|head stack)
- (&/update$ &/$LOCALS #(&/update$ &/$COUNTER inc %))
- (&/update$ &/$LOCALS #(&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)) %)))
+ (&/|cons (&/update$ &/$LOCALS #(->> %
+ (&/update$ &/$COUNTER inc)
+ (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m))))
+ (&/|head stack))
(&/|tail stack))))
state))]
(matchv ::M/objects [=return]
[["lux;Right" [?state ?value]]]
(return* (&/update$ &/$ENVS (fn [stack*]
- (&/|cons (->> (&/|head stack*)
- (&/update$ &/$LOCALS #(&/update$ &/$COUNTER dec %))
- (&/update$ &/$LOCALS #(&/set$ &/$MAPPINGS old-mappings %)))
- (&/|tail stack*)))
+ (&/|cons (&/update$ &/$LOCALS #(->> %
+ (&/update$ &/$COUNTER dec)
+ (&/set$ &/$MAPPINGS old-mappings))
+ (&/|head stack*))
+ (&/|tail stack*)))
?state)
?value)
[_]
=return))))
-(defn with-locals [locals monad]
- (reduce (fn [inner [label elem]]
- (with-local label elem inner))
- monad
- (reverse locals)))
-
(def captured-vars
(fn [state]
(return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS)))))
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 3c9e3ce3f..5033f4f2c 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.analyser.host
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [match matchv]]
@@ -10,18 +18,17 @@
[env :as &&env])))
;; [Utils]
-(defn ^:private extract-ident [ident]
- (matchv ::M/objects [ident]
- [["lux;Meta" [_ ["lux;Symbol" [_ ?ident]]]]]
- (return ?ident)
+(defn ^:private extract-text [text]
+ (matchv ::M/objects [text]
+ [["lux;Meta" [_ ["lux;TextS" ?text]]]]
+ (return ?text)
[_]
- (fail "[Analyser Error] Can't extract Symbol.")))
+ (fail "[Analyser Error] Can't extract Text.")))
(defn ^:private analyse-1+ [analyse ?token]
(&type/with-var
(fn [$var]
- ;; (prn 'analyse-1+ (aget $var 1) (&/show-ast ?token))
(|do [=expr (&&/analyse-1 analyse $var ?token)]
(matchv ::M/objects [=expr]
[[?item ?type]]
@@ -29,13 +36,32 @@
(return (&/T ?item =type)))
)))))
+(defn ^:private ensure-object [token]
+ "(-> Analysis (Lux (,)))"
+ (matchv ::M/objects [token]
+ [[_ ["lux;DataT" _]]]
+ (return nil)
+
+ [_]
+ (fail "[Analyser Error] Expecting object")))
+
+(defn ^:private as-object [type]
+ "(-> Type Type)"
+ (matchv ::M/objects [type]
+ [["lux;DataT" class]]
+ (&/V "lux;DataT" (&type/as-obj class))
+
+ [_]
+ type))
+
;; [Resources]
(do-template [<name> <output-tag> <input-class> <output-class>]
(let [input-type (&/V "lux;DataT" <input-class>)
output-type (&/V "lux;DataT" <output-class>)]
- (defn <name> [analyse ?x ?y]
+ (defn <name> [analyse exo-type ?x ?y]
(|do [=x (&&/analyse-1 analyse input-type ?x)
- =y (&&/analyse-1 analyse input-type ?y)]
+ =y (&&/analyse-1 analyse input-type ?y)
+ _ (&type/check exo-type output-type)]
(return (&/|list (&/T (&/V <output-tag> (&/T =x =y)) output-type))))))
analyse-jvm-iadd "jvm-iadd" "java.lang.Integer" "java.lang.Integer"
@@ -47,6 +73,10 @@
analyse-jvm-ilt "jvm-ilt" "java.lang.Integer" "java.lang.Boolean"
analyse-jvm-igt "jvm-igt" "java.lang.Integer" "java.lang.Boolean"
+ analyse-jvm-ceq "jvm-ceq" "java.lang.Character" "java.lang.Boolean"
+ analyse-jvm-clt "jvm-clt" "java.lang.Character" "java.lang.Boolean"
+ analyse-jvm-cgt "jvm-cgt" "java.lang.Character" "java.lang.Boolean"
+
analyse-jvm-ladd "jvm-ladd" "java.lang.Long" "java.lang.Long"
analyse-jvm-lsub "jvm-lsub" "java.lang.Long" "java.lang.Long"
analyse-jvm-lmul "jvm-lmul" "java.lang.Long" "java.lang.Long"
@@ -75,162 +105,292 @@
analyse-jvm-dgt "jvm-dgt" "java.lang.Double" "java.lang.Boolean"
)
-(defn analyse-jvm-getstatic [analyse ?class ?field]
- (|do [=class (&host/full-class-name ?class)
- ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)]
- =type (&host/lookup-static-field =class ?field)
- ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)]
- ]
- (return (&/|list (&/T (&/V "jvm-getstatic" (&/T =class ?field)) =type)))))
-
-(defn analyse-jvm-getfield [analyse ?class ?field ?object]
- (|do [=class (&host/full-class-name ?class)
- =type (&host/lookup-static-field =class ?field)
- =object (&&/analyse-1 analyse ?object)]
- (return (&/|list (&/T (&/V "jvm-getfield" (&/T =class ?field =object)) =type)))))
-
-(defn analyse-jvm-putstatic [analyse ?class ?field ?value]
- (|do [=class (&host/full-class-name ?class)
- ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)]
- =type (&host/lookup-static-field =class ?field)
- ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)]
- =value (&&/analyse-1 analyse ?value)]
- (return (&/|list (&/T (&/V "jvm-putstatic" (&/T =class ?field =value)) =type)))))
-
-(defn analyse-jvm-putfield [analyse ?class ?field ?object ?value]
- (|do [=class (&host/full-class-name ?class)
- =type (&host/lookup-static-field =class ?field)
- =object (&&/analyse-1 analyse ?object)
- =value (&&/analyse-1 analyse ?value)]
- (return (&/|list (&/T (&/V "jvm-putfield" (&/T =class ?field =object =value)) =type)))))
+(defn analyse-jvm-getstatic [analyse exo-type ?class ?field]
+ (|do [class-loader &/loader
+ =type (&host/lookup-static-field class-loader ?class ?field)
+ :let [output-type =type]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) output-type)))))
-(defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args]
- (|do [=class (&host/full-class-name ?class)
- =classes (&/map% &host/extract-jvm-param ?classes)
- =return (&host/lookup-static-method =class ?method =classes)
- =args (&/flat-map% analyse ?args)]
- (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T =class ?method =classes =args)) =return)))))
+(defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object]
+ (|do [class-loader &/loader
+ =type (&host/lookup-static-field class-loader ?class ?field)
+ =object (&&/analyse-1 analyse ?object)
+ :let [output-type =type]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) output-type)))))
+
+(defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value]
+ (|do [class-loader &/loader
+ =type (&host/lookup-static-field class-loader ?class ?field)
+ =value (&&/analyse-1 analyse =type ?value)
+ :let [output-type &type/Unit]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) output-type)))))
+
+(defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value]
+ (|do [class-loader &/loader
+ =type (&host/lookup-static-field class-loader ?class ?field)
+ =object (&&/analyse-1 analyse ?object)
+ =value (&&/analyse-1 analyse =type ?value)
+ :let [output-type &type/Unit]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) output-type)))))
+
+(defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args]
+ (|do [class-loader &/loader
+ =classes (&/map% extract-text ?classes)
+ =return (&host/lookup-static-method class-loader ?class ?method =classes)
+ ;; :let [_ (matchv ::M/objects [=return]
+ ;; [["lux;DataT" _return-class]]
+ ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))]
+ =args (&/map2% (fn [_class _arg]
+ (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg))
+ =classes
+ ?args)
+ :let [output-type =return]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) output-type)))))
+
+(defn analyse-jvm-instanceof [analyse exo-type ?class ?object]
+ (|do [=object (analyse-1+ analyse ?object)
+ _ (ensure-object =object)
+ :let [output-type &type/Bool]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class =object)) output-type)))))
(do-template [<name> <tag>]
- (defn <name> [analyse ?class ?method ?classes ?object ?args]
- ;; (prn '<name> ?class ?method)
- (|do [=class (&host/full-class-name ?class)
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=class =class)]
- =classes (&/map% &host/extract-jvm-param ?classes)
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=classes =classes)]
- =return (&host/lookup-virtual-method =class ?method =classes)
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=return =return)]
+ (defn <name> [analyse exo-type ?class ?method ?classes ?object ?args]
+ (|do [class-loader &/loader
+ =classes (&/map% extract-text ?classes)
+ =return (&host/lookup-virtual-method class-loader ?class ?method =classes)
=object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object)
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=object =object)]
- =args (&/map% (fn [c+o]
- (|let [[?c ?o] c+o]
- (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)))
- (&/zip2 =classes ?args))
- ;; :let [_ (prn 'analyse-jvm-invokevirtual/=args =args)]
- ]
- (return (&/|list (&/T (&/V <tag> (&/T =class ?method =classes =object =args)) =return)))))
+ =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o))
+ =classes ?args)
+ :let [output-type =return]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V <tag> (&/T ?class ?method =classes =object =args)) output-type)))))
analyse-jvm-invokevirtual "jvm-invokevirtual"
analyse-jvm-invokeinterface "jvm-invokeinterface"
- analyse-jvm-invokespecial "jvm-invokespecial"
)
-(defn analyse-jvm-null? [analyse ?object]
- (|do [=object (&&/analyse-1 analyse ?object)]
- (return (&/|list (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" "java.lang.Boolean"))))))
-
-(defn analyse-jvm-new [analyse ?class ?classes ?args]
- (|do [=class (&host/full-class-name ?class)
- =classes (&/map% &host/extract-jvm-param ?classes)
- =args (&/flat-map% analyse ?args)]
- (return (&/|list (&/T (&/V "jvm-new" (&/T =class =classes =args)) (&/V "lux;DataT" =class))))))
+(defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args]
+ (|do [class-loader &/loader
+ =classes (&/map% extract-text ?classes)
+ =return (if (= "<init>" ?method)
+ (return &type/Unit)
+ (&host/lookup-virtual-method class-loader ?class ?method =classes))
+ =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object)
+ =args (&/map2% (fn [?c ?o]
+ (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o))
+ =classes ?args)
+ :let [output-type =return]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-invokespecial" (&/T ?class ?method =classes =object =args)) output-type)))))
+
+(defn analyse-jvm-null? [analyse exo-type ?object]
+ (|do [=object (analyse-1+ analyse ?object)
+ _ (ensure-object =object)
+ :let [output-type &type/Bool]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-null?" =object) output-type)))))
+
+(defn analyse-jvm-null [analyse exo-type]
+ (|do [:let [output-type (&/V "lux;DataT" "null")]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-null" nil) output-type)))))
+
+(defn analyse-jvm-new [analyse exo-type ?class ?classes ?args]
+ (|do [=classes (&/map% extract-text ?classes)
+ =args (&/map% (partial analyse-1+ analyse) ?args)
+ :let [output-type (&/V "lux;DataT" ?class)]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) output-type)))))
(defn analyse-jvm-new-array [analyse ?class ?length]
- (|do [=class (&host/full-class-name ?class)]
- (return (&/|list (&/T (&/V "jvm-new-array" (&/T =class ?length)) (&/V "array" (&/T (&/V "lux;DataT" =class)
- (&/V "lux;Nil" nil))))))))
+ (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class)
+ (&/V "lux;Nil" nil)))))))
(defn analyse-jvm-aastore [analyse ?array ?idx ?elem]
- (|do [=array (&&/analyse-1 analyse &type/$Void ?array)
- =elem (&&/analyse-1 analyse &type/$Void ?elem)
+ (|do [=array (analyse-1+ analyse ?array)
+ =elem (analyse-1+ analyse ?elem)
=array-type (&&/expr-type =array)]
(return (&/|list (&/T (&/V "jvm-aastore" (&/T =array ?idx =elem)) =array-type)))))
(defn analyse-jvm-aaload [analyse ?array ?idx]
- (|do [=array (&&/analyse-1 analyse ?array)
+ (|do [=array (analyse-1+ analyse ?array)
=array-type (&&/expr-type =array)]
(return (&/|list (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type)))))
-(defn analyse-jvm-class [analyse ?name ?super-class ?fields]
- (|do [?fields (&/map% (fn [?field]
+(defn ^:private analyse-modifiers [modifiers]
+ (&/fold% (fn [so-far modif]
+ (matchv ::M/objects [modif]
+ [["lux;Meta" [_ ["lux;TextS" "public"]]]]
+ (return (assoc so-far :visibility "public"))
+
+ [["lux;Meta" [_ ["lux;TextS" "private"]]]]
+ (return (assoc so-far :visibility "private"))
+
+ [["lux;Meta" [_ ["lux;TextS" "protected"]]]]
+ (return (assoc so-far :visibility "protected"))
+
+ [["lux;Meta" [_ ["lux;TextS" "static"]]]]
+ (return (assoc so-far :static? true))
+
+ [["lux;Meta" [_ ["lux;TextS" "final"]]]]
+ (return (assoc so-far :final? true))
+
+ [["lux;Meta" [_ ["lux;TextS" "abstract"]]]]
+ (return (assoc so-far :abstract? true))
+
+ [["lux;Meta" [_ ["lux;TextS" "synchronized"]]]]
+ (return (assoc so-far :concurrency "synchronized"))
+
+ [["lux;Meta" [_ ["lux;TextS" "volatile"]]]]
+ (return (assoc so-far :concurrency "volatile"))
+
+ [_]
+ (fail (str "[Analyser Error] Unknown modifier: " (&/show-ast modif)))))
+ {:visibility "default"
+ :static? false
+ :final? false
+ :abstract? false
+ :concurrency nil}
+ modifiers))
+
+(defn ^:private as-otype [tname]
+ (case tname
+ "boolean" "java.lang.Boolean"
+ "byte" "java.lang.Byte"
+ "short" "java.lang.Short"
+ "int" "java.lang.Integer"
+ "long" "java.lang.Long"
+ "float" "java.lang.Float"
+ "double" "java.lang.Double"
+ "char" "java.lang.Character"
+ ;; else
+ tname
+ ))
+
+(defn analyse-jvm-class [analyse ?name ?super-class ?interfaces ?fields ?methods]
+ (|do [=interfaces (&/map% extract-text ?interfaces)
+ =fields (&/map% (fn [?field]
(matchv ::M/objects [?field]
- [["lux;Meta" [_ ["lux;Tuple" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?class]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?field-name]]]
- ["lux;Nil" _]]]]]]]]]
- (return [?class ?field-name])
+ [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-name]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-type]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?field-modifiers]]]
+ ["lux;Nil" _]]]]]]]]]]]
+ (|do [=field-modifiers (analyse-modifiers ?field-modifiers)]
+ (return {:name ?field-name
+ :modifiers =field-modifiers
+ :type ?field-type}))
[_]
- (fail "[Analyser Error] Fields must be Tuple2 of [Symbol, Symbol]")))
+ (fail "[Analyser Error] Wrong syntax for field.")))
?fields)
- :let [=fields (into {} (for [[class field] ?fields]
- [field {:access :public
- :type class}]))]
- $module &/get-module-name]
- (return (&/|list (&/V "jvm-class" (&/T $module ?name ?super-class =fields {}))))))
-
-(defn analyse-jvm-interface [analyse ?name ?members]
- ;; (prn 'analyse-jvm-interface ?name ?members)
- (|do [=members (&/map% (fn [member]
- ;; (prn 'analyse-jvm-interface (&/show-ast member))
- (matchv ::M/objects [member]
- [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ":'"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "->"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?inputs]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?output]]]]
- ["lux;Nil" _]]]]]]]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?member-name]]]]
- ["lux;Nil" _]]]]]]]]]]]
- (do ;; (prn 'analyse-jvm-interface ?member-name ?inputs ?output)
- (|do [inputs* (&/map% extract-ident ?inputs)]
- (return [?member-name [inputs* ?output]])))
+ =methods (&/map% (fn [?method]
+ (matchv ::M/objects [?method]
+ [[?idx ["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-inputs]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-output]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-modifiers]]]
+ ["lux;Cons" [?method-body
+ ["lux;Nil" _]]]]]]]]]]]]]]]]
+ (|do [=method-inputs (&/map% (fn [minput]
+ (matchv ::M/objects [minput]
+ [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?input-name]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]]
+ ["lux;Nil" _]]]]]]]]]
+ (return (&/T (&/ident->text ?input-name) ?input-type))
+
+ [_]
+ (fail "[Analyser Error] Wrong syntax for method input.")))
+ ?method-inputs)
+ =method-modifiers (analyse-modifiers ?method-modifiers)
+ =method-body (&/with-scope (str ?name "_" ?idx)
+ (&/fold (fn [body* input*]
+ (|let [[iname itype] input*]
+ (&&env/with-local iname (&/V "lux;DataT" (as-otype itype))
+ body*)))
+ (if (= "void" ?method-output)
+ (analyse-1+ analyse ?method-body)
+ (&&/analyse-1 analyse (&/V "lux;DataT" (as-otype ?method-output)) ?method-body))
+ (&/|reverse (if (:static? =method-modifiers)
+ =method-inputs
+ (&/|cons (&/T ";this" ?super-class)
+ =method-inputs)))))]
+ (return {:name ?method-name
+ :modifiers =method-modifiers
+ :inputs (&/|map &/|second =method-inputs)
+ :output ?method-output
+ :body =method-body}))
+
+ [_]
+ (fail "[Analyser Error] Wrong syntax for method.")))
+ (&/enumerate ?methods))]
+ (return (&/|list (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods))))))
+
+(defn analyse-jvm-interface [analyse ?name ?supers ?methods]
+ (|do [=supers (&/map% extract-text ?supers)
+ =methods (&/map% (fn [method]
+ (matchv ::M/objects [method]
+ [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?output]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?modifiers]]]
+ ["lux;Nil" _]]]]]]]]]]]]]
+ (|do [=inputs (&/map% extract-text ?inputs)
+ =modifiers (analyse-modifiers ?modifiers)]
+ (return {:name ?method-name
+ :modifiers =modifiers
+ :inputs =inputs
+ :output ?output}))
[_]
- (fail "[Analyser Error] Invalid method signature!")))
- ?members)
- :let [;; _ (prn '=members =members)
- =methods (into {} (for [[method [inputs output]] (&/->seq =members)]
- [method {:access :public
- :type [inputs output]}]))]
- $module &/get-module-name]
- (return (&/|list (&/V "jvm-interface" (&/T $module ?name =methods))))))
-
-(defn analyse-jvm-try [analyse ?body [?catches ?finally]]
- (|do [=body (&&/analyse-1 analyse ?body)
+ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method)))))
+ ?methods)]
+ (return (&/|list (&/V "jvm-interface" (&/T ?name =supers =methods))))))
+
+(defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally]
+ (|do [:let [[?catches ?finally] ?catches+?finally]
+ =body (&&/analyse-1 analyse exo-type ?body)
=catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]]
- (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class)
- (|do [=catch-body (&&/analyse-1 analyse ?catch-body)]
- (return [?ex-class ?ex-arg =catch-body]))))
+ (|do [=catch-body (&&env/with-local (str ";" ?ex-arg) (&/V "lux;DataT" ?ex-class)
+ (&&/analyse-1 analyse exo-type ?catch-body))
+ idx &&env/next-local-idx]
+ (return (&/T ?ex-class idx =catch-body))))
?catches)
- =finally (&&/analyse-1 analyse ?finally)
- =body-type (&&/expr-type =body)]
- (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) =body-type)))))
-
-(defn analyse-jvm-throw [analyse ?ex]
- (|do [=ex (&&/analyse-1 analyse ?ex)]
+ =finally (matchv ::M/objects [?finally]
+ [["lux;None" _]] (return (&/V "lux;None" nil))
+ [["lux;Some" ?finally*]] (|do [=finally (analyse-1+ analyse ?finally*)]
+ (return (&/V "lux;Some" =finally))))]
+ (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type)))))
+
+(defn analyse-jvm-throw [analyse exo-type ?ex]
+ (|do [=ex (analyse-1+ analyse ?ex)
+ :let [[_obj _type] =ex]
+ _ (&type/check (&/V "lux;DataT" "java.lang.Throwable") _type)]
(return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void)))))
-(defn analyse-jvm-monitorenter [analyse ?monitor]
- (|do [=monitor (&&/analyse-1 analyse ?monitor)]
- (return (&/|list (&/T (&/V "jvm-monitorenter" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil)))))))
-
-(defn analyse-jvm-monitorexit [analyse ?monitor]
- (|do [=monitor (&&/analyse-1 analyse ?monitor)]
- (return (&/|list (&/T (&/V "jvm-monitorexit" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil)))))))
+(do-template [<name> <tag>]
+ (defn <name> [analyse exo-type ?monitor]
+ (|do [=monitor (analyse-1+ analyse ?monitor)
+ _ (ensure-object =monitor)
+ :let [output-type &type/Unit]
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V <tag> =monitor) output-type)))))
+
+ analyse-jvm-monitorenter "jvm-monitorenter"
+ analyse-jvm-monitorexit "jvm-monitorexit"
+ )
(do-template [<name> <tag> <from-class> <to-class>]
- (defn <name> [analyse ?value]
- (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value)]
- (return (&/|list (&/T (&/V <tag> =value) (&/V "lux;DataT" <to-class>))))))
+ (let [output-type (&/V "lux;DataT" <to-class>)]
+ (defn <name> [analyse exo-type ?value]
+ (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value)
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V <tag> =value) output-type))))))
analyse-jvm-d2f "jvm-d2f" "java.lang.Double" "java.lang.Float"
analyse-jvm-d2i "jvm-d2i" "java.lang.Double" "java.lang.Integer"
@@ -253,9 +413,11 @@
)
(do-template [<name> <tag> <from-class> <to-class>]
- (defn <name> [analyse ?value]
- (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value)]
- (return (&/|list (&/T (&/V <tag> =value) (&/V "lux;DataT" <to-class>))))))
+ (let [output-type (&/V "lux;DataT" <to-class>)]
+ (defn <name> [analyse exo-type ?value]
+ (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value)
+ _ (&type/check exo-type output-type)]
+ (return (&/|list (&/T (&/V <tag> =value) output-type))))))
analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer"
analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer"
@@ -270,11 +432,8 @@
)
(defn analyse-jvm-program [analyse ?args ?body]
- (|do [;; =body (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text))
- ;; (&&/analyse-1 analyse ?body))
- =body (&/with-scope ""
- (&&env/with-local "" (&/V "lux;AppT" (&/T &type/List &type/Text))
- (analyse-1+ analyse ?body)))
- ;; =body (analyse-1+ analyse ?body)
- ]
- (return (&/|list (&/V "jvm-program" =body)))))
+ (|let [[_module _name] ?args]
+ (|do [=body (&/with-scope ""
+ (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text))
+ (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))]
+ (return (&/|list (&/V "jvm-program" =body))))))
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index 859f47e56..b1b9e2c22 100644
--- a/src/lux/analyser/lambda.clj
+++ b/src/lux/analyser/lambda.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.analyser.lambda
(:require [clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
@@ -8,8 +16,6 @@
;; [Resource]
(defn with-lambda [self self-type arg arg-type body]
- ;; (prn 'with-lambda (&/|length self) (&/|length arg))
- ;; (prn 'with-lambda [(aget self 0) (aget self 1)] [(aget arg 0) (aget arg 1)] (alength self) (alength arg))
(|let [[?module1 ?name1] self
[?module2 ?name2] arg]
(&/with-closure
@@ -21,11 +27,6 @@
(return (&/T scope-name =captured =return)))))))))
(defn close-over [scope ident register frame]
- ;; (prn 'close-over
- ;; (&host/location scope)
- ;; (&host/location (&/|list ident))
- ;; register
- ;; (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)))
(matchv ::M/objects [register]
[[_ register-type]]
(|let [register* (&/T (&/V "captured" (&/T scope
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 2a68e0aeb..065e150d9 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.analyser.lux
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
@@ -15,7 +23,6 @@
(defn ^:private analyse-1+ [analyse ?token]
(&type/with-var
(fn [$var]
- ;; (prn 'analyse-1+ (aget $var 1) (&/show-ast ?token))
(|do [=expr (&&/analyse-1 analyse $var ?token)]
(matchv ::M/objects [=expr]
[[?item ?type]]
@@ -23,18 +30,19 @@
(return (&/T ?item =type)))
)))))
+(defn ^:private with-cursor [cursor form]
+ (matchv ::M/objects [form]
+ [["lux;Meta" [_ syntax]]]
+ (&/V "lux;Meta" (&/T cursor syntax))))
+
;; [Exports]
(defn analyse-tuple [analyse exo-type ?elems]
- ;; (prn "^^ analyse-tuple ^^")
- ;; (prn 'analyse-tuple (str "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")
- ;; (&type/show-type exo-type))
(|do [exo-type* (&type/actual-type exo-type)]
(matchv ::M/objects [exo-type*]
[["lux;TupleT" ?members]]
- (|do [=elems (&/map% (fn [ve]
- (|let [[elem-t elem] ve]
- (&&/analyse-1 analyse elem-t elem)))
- (&/zip2 ?members ?elems))]
+ (|do [=elems (&/map2% (fn [elem-t elem]
+ (&&/analyse-1 analyse elem-t elem))
+ ?members ?elems)]
(return (&/|list (&/T (&/V "tuple" =elems)
exo-type))))
@@ -48,28 +56,20 @@
(fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))))
(defn analyse-variant [analyse exo-type ident ?value]
- ;; (prn "^^ analyse-variant ^^")
- (|do [;; :let [_ (prn 'analyse-variant/exo-type (&type/show-type exo-type))]
- exo-type* (matchv ::M/objects [exo-type]
+ (|do [exo-type* (matchv ::M/objects [exo-type]
[["lux;VarT" ?id]]
- (&/try-all% (&/|list (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id)
- (fail "##8##")))]
+ (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)]
(&type/actual-type exo-type*))
(|do [_ (&type/set-var ?id &type/Type)]
(&type/actual-type &type/Type))))
[_]
- (&type/actual-type exo-type))
- ;; :let [_ (prn 'analyse-variant/exo-type* (&type/show-type exo-type*))]
- ]
+ (&type/actual-type exo-type))]
(matchv ::M/objects [exo-type*]
[["lux;VariantT" ?cases]]
(|do [?tag (&&/resolved-ident ident)]
(if-let [vtype (&/|get ?tag ?cases)]
- (|do [;; :let [_ (prn 'VARIANT_BODY ?tag (&/show-ast ?value) (&type/show-type vtype))]
- =value (&&/analyse-1 analyse vtype ?value)
- ;; :let [_ (prn 'GOT_VALUE =value)]
- ]
+ (|do [=value (&&/analyse-1 analyse vtype ?value)]
(return (&/|list (&/T (&/V "variant" (&/T ?tag =value))
exo-type))))
(fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*)))))
@@ -86,10 +86,18 @@
(defn analyse-record [analyse exo-type ?elems]
(|do [exo-type* (matchv ::M/objects [exo-type]
[["lux;VarT" ?id]]
- (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id)
- (fail "##7##")))]
+ (|do [exo-type* (&type/deref ?id)]
(&type/actual-type exo-type*))
+ [["lux;AllT" _]]
+ (|do [$var &type/existential
+ =type (&type/apply-type exo-type $var)]
+ (&type/actual-type =type))
+ ;; (&type/with-var
+ ;; (fn [$var]
+ ;; (|do [=type (&type/apply-type exo-type $var)]
+ ;; (&type/actual-type =type))))
+
[_]
(&type/actual-type exo-type))
types (matchv ::M/objects [exo-type*]
@@ -97,15 +105,16 @@
(return ?table)
[_]
- (fail "[Analyser Error] The type of a record must be a record type."))
+ (fail (str "[Analyser Error] The type of a record must be a record type:\n"
+ (&type/show-type exo-type*)
+ "\n")))
=slots (&/map% (fn [kv]
(matchv ::M/objects [kv]
- [[["lux;Meta" [_ ["lux;Tag" ?ident]]] ?value]]
+ [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]]
(|do [?tag (&&/resolved-ident ?ident)
slot-type (if-let [slot-type (&/|get ?tag types)]
(return slot-type)
(fail (str "[Analyser Error] Record type does not have slot: " ?tag)))
- ;; :let [_ (prn 'slot ?tag (&/show-ast ?value) (&type/show-type slot-type))]
=value (&&/analyse-1 analyse slot-type ?value)]
(return (&/T ?tag =value)))
@@ -118,214 +127,192 @@
(|do [module-name &/get-module-name]
(fn [state]
(|let [[?module ?name] ident
- ;; _ (prn 'analyse-symbol ?module ?name)
+ ;; _ (prn 'analyse-symbol/_0 ?module ?name)
local-ident (str ?module ";" ?name)
stack (&/get$ &/$ENVS state)
no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not)
(->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not))
[inner outer] (&/|split-with no-binding? stack)]
- (do ;; (when (= "<" ?name)
- ;; (prn 'HALLO (&/|length inner) (&/|length outer)))
- (matchv ::M/objects [outer]
- [["lux;Nil" _]]
- (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module)
- ?name)
- endo-type (matchv ::M/objects [$def]
- [["lux;ValueD" ?type]]
- (return ?type)
-
- [["lux;MacroD" _]]
- (return &type/Macro)
-
- [["lux;TypeD" _]]
- (return &type/Type))
- ;; :let [_ (println "Got endo-type:" endo-type)]
- _ (if (and (= &type/Type endo-type) (= &type/Type exo-type))
- (do ;; (println "OH YEAH" (if (= "" ?module) module-name ?module)
- ;; ?name)
- (return nil))
- (&type/check exo-type endo-type))
- ;; :let [_ (println "Type-checked:" exo-type endo-type)]
- ]
- (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name))
- endo-type))))
- state)
-
- [["lux;Cons" [?genv ["lux;Nil" _]]]]
- (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))]
- (do (when (= "<" ?name)
- (prn 'GOT_GLOBAL local-ident))
- (matchv ::M/objects [global]
- [[["lux;Global" [?module* ?name*]] _]]
- (&/run-state (|do [;; :let [_ (prn 'GLOBAL/_1 ?module* ?name*)]
- ;; :let [_ (when (= "<" ?name)
- ;; (println "Pre Found def:" ?module* ?name*))]
- [[r-module r-name] $def] (&&module/find-def ?module* ?name*)
- ;; :let [_ (prn 'GLOBAL/_2 r-module r-name)]
- ;; :let [_ (when (= "<" ?name)
- ;; (println "Found def:" r-module r-name))]
- endo-type (matchv ::M/objects [$def]
- [["lux;ValueD" ?type]]
- (return ?type)
-
- [["lux;MacroD" _]]
- (return &type/Macro)
-
- [["lux;TypeD" _]]
- (return &type/Type))
- ;; :let [_ (println "Got endo-type:" endo-type)]
- _ (if (and (= &type/Type endo-type) (= &type/Type exo-type))
- (do ;; (println "OH YEAH" ?module* ?name*)
- (return nil))
- (&type/check exo-type endo-type))
- ;; :let [_ (println "Type-checked:" exo-type endo-type)]
- ;; :let [_ (when (= "<" ?name)
- ;; (println "Returnin'"))]
- ]
- (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name))
- endo-type))))
- state)
-
- [_]
- (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))
- (fail* ""))
-
- [["lux;Cons" [top-outer _]]]
- (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1)
- (&/|map #(&/get$ &/$NAME %) outer)
- (&/|reverse inner)))
- [=local inner*] (&/fold (fn [register+new-inner frame+in-scope]
- (|let [[register new-inner] register+new-inner
- [frame in-scope] frame+in-scope
- [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)]
- (&/T register* (&/|cons frame* new-inner))))
- (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))
- (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident)))
- (&/|list))
- (&/zip2 (&/|reverse inner) scopes))]
- (&/run-state (|do [btype (&&/expr-type =local)
- _ (&type/check exo-type btype)]
- (return (&/|list =local)))
- (&/set$ &/$ENVS (&/|++ inner* outer) state)))
- ))))
+ (matchv ::M/objects [outer]
+ [["lux;Nil" _]]
+ (do ;; (prn 'analyse-symbol/_1
+ ;; [?module ?name]
+ ;; [(if (.equals "" ?module) module-name ?module)
+ ;; ?name])
+ ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module)
+ ?name)
+ ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)]
+ endo-type (matchv ::M/objects [$def]
+ [["lux;ValueD" ?type]]
+ (return ?type)
+
+ [["lux;MacroD" _]]
+ (return &type/Macro)
+
+ [["lux;TypeD" _]]
+ (return &type/Type))
+ _ (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))]
+ (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name))
+ endo-type))))
+ state))
+
+ [["lux;Cons" [?genv ["lux;Nil" _]]]]
+ (do ;; (prn 'analyse-symbol/_2 ?module ?name local-ident (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq))
+ (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))]
+ (do ;; (prn 'analyse-symbol/_2.1 ?module ?name local-ident (aget global 0))
+ (matchv ::M/objects [global]
+ [[["lux;Global" [?module* ?name*]] _]]
+ ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*)
+ ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)]
+ endo-type (matchv ::M/objects [$def]
+ [["lux;ValueD" ?type]]
+ (return ?type)
+
+ [["lux;MacroD" _]]
+ (return &type/Macro)
+
+ [["lux;TypeD" _]]
+ (return &type/Type))
+ _ (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))]
+ (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name))
+ endo-type))))
+ state)
+
+ [_]
+ (do ;; (prn 'analyse-symbol/_2.1.2 ?module ?name local-ident)
+ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))))
+ (fail* "_{_ analyse-symbol _}_")))
+
+ [["lux;Cons" [top-outer _]]]
+ (do ;; (prn 'analyse-symbol/_3 ?module ?name)
+ (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1)
+ (&/|map #(&/get$ &/$NAME %) outer)
+ (&/|reverse inner)))
+ [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope]
+ (|let [[register new-inner] register+new-inner
+ [register* frame*] (&&lambda/close-over (&/|reverse in-scope) ident register frame)]
+ (&/T register* (&/|cons frame* new-inner))))
+ (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))
+ (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident)))
+ (&/|list))
+ (&/|reverse inner) scopes)]
+ ((|do [btype (&&/expr-type =local)
+ _ (&type/check exo-type btype)]
+ (return (&/|list =local)))
+ (&/set$ &/$ENVS (&/|++ inner* outer) state))))
+ )))
))
-(defn ^:private analyse-apply* [analyse exo-type =fn ?args]
- ;; (prn 'analyse-apply* (&/->seq (&/|map &/show-ast ?args)))
- ;; (prn 'analyse-apply*/exo-type (&type/show-type exo-type))
- (matchv ::M/objects [=fn]
- [[?fun-expr ?fun-type]]
- (matchv ::M/objects [?args]
- [["lux;Nil" _]]
- (|do [_ (&type/check exo-type ?fun-type)]
- (return =fn))
-
- [["lux;Cons" [?arg ?args*]]]
- (|do [?fun-type* (&type/actual-type ?fun-type)]
- (matchv ::M/objects [?fun-type*]
- [["lux;AllT" _]]
- (&type/with-var
- (fn [$var]
- (|do [type* (&type/apply-type ?fun-type* $var)
- output (analyse-apply* analyse exo-type (&/T ?fun-expr type*) ?args)]
- (matchv ::M/objects [output $var]
- [[?expr* ?type*] ["lux;VarT" ?id]]
- ;; (|do [? (&type/bound? ?id)]
- ;; (if ?
- ;; (return (&/T ?expr* ?type*))
- ;; (|do [type** (&type/clean $var ?type*)]
- ;; (return (&/T ?expr* type**)))))
- (|do [? (&type/bound? ?id)
- _ (if ?
- (return nil)
- (|do [ex &type/existential]
- (&type/set-var ?id ex)))
- type** (&type/clean $var ?type*)]
- (return (&/T ?expr* type**)))
- ))))
-
- [["lux;LambdaT" [?input-t ?output-t]]]
- ;; (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)]
- ;; (return (&/T (&/V "apply" (&/T =fn =arg))
- ;; ?output-t)))
- (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)]
- (analyse-apply* analyse exo-type (&/T (&/V "apply" (&/T =fn =arg))
- ?output-t)
- ?args*))
-
- [_]
- (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))))
- )))
+(defn ^:private analyse-apply* [analyse exo-type fun-type ?args]
+ ;; (prn 'analyse-apply* (aget fun-type 0))
+ (matchv ::M/objects [?args]
+ [["lux;Nil" _]]
+ (|do [_ (&type/check exo-type fun-type)]
+ (return (&/T fun-type (&/|list))))
+
+ [["lux;Cons" [?arg ?args*]]]
+ (|do [?fun-type* (&type/actual-type fun-type)]
+ (matchv ::M/objects [?fun-type*]
+ [["lux;AllT" [_aenv _aname _aarg _abody]]]
+ ;; (|do [$var &type/existential
+ ;; type* (&type/apply-type ?fun-type* $var)]
+ ;; (analyse-apply* analyse exo-type type* ?args))
+ (&type/with-var
+ (fn [$var]
+ (|do [type* (&type/apply-type ?fun-type* $var)
+ [=output-t =args] (analyse-apply* analyse exo-type type* ?args)]
+ (matchv ::M/objects [$var]
+ [["lux;VarT" ?id]]
+ (|do [? (&type/bound? ?id)
+ type** (if ?
+ (&type/clean $var =output-t)
+ (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _aarg))]
+ (&type/clean $var =output-t)))]
+ (return (&/T type** =args)))
+ ))))
+
+ [["lux;LambdaT" [?input-t ?output-t]]]
+ (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*)
+ =arg (&&/analyse-1 analyse ?input-t ?arg)]
+ (return (&/T =output-t (&/|cons =arg =args))))
+
+ ;; [["lux;VarT" ?id-t]]
+ ;; (|do [ (&type/deref ?id-t)])
+
+ [_]
+ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))))
+ ))
-(defn analyse-apply [analyse exo-type =fn ?args]
- ;; (prn 'analyse-apply1 (aget =fn 0))
+(defn analyse-apply [analyse exo-type form-cursor =fn ?args]
(|do [loader &/loader]
(matchv ::M/objects [=fn]
[[=fn-form =fn-type]]
- (do ;; (prn 'analyse-apply2 (aget =fn-form 0))
- (matchv ::M/objects [=fn-form]
- [["lux;Global" [?module ?name]]]
- (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)
- ;; :let [_ (prn 'apply [?module ?name] (aget $def 0))]
+ (matchv ::M/objects [=fn-form]
+ [["lux;Global" [?module ?name]]]
+ (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)]
+ (matchv ::M/objects [$def]
+ [["lux;MacroD" macro]]
+ (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))
+ :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)]
+ ;; :let [_ (when (and ;; (= "lux/control/monad" ?module)
+ ;; (= "case" ?name))
+ ;; (->> (&/|map &/show-ast macro-expansion*)
+ ;; (&/|interpose "\n")
+ ;; (&/fold str "")
+ ;; (prn ?module "case")))]
]
- (matchv ::M/objects [$def]
- [["lux;MacroD" macro]]
- (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))
- ;; :let [_ (cond (= ?name "using")
- ;; (println (str "using: " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))
-
- ;; ;; (= ?name "def")
- ;; ;; (println (str "def " ?module ";" ?name ": " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))
-
- ;; ;; (= ?name "type`")
- ;; ;; (println (str "type`: " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))
-
- ;; :else
- ;; nil)]
- ]
- (&/flat-map% (partial analyse exo-type) macro-expansion))
+ (&/flat-map% (partial analyse exo-type) macro-expansion*))
- [_]
- (|do [output (analyse-apply* analyse exo-type =fn ?args)]
- (return (&/|list output)))))
-
[_]
- (|do [output (analyse-apply* analyse exo-type =fn ?args)]
- (return (&/|list output)))))
+ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
+ (return (&/|list (&/T (&/V "apply" (&/T =fn =args))
+ =output-t))))))
+
+ [_]
+ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
+ (return (&/|list (&/T (&/V "apply" (&/T =fn =args))
+ =output-t)))))
)))
(defn analyse-case [analyse exo-type ?value ?branches]
- ;; (prn 'analyse-case 'exo-type (&type/show-type exo-type) (&/show-ast ?value))
(|do [:let [num-branches (&/|length ?branches)]
_ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.")
_ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.")
=value (analyse-1+ analyse ?value)
=value-type (&&/expr-type =value)
- ;; :let [_ (prn 'analyse-case/GOT_VALUE (&type/show-type =value-type))]
- =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))
- ;; :let [_ (prn 'analyse-case/GOT_MATCH)]
- ]
+ =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))]
(return (&/|list (&/T (&/V "case" (&/T =value =match))
exo-type)))))
(defn analyse-lambda* [analyse exo-type ?self ?arg ?body]
- ;; (prn 'analyse-lambda ?self ?arg ?body)
- (matchv ::M/objects [exo-type]
- [["lux;LambdaT" [?arg-t ?return-t]]]
- (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type
- ?arg ?arg-t
- (&&/analyse-1 analyse ?return-t ?body))]
- (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type)))
-
- [_]
- (fail (str "[Analyser Error] Functions require function types: "
- ;; (str (aget ?self 0) ";" (aget ?self 1))
- ;; (str( aget ?arg 0) ";" (aget ?arg 1))
- ;; (&/show-ast ?body)
- (&type/show-type exo-type)))))
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (matchv ::M/objects [exo-type]
+ [["lux;AllT" _]]
+ (&type/with-var
+ (fn [$var]
+ (|do [exo-type** (&type/apply-type exo-type* $var)]
+ (analyse-lambda* analyse exo-type** ?self ?arg ?body))))
+ ;; (|do [$var &type/existential
+ ;; exo-type** (&type/apply-type exo-type* $var)]
+ ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body))
+
+ [["lux;LambdaT" [?arg-t ?return-t]]]
+ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type*
+ ?arg ?arg-t
+ (&&/analyse-1 analyse ?return-t ?body))]
+ (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*)))
+
+ [_]
+ (fail (str "[Analyser Error] Functions require function types: "
+ (&type/show-type exo-type*))))))
(defn analyse-lambda** [analyse exo-type ?self ?arg ?body]
- ;; (prn 'analyse-lambda**/&& (aget exo-type 0))
(matchv ::M/objects [exo-type]
[["lux;AllT" [_env _self _arg _body]]]
(&type/with-var
@@ -336,12 +323,24 @@
[["lux;VarT" ?id]]
(|do [? (&type/bound? ?id)]
(if ?
- (|do [dtype (&/try-all% (&/|list (&type/deref ?id)
- (fail "##6##")))]
+ (|do [dtype (&type/deref ?id)
+ ;; dtype* (&type/actual-type dtype)
+ ]
(matchv ::M/objects [dtype]
+ [["lux;BoundT" ?vname]]
+ (return (&/T _expr exo-type))
+
[["lux;ExT" _]]
(return (&/T _expr exo-type))
+ [["lux;VarT" ?_id]]
+ (|do [?? (&type/bound? ?_id)]
+ ;; (return (&/T _expr exo-type))
+ (if ??
+ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype)))
+ (return (&/T _expr exo-type)))
+ )
+
[_]
(fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype)))))
(return (&/T _expr exo-type))))))))
@@ -351,55 +350,32 @@
(analyse-lambda* analyse exo-type* ?self ?arg ?body))
))
-;; (defn analyse-lambda** [analyse exo-type ?self ?arg ?body]
-;; ;; (prn 'analyse-lambda**/&& (aget exo-type 0))
-;; (matchv ::M/objects [exo-type]
-;; [["lux;AllT" [_env _self _arg _body]]]
-;; (&type/with-var
-;; (fn [$var]
-;; (|do [exo-type* (&type/apply-type exo-type $var)
-;; output (analyse-lambda** analyse exo-type* ?self ?arg ?body)]
-;; (matchv ::M/objects [$var]
-;; [["lux;VarT" ?id]]
-;; (|do [? (&type/bound? ?id)]
-;; (if ?
-;; (|do [dtype (&type/deref ?id)]
-;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))
-;; (return output)))))))
-
-;; [_]
-;; (|do [exo-type* (&type/actual-type exo-type)]
-;; (analyse-lambda* analyse exo-type* ?self ?arg ?body))
-;; ))
-
(defn analyse-lambda [analyse exo-type ?self ?arg ?body]
(|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)]
(return (&/|list output))))
(defn analyse-def [analyse ?name ?value]
- ;; (prn 'analyse-def/CODE ?name (&/show-ast ?value))
- (prn 'analyse-def/BEGIN ?name)
+ ;; (prn 'analyse-def/BEGIN ?name)
(|do [module-name &/get-module-name
? (&&module/defined? module-name ?name)]
(if ?
- (fail (str "[Analyser Error] Can't redefine " ?name))
- (|do [;; :let [_ (prn 'analyse-def/_0)]
- =value (&/with-scope ?name
+ (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
+ (|do [=value (&/with-scope ?name
(analyse-1+ analyse ?value))
- =value-type (&&/expr-type =value)
- ;; :let [_ (prn 'analyse-def/_1 [?name ?value] (aget =value 0 0))]
- ]
+ =value-type (&&/expr-type =value)]
(matchv ::M/objects [=value]
[[["lux;Global" [?r-module ?r-name]] _]]
(|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type)
- :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name))
- _ (println)]]
+ ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name))
+ ;; _ (println)]
+ ]
(return (&/|list)))
[_]
(|do [=value-type (&&/expr-type =value)
- :let [_ (prn 'analyse-def/END ?name)
- _ (println)
+ :let [;; _ (prn 'analyse-def/END ?name)
+ _ (println 'DEF (str module-name ";" ?name))
+ ;; _ (println)
def-data (cond (&type/type= &type/Type =value-type)
(&/V "lux;TypeD" nil)
@@ -410,41 +386,43 @@
))))
(defn analyse-declare-macro [analyse ?name]
- (|do [module-name &/get-module-name
- _ (&&module/declare-macro module-name ?name)]
- (return (&/|list))))
-
-(defn analyse-declare-macro [analyse ?name]
(|do [module-name &/get-module-name]
(return (&/|list (&/V "declare-macro" (&/T module-name ?name))))))
-(defn analyse-import [analyse exo-type ?path]
- (return (&/|list)))
+(defn analyse-import [analyse compile-module ?path]
+ (|do [module-name &/get-module-name
+ _ (if (= module-name ?path)
+ (fail (str "[Analyser Error] Module can't import itself: " ?path))
+ (return nil))]
+ (&/save-module
+ (|do [already-compiled? (&&module/exists? ?path)
+ ;; :let [_ (prn 'analyse-import module-name ?path already-compiled?)]
+ _ (&&module/add-import ?path)
+ _ (&/when% (not already-compiled?) (compile-module ?path))]
+ (return (&/|list))))))
(defn analyse-export [analyse name]
(|do [module-name &/get-module-name
_ (&&module/export module-name name)]
(return (&/|list))))
+(defn analyse-alias [analyse ex-alias ex-module]
+ (|do [module-name &/get-module-name
+ _ (&&module/alias module-name ex-alias ex-module)]
+ (return (&/|list))))
+
(defn analyse-check [analyse eval! exo-type ?type ?value]
- ;; (println "analyse-check#0")
(|do [=type (&&/analyse-1 analyse &type/Type ?type)
- ;; =type (analyse-1+ analyse ?type)
- ;; :let [_ (println "analyse-check#1")]
==type (eval! =type)
_ (&type/check exo-type ==type)
- ;; :let [_ (println "analyse-check#4" (&type/show-type ==type))]
- =value (&&/analyse-1 analyse ==type ?value)
- ;; :let [_ (println "analyse-check#5")]
- ]
- (matchv ::M/objects [=value]
- [[?expr ?expr-type]]
- (return (&/|list (&/T ?expr ==type))))))
+ =value (&&/analyse-1 analyse ==type ?value)]
+ (return (&/|list (&/T (&/V "ann" (&/T =value =type))
+ ==type)))))
(defn analyse-coerce [analyse eval! exo-type ?type ?value]
(|do [=type (&&/analyse-1 analyse &type/Type ?type)
==type (eval! =type)
+ _ (&type/check exo-type ==type)
=value (&&/analyse-1 analyse ==type ?value)]
- (matchv ::M/objects [=value]
- [[?expr ?expr-type]]
- (return (&/|list (&/T ?expr ==type))))))
+ (return (&/|list (&/T (&/V "ann" (&/T =value =type))
+ ==type)))))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index de68f48aa..68cdc4747 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -1,89 +1,153 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.analyser.module
- (:require [clojure.core.match :as M :refer [matchv]]
+ (:refer-clojure :exclude [alias])
+ (:require [clojure.string :as string]
+ [clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [|do return return* fail fail*]]
+ (lux [base :as & :refer [|let |do return return* fail fail*]]
[type :as &type]
[host :as &host])
[lux.analyser.base :as &&]))
+;; [Utils]
+(def ^:private $DEFS 0)
+(def ^:private $ALIASES 1)
+(def ^:private $IMPORTS 2)
+(def ^:private +init+
+ (&/R ;; "lux;defs"
+ (&/|table)
+ ;; "lux;module-aliases"
+ (&/|table)
+ ;; "lux;imports"
+ (&/|list)
+ ))
+
;; [Exports]
-(def init-module
- (&/|table))
+(defn add-import [module]
+ "(-> Text (Lux (,)))"
+ (|do [current-module &/get-module-name]
+ (fn [state]
+ (return* (&/update$ &/$MODULES
+ (fn [ms]
+ (&/|update current-module
+ (fn [m] (&/update$ $IMPORTS (partial &/|cons module) m))
+ ms))
+ state)
+ nil))))
(defn define [module name def-data type]
(fn [state]
(matchv ::M/objects [(&/get$ &/$ENVS state)]
[["lux;Cons" [?env ["lux;Nil" _]]]]
(return* (->> state
- (&/update$ &/$MODULES (fn [ms]
- (&/|update module #(&/|put name (&/T false def-data) %)
- ms)))
- (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals]
- (&/update$ &/$MAPPINGS (fn [mappings]
- (&/|put (str "" &/+name-separator+ name)
- (&/T (&/V "lux;Global" (&/T module name)) type)
- mappings))
- locals))
- ?env))))
+ (&/update$ &/$MODULES
+ (fn [ms]
+ (&/|update module
+ (fn [m]
+ (&/update$ $DEFS
+ #(&/|put name (&/T false def-data) %)
+ m))
+ ms))))
nil)
[_]
- (fail* "[Analyser Error] Can't create a new global definition outside of a global environment."))))
+ (fail* (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name)))))
+
+(defn def-type [module name]
+ "(-> Text Text (Lux Type))"
+ (fn [state]
+ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))]
+ (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))]
+ (matchv ::M/objects [$def]
+ [[_ ["lux;TypeD" _]]]
+ (return* state &type/Type)
+
+ [[_ ["lux;MacroD" _]]]
+ (return* state &type/Macro)
+
+ [[_ ["lux;ValueD" _type]]]
+ (return* state _type)
+
+ [[_ ["lux;AliasD" [?r-module ?r-name]]]]
+ (&/run-state (def-type ?r-module ?r-name)
+ state))
+ (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name))))
+ (fail* (str "[Analyser Error] Unknown module: " module)))))
(defn def-alias [a-module a-name r-module r-name type]
+ ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type))
(fn [state]
- ;; (prn 'def-alias [a-module a-name] '=> [r-module r-name])
(matchv ::M/objects [(&/get$ &/$ENVS state)]
[["lux;Cons" [?env ["lux;Nil" _]]]]
(return* (->> state
- (&/update$ &/$MODULES (fn [ms]
- (&/|update a-module #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %)
- ms)))
- (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals]
- (&/update$ &/$MAPPINGS (fn [mappings]
- (&/|put (str "" &/+name-separator+ a-name)
- (&/T (&/V "lux;Global" (&/T r-module r-name)) type)
- mappings))
- locals))
- ?env))))
+ (&/update$ &/$MODULES
+ (fn [ms]
+ (&/|update a-module
+ (fn [m]
+ (&/update$ $DEFS
+ #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %)
+ m))
+ ms))))
nil)
[_]
(fail* "[Analyser Error] Can't alias a global definition outside of a global environment."))))
(defn exists? [name]
+ "(-> Text (Lux Bool))"
(fn [state]
- ;; (prn `exists? name (->> state (&/get$ &/$MODULES) (&/|contains? name)))
(return* state
(->> state (&/get$ &/$MODULES) (&/|contains? name)))))
-(defn dealias [name]
+(defn alias [module alias reference]
(fn [state]
- (if-let [real-name (->> state (&/get$ &/$MODULE-ALIASES) (&/|get name))]
- (return* state real-name)
- (fail* (str "Unknown alias: " name)))))
+ (return* (->> state
+ (&/update$ &/$MODULES
+ (fn [ms]
+ (&/|update module
+ #(&/update$ $ALIASES
+ (fn [aliases]
+ (&/|put alias reference aliases))
+ %)
+ ms))))
+ nil)))
+
+(defn dealias [name]
+ (|do [current-module &/get-module-name]
+ (fn [state]
+ (if-let [real-name (->> state (&/get$ &/$MODULES) (&/|get current-module) (&/get$ $ALIASES) (&/|get name))]
+ (return* state real-name)
+ (fail* (str "Unknown alias: " name))))))
(defn find-def [module name]
(|do [current-module &/get-module-name]
(fn [state]
+ ;; (prn 'find-def/_0 module name 'current-module current-module)
(if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))]
- (if-let [$def (&/|get name $module)]
- (matchv ::M/objects [$def]
- [[exported? $$def]]
- (if (or exported? (= current-module module))
- (matchv ::M/objects [$$def]
- [["lux;AliasD" [?r-module ?r-name]]]
- (&/run-state (find-def ?r-module ?r-name)
- state)
-
- [_]
- (return* state (&/T (&/T module name) $$def)))
- (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))
- (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name))))
- (do (prn [module name]
- (str "[Analyser Error] Module doesn't exist: " module)
- (->> state (&/get$ &/$MODULES) &/|keys &/->seq))
- (fail* (str "[Analyser Error] Module doesn't exist: " module)))))))
+ (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module)))
+ (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))]
+ (matchv ::M/objects [$def]
+ [[exported? $$def]]
+ (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module))
+ (if (or exported? (.equals ^Object current-module module))
+ (matchv ::M/objects [$$def]
+ [["lux;AliasD" [?r-module ?r-name]]]
+ (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name])
+ ((find-def ?r-module ?r-name)
+ state))
+
+ [_]
+ (return* state (&/T (&/T module name) $$def)))
+ (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))))))
+ (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))))
+ (fail* (str "[Analyser Error] Module doesn't exist: " module))))))
(defn defined? [module name]
(&/try-all% (&/|list (|do [_ (find-def module name)]
@@ -92,38 +156,41 @@
(defn declare-macro [module name]
(fn [state]
- (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))]
+ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))]
(if-let [$def (&/|get name $module)]
(matchv ::M/objects [$def]
[[exported? ["lux;ValueD" ?type]]]
- (do ;; (prn 'declare-macro/?type (aget ?type 0))
- (&/run-state (|do [_ (&type/check &type/Macro ?type)
- ^ClassLoader loader &/loader
- :let [macro (-> (.loadClass loader (&host/location (&/|list module name)))
- (.getField "_datum")
- (.get nil))]]
- (fn [state*]
- (return* (&/update$ &/$MODULES
- (fn [$modules]
- (&/|put module (&/|put name (&/T exported? (&/V "lux;MacroD" macro)) $module)
- $modules))
- state*)
- nil)))
- state))
+ ((|do [_ (&type/check &type/Macro ?type)
+ ^ClassLoader loader &/loader
+ :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name)))
+ (.getField "_datum")
+ (.get nil))]]
+ (fn [state*]
+ (return* (&/update$ &/$MODULES
+ (fn [$modules]
+ (&/|update module
+ (fn [m]
+ (&/update$ $DEFS
+ #(&/|put name (&/T exported? (&/V "lux;MacroD" macro)) %)
+ m))
+ $modules))
+ state*)
+ nil)))
+ state)
[[_ ["lux;MacroD" _]]]
(fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name)))
[[_ ["lux;TypeD" _]]]
- (fail* (str "[Analyser Error] Definition doesn't have macro type: " module ";" name)))
- (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name))))
- (fail* (str "[Analyser Error] Module doesn't exist: " module)))))
+ (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name))))
+ (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))
+ (fail* (str "[Analyser Error] Module does not exist: " module)))))
(defn export [module name]
(fn [state]
(matchv ::M/objects [(&/get$ &/$ENVS state)]
[["lux;Cons" [?env ["lux;Nil" _]]]]
- (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/|get name))]
+ (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))]
(matchv ::M/objects [$def]
[[true _]]
(fail* (str "[Analyser Error] Definition has already been exported: " module ";" name))
@@ -131,10 +198,52 @@
[[false ?data]]
(return* (->> state
(&/update$ &/$MODULES (fn [ms]
- (&/|update module #(&/|put name (&/T true ?data) %)
+ (&/|update module (fn [m]
+ (&/update$ $DEFS
+ #(&/|put name (&/T true ?data) %)
+ m))
ms))))
nil))
- (fail* (str "[Analyser Error] Can't export an inexistent definition: " module ";" name)))
+ (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name))))
[_]
(fail* "[Analyser Error] Can't export a global definition outside of a global environment."))))
+
+(def defs
+ (|do [module &/get-module-name]
+ (fn [state]
+ (return* state
+ (&/|map (fn [kv]
+ (|let [[k v] kv]
+ (matchv ::M/objects [v]
+ [[?exported? ?def]]
+ (do ;; (prn 'defs k ?exported?)
+ (matchv ::M/objects [?def]
+ [["lux;AliasD" [?r-module ?r-name]]]
+ (&/T ?exported? k (str "A" ?r-module ";" ?r-name))
+
+ [["lux;MacroD" _]]
+ (&/T ?exported? k "M")
+
+ [["lux;TypeD" _]]
+ (&/T ?exported? k "T")
+
+ [_]
+ (&/T ?exported? k "V"))))))
+ (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS)))))))
+
+(def imports
+ (|do [module &/get-module-name]
+ (fn [state]
+ (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS))))))
+
+(defn create-module [name]
+ (fn [state]
+ (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil)))
+
+(defn enter-module [name]
+ (fn [state]
+ (return* (->> state
+ (&/update$ &/$MODULES #(&/|put name +init+ %))
+ (&/set$ &/$ENVS (&/|list (&/env name))))
+ nil)))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 70a658d19..eb94c2c90 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.base
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
@@ -15,14 +23,14 @@
(def $NAME 3)
;; Host
-(def $EVAL-CTOR 0)
+(def $CLASSES 0)
(def $LOADER 1)
(def $WRITER 2)
;; CompilerState
(def $ENVS 0)
-(def $HOST 1)
-(def $MODULE-ALIASES 2)
+(def $EVAL? 1)
+(def $HOST 2)
(def $MODULES 3)
(def $SEED 4)
(def $SOURCE 5)
@@ -81,13 +89,12 @@
(reverse (partition 2 elems))))
(defn |get [slot table]
- ;; (prn '|get slot (aget table 0))
(matchv ::M/objects [table]
[["lux;Nil" _]]
nil
[["lux;Cons" [[k v] table*]]]
- (if (= k slot)
+ (if (.equals ^Object k slot)
v
(|get slot table*))))
@@ -97,7 +104,7 @@
(V "lux;Cons" (T (T slot value) (V "lux;Nil" nil)))
[["lux;Cons" [[k v] table*]]]
- (if (= k slot)
+ (if (.equals ^Object k slot)
(V "lux;Cons" (T (T slot value) table*))
(V "lux;Cons" (T (T k v) (|put slot value table*))))))
@@ -107,26 +114,17 @@
table
[["lux;Cons" [[k v] table*]]]
- (if (= k slot)
+ (if (.equals ^Object k slot)
table*
(V "lux;Cons" (T (T k v) (|remove slot table*))))))
-(defn |merge [table1 table2]
- ;; (prn '|merge (aget table1 0) (aget table2 0))
- (matchv ::M/objects [table2]
- [["lux;Nil" _]]
- table1
-
- [["lux;Cons" [[k v] table2*]]]
- (|merge (|put k v table1) table2*)))
-
(defn |update [k f table]
(matchv ::M/objects [table]
[["lux;Nil" _]]
table
[["lux;Cons" [[k* v] table*]]]
- (if (= k k*)
+ (if (.equals ^Object k k*)
(V "lux;Cons" (T (T k* (f v)) table*))
(V "lux;Cons" (T (T k* v) (|update k f table*))))))
@@ -149,7 +147,6 @@
;; [Resources/Monads]
(defn fail [message]
(fn [_]
- ;; (prn 'FAIL message)
(V "lux;Left" message)))
(defn return [value]
@@ -168,7 +165,6 @@
))))
(defmacro |do [steps return]
- (assert (not= 0 (count steps)) "The steps can't be empty!")
(assert (= 0 (rem (count steps) 2)) "The number of steps must be even!")
(reduce (fn [inner [label computation]]
(case label
@@ -178,28 +174,15 @@
(fn [val#]
(matchv ::M/objects [val#]
[~label]
- ~inner)))
- ;; `(bind ~computation
- ;; (fn [~label] ~inner))
- ))
+ ~inner)))))
return
(reverse (partition 2 steps))))
;; [Resources/Combinators]
-(defn try% [monad]
- (fn [state]
- (matchv ::M/objects [(monad state)]
- [["lux;Right" [?state ?datum]]]
- (return* ?state ?datum)
-
- [_]
- (return* state nil))))
-
(defn |cons [head tail]
(V "lux;Cons" (T head tail)))
(defn |++ [xs ys]
- ;; (prn '|++ (and xs (aget xs 0)) (and ys (aget ys 0)))
(matchv ::M/objects [xs]
[["lux;Nil" _]]
ys
@@ -208,7 +191,6 @@
(V "lux;Cons" (T x (|++ xs* ys)))))
(defn |map [f xs]
- ;; (prn '|map (aget xs 0))
(matchv ::M/objects [xs]
[["lux;Nil" _]]
xs
@@ -259,7 +241,7 @@
false
[["lux;Cons" [[k* _] table*]]]
- (or (= k k*)
+ (or (.equals ^Object k k*)
(|contains? k table*))))
(defn fold [f init xs]
@@ -288,7 +270,6 @@
(|cons init (folds f (f init x) xs*))))
(defn |length [xs]
- ;; (prn '|length (aget xs 0))
(fold (fn [acc _] (inc acc)) 0 xs))
(let [|range* (fn |range* [from to]
@@ -343,21 +324,21 @@
(do-template [<name> <joiner>]
(defn <name> [f xs]
- ;; (prn '<name> 0 (aget xs 0))
(matchv ::M/objects [xs]
[["lux;Nil" _]]
(return xs)
[["lux;Cons" [x xs*]]]
(|do [y (f x)
- ;; :let [_ (prn '<name> 1 (class y))
- ;; _ (prn '<name> 2 (aget y 0))]
- ys (<name> f xs*)]
+ ys (<name> f xs*)]
(return (<joiner> y ys)))))
map% |cons
flat-map% |++)
+(defn list-join [xss]
+ (fold |++ (V "lux;Nil" nil) xss))
+
(defn |as-pairs [xs]
(matchv ::M/objects [xs]
[["lux;Cons" [x ["lux;Cons" [y xs*]]]]]
@@ -372,65 +353,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 apply% [monad call-state]
- (fn [state]
- ;; (prn 'apply-m monad call-state)
- (let [output (monad call-state)]
- ;; (prn 'apply-m/output output)
- (matchv ::M/objects [output]
- [["lux;Right" [?state ?datum]]]
- (return* state ?datum)
-
- [_]
- output))))
-
(defn assert! [test message]
(if test
(return nil)
(fail message)))
-(defn comp% [f-m g-m]
- (|do [temp g-m]
- (f-m temp)))
-
-(defn pass [m-value]
- (fn [state]
- m-value))
-
(def get-state
(fn [state]
(return* state state)))
-(defn sequence% [m-values]
- (matchv ::M/objects [m-values]
- [["lux;Cons" [head tail]]]
- (|do [_ head]
- (sequence% tail))
-
- [_]
- (return nil)))
-
-(def source-consumed?
- (fn [state]
- (matchv ::M/objects [(get$ $SOURCE state)]
- [["lux;None" _]]
- (fail* "No source code.")
-
- [["lux;Some" ["lux;Nil" _]]]
- (return* state true)
-
- [["lux;Some" _]]
- (return* state false))))
-
(defn try-all% [monads]
(matchv ::M/objects [monads]
[["lux;Nil" _]]
@@ -464,18 +395,9 @@
((exhaust% step) state*)
[["lux;Left" msg]]
- ((|do [? source-consumed?]
- (if ?
- (return nil)
- (fail msg)))
- state)
- ;; (if (= "[Reader Error] EOF" msg)
- ;; ((|do [? source-consumed?
- ;; :let [_ (prn '? ?)]]
- ;; (return nil))
- ;; state)
- ;; (fail* msg))
- )))
+ (if (.equals "[Reader Error] EOF" msg)
+ (return* state nil)
+ (fail* msg)))))
(defn ^:private normalize-char [char]
(case char
@@ -501,16 +423,21 @@
\< "_LT_"
\> "_GT_"
\~ "_TILDE_"
+ \| "_PIPE_"
;; default
char))
-(defn normalize-ident [ident]
+(defn normalize-name [ident]
(reduce str "" (map normalize-char ident)))
(def loader
(fn [state]
(return* state (->> state (get$ $HOST) (get$ $LOADER)))))
+(def classes
+ (fn [state]
+ (return* state (->> state (get$ $HOST) (get$ $CLASSES)))))
+
(def +init-bindings+
(R ;; "lux;counter"
0
@@ -528,21 +455,40 @@
name
))
+(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String
+ (class (byte-array []))
+ Integer/TYPE
+ Integer/TYPE]))
+ (.setAccessible true))]
+ (defn memory-class-loader [store]
+ (proxy [java.lang.ClassLoader]
+ []
+ (findClass [^String class-name]
+ ;; (prn 'findClass class-name)
+ (if-let [^bytes bytecode (get @store class-name)]
+ (try (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))]))
+ (catch java.lang.reflect.InvocationTargetException e
+ (prn 'InvocationTargetException (.getCause e))
+ (throw e)))
+ (do (prn 'memory-class-loader/store class-name (keys @store))
+ (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))))
+
(defn host [_]
- (R ;; "lux;eval-ctor"
- 0
- ;; "lux;loader"
- (-> (java.io.File. "./output/") .toURL vector into-array java.net.URLClassLoader.)
- ;; "lux;writer"
- (V "lux;None" nil)))
+ (let [store (atom {})]
+ (R ;; "lux;classes"
+ store
+ ;; "lux;loader"
+ (memory-class-loader store)
+ ;; "lux;writer"
+ (V "lux;None" nil))))
(defn init-state [_]
(R ;; "lux;envs"
(|list)
+ ;; "lux;eval?"
+ false
;; "lux;host"
(host nil)
- ;; "lux;module-aliases"
- (|table)
;; "lux;modules"
(|table)
;; "lux;seed"
@@ -553,24 +499,34 @@
+init-bindings+
))
-(defn from-some [some]
- (matchv ::M/objects [some]
- [["lux;Some" datum]]
- datum
+(defn save-module [body]
+ (fn [state]
+ (matchv ::M/objects [(body state)]
+ [["lux;Right" [state* output]]]
+ (return* (->> state*
+ (set$ $ENVS (get$ $ENVS state))
+ (set$ $SOURCE (get$ $SOURCE state)))
+ output)
- [_]
- (assert false)))
+ [["lux;Left" msg]]
+ (fail* msg))))
+
+(defn with-eval [body]
+ (fn [state]
+ (matchv ::M/objects [(body (set$ $EVAL? true state))]
+ [["lux;Right" [state* output]]]
+ (return* (set$ $EVAL? (get$ $EVAL? state) state*) output)
-(def get-eval-ctor
+ [["lux;Left" msg]]
+ (fail* msg))))
+
+(def get-eval
(fn [state]
- (return* (update$ $HOST #(update$ $EVAL-CTOR inc %) state)
- (get$ $EVAL-CTOR (get$ $HOST state)))))
+ (return* state (get$ $EVAL? state))))
(def get-writer
(fn [state]
(let [writer* (->> state (get$ $HOST) (get$ $WRITER))]
- ;; (prn 'get-writer (class writer*))
- ;; (prn 'get-writer (aget writer* 0))
(matchv ::M/objects [writer*]
[["lux;Some" datum]]
(return* state datum)
@@ -640,9 +596,8 @@
state))))))
(def get-scope-name
- (|do [module-name get-module-name]
- (fn [state]
- (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse (|cons module-name))))))
+ (fn [state]
+ (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse))))
(defn with-writer [writer body]
(fn [state]
@@ -656,54 +611,113 @@
output))))
(defn show-ast [ast]
- ;; (prn 'show-ast (aget ast 0))
- ;; (prn 'show-ast (aget ast 1 1 0))
- ;; (cond (= "lux;Meta" (aget ast 1 1 0))
- ;; (prn 'EXTRA 'show-ast (aget ast 1 1 1 1 0))
-
- ;; (= "lux;Symbol" (aget ast 1 1 0))
- ;; (prn 'EXTRA 'show-ast (aget ast 1 1 1 1))
-
- ;; :else
- ;; nil)
(matchv ::M/objects [ast]
- [["lux;Meta" [_ ["lux;Bool" ?value]]]]
+ [["lux;Meta" [_ ["lux;BoolS" ?value]]]]
(pr-str ?value)
- [["lux;Meta" [_ ["lux;Int" ?value]]]]
+ [["lux;Meta" [_ ["lux;IntS" ?value]]]]
(pr-str ?value)
- [["lux;Meta" [_ ["lux;Real" ?value]]]]
+ [["lux;Meta" [_ ["lux;RealS" ?value]]]]
(pr-str ?value)
- [["lux;Meta" [_ ["lux;Char" ?value]]]]
+ [["lux;Meta" [_ ["lux;CharS" ?value]]]]
(pr-str ?value)
- [["lux;Meta" [_ ["lux;Text" ?value]]]]
+ [["lux;Meta" [_ ["lux;TextS" ?value]]]]
(str "\"" ?value "\"")
- [["lux;Meta" [_ ["lux;Tag" [?module ?tag]]]]]
+ [["lux;Meta" [_ ["lux;TagS" [?module ?tag]]]]]
(str "#" ?module ";" ?tag)
- [["lux;Meta" [_ ["lux;Symbol" [?module ?ident]]]]]
- (if (= "" ?module)
+ [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]]
+ (if (.equals "" ?module)
?ident
(str ?module ";" ?ident))
- [["lux;Meta" [_ ["lux;Tuple" ?elems]]]]
+ [["lux;Meta" [_ ["lux;TupleS" ?elems]]]]
(str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]")
- [["lux;Meta" [_ ["lux;Record" ?elems]]]]
+ [["lux;Meta" [_ ["lux;RecordS" ?elems]]]]
(str "{" (->> ?elems
(|map (fn [elem]
(|let [[k v] elem]
(str (show-ast k) " " (show-ast v)))))
(|interpose " ") (fold str "")) "}")
- [["lux;Meta" [_ ["lux;Form" ?elems]]]]
+ [["lux;Meta" [_ ["lux;FormS" ?elems]]]]
(str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")")
))
(defn ident->text [ident]
(|let [[?module ?name] ident]
(str ?module ";" ?name)))
+
+(defn fold2% [f init xs ys]
+ (matchv ::M/objects [xs ys]
+ [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
+ (|do [init* (f init x y)]
+ (fold2% f init* xs* ys*))
+
+ [["lux;Nil" _] ["lux;Nil" _]]
+ (return init)
+
+ [_ _]
+ (fail "Lists don't match in size.")))
+
+(defn map2% [f xs ys]
+ (matchv ::M/objects [xs ys]
+ [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
+ (|do [z (f x y)
+ zs (map2% f xs* ys*)]
+ (return (|cons z zs)))
+
+ [["lux;Nil" _] ["lux;Nil" _]]
+ (return (V "lux;Nil" nil))
+
+ [_ _]
+ (fail "Lists don't match in size.")))
+
+(defn map2 [f xs ys]
+ (matchv ::M/objects [xs ys]
+ [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
+ (|cons (f x y) (map2 f xs* ys*))
+
+ [_ _]
+ (V "lux;Nil" nil)))
+
+(defn fold2 [f init xs ys]
+ (matchv ::M/objects [xs ys]
+ [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
+ (and init
+ (fold2 f (f init x y) xs* ys*))
+
+ [["lux;Nil" _] ["lux;Nil" _]]
+ init
+
+ [_ _]
+ false))
+
+(defn ^:private enumerate* [idx xs]
+ (matchv ::M/objects [xs]
+ [["lux;Cons" [x xs*]]]
+ (V "lux;Cons" (T (T idx x)
+ (enumerate* (inc idx) xs*)))
+
+ [["lux;Nil" _]]
+ xs
+ ))
+
+(defn enumerate [xs]
+ (enumerate* 0 xs))
+
+(def modules
+ "(Lux (List Text))"
+ (fn [state]
+ (return* state (|keys (get$ $MODULES state)))))
+
+(defn when% [test body]
+ "(-> Bool (Lux (,)) (Lux (,)))"
+ (if test
+ body
+ (return nil)))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 5a9f1b39d..3449900e0 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.compiler
(:refer-clojure :exclude [compile])
(:require (clojure [string :as string]
@@ -5,7 +13,7 @@
[template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail*]]
+ (lux [base :as & :refer [|let |do return* return fail fail*]]
[type :as &type]
[reader :as &reader]
[lexer :as &lexer]
@@ -16,12 +24,12 @@
[lux.analyser.base :as &a]
[lux.analyser.module :as &a-module]
(lux.compiler [base :as &&]
+ [cache :as &&cache]
[lux :as &&lux]
[host :as &&host]
[case :as &&case]
- [lambda :as &&lambda])
- ;; :reload
- )
+ [lambda :as &&lambda]
+ [package :as &&package]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -29,280 +37,293 @@
;; [Utils/Compilers]
(defn ^:private compile-expression [syntax]
- ;; (prn 'compile-expression (aget syntax 0))
(matchv ::M/objects [syntax]
[[?form ?type]]
- (do ;; (prn 'compile-expression2 (aget ?form 0))
- (matchv ::M/objects [?form]
- [["bool" ?value]]
- (&&lux/compile-bool compile-expression ?type ?value)
-
- [["int" ?value]]
- (&&lux/compile-int compile-expression ?type ?value)
-
- [["real" ?value]]
- (&&lux/compile-real compile-expression ?type ?value)
-
- [["char" ?value]]
- (&&lux/compile-char compile-expression ?type ?value)
-
- [["text" ?value]]
- (&&lux/compile-text compile-expression ?type ?value)
-
- [["tuple" ?elems]]
- (&&lux/compile-tuple compile-expression ?type ?elems)
-
- [["record" ?elems]]
- (&&lux/compile-record compile-expression ?type ?elems)
-
- [["lux;Local" ?idx]]
- (&&lux/compile-local compile-expression ?type ?idx)
-
- [["captured" [?scope ?captured-id ?source]]]
- (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source)
-
- [["lux;Global" [?owner-class ?name]]]
- (&&lux/compile-global compile-expression ?type ?owner-class ?name)
-
- [["apply" [?fn ?arg]]]
- (&&lux/compile-apply compile-expression ?type ?fn ?arg)
-
- [["variant" [?tag ?members]]]
- (&&lux/compile-variant compile-expression ?type ?tag ?members)
-
- [["case" [?value ?match]]]
- (&&case/compile-case compile-expression ?type ?value ?match)
-
- [["lambda" [?scope ?env ?body]]]
- (&&lambda/compile-lambda compile-expression ?scope ?env ?body)
-
- ;; Integer arithmetic
- [["jvm-iadd" [?x ?y]]]
- (&&host/compile-jvm-iadd compile-expression ?type ?x ?y)
-
- [["jvm-isub" [?x ?y]]]
- (&&host/compile-jvm-isub compile-expression ?type ?x ?y)
-
- [["jvm-imul" [?x ?y]]]
- (&&host/compile-jvm-imul compile-expression ?type ?x ?y)
-
- [["jvm-idiv" [?x ?y]]]
- (&&host/compile-jvm-idiv compile-expression ?type ?x ?y)
-
- [["jvm-irem" [?x ?y]]]
- (&&host/compile-jvm-irem compile-expression ?type ?x ?y)
-
- [["jvm-ieq" [?x ?y]]]
- (&&host/compile-jvm-ieq compile-expression ?type ?x ?y)
-
- [["jvm-ilt" [?x ?y]]]
- (&&host/compile-jvm-ilt compile-expression ?type ?x ?y)
-
- [["jvm-igt" [?x ?y]]]
- (&&host/compile-jvm-igt compile-expression ?type ?x ?y)
-
- ;; Long arithmetic
- [["jvm-ladd" [?x ?y]]]
- (&&host/compile-jvm-ladd compile-expression ?type ?x ?y)
-
- [["jvm-lsub" [?x ?y]]]
- (&&host/compile-jvm-lsub compile-expression ?type ?x ?y)
-
- [["jvm-lmul" [?x ?y]]]
- (&&host/compile-jvm-lmul compile-expression ?type ?x ?y)
-
- [["jvm-ldiv" [?x ?y]]]
- (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y)
-
- [["jvm-lrem" [?x ?y]]]
- (&&host/compile-jvm-lrem compile-expression ?type ?x ?y)
-
- [["jvm-leq" [?x ?y]]]
- (&&host/compile-jvm-leq compile-expression ?type ?x ?y)
-
- [["jvm-llt" [?x ?y]]]
- (&&host/compile-jvm-llt compile-expression ?type ?x ?y)
-
- [["jvm-lgt" [?x ?y]]]
- (&&host/compile-jvm-lgt compile-expression ?type ?x ?y)
-
- ;; Float arithmetic
- [["jvm-fadd" [?x ?y]]]
- (&&host/compile-jvm-fadd compile-expression ?type ?x ?y)
-
- [["jvm-fsub" [?x ?y]]]
- (&&host/compile-jvm-fsub compile-expression ?type ?x ?y)
-
- [["jvm-fmul" [?x ?y]]]
- (&&host/compile-jvm-fmul compile-expression ?type ?x ?y)
-
- [["jvm-fdiv" [?x ?y]]]
- (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y)
-
- [["jvm-frem" [?x ?y]]]
- (&&host/compile-jvm-frem compile-expression ?type ?x ?y)
-
- [["jvm-feq" [?x ?y]]]
- (&&host/compile-jvm-feq compile-expression ?type ?x ?y)
-
- [["jvm-flt" [?x ?y]]]
- (&&host/compile-jvm-flt compile-expression ?type ?x ?y)
-
- [["jvm-fgt" [?x ?y]]]
- (&&host/compile-jvm-fgt compile-expression ?type ?x ?y)
-
- ;; Double arithmetic
- [["jvm-dadd" [?x ?y]]]
- (&&host/compile-jvm-dadd compile-expression ?type ?x ?y)
-
- [["jvm-dsub" [?x ?y]]]
- (&&host/compile-jvm-dsub compile-expression ?type ?x ?y)
-
- [["jvm-dmul" [?x ?y]]]
- (&&host/compile-jvm-dmul compile-expression ?type ?x ?y)
-
- [["jvm-ddiv" [?x ?y]]]
- (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y)
-
- [["jvm-drem" [?x ?y]]]
- (&&host/compile-jvm-drem compile-expression ?type ?x ?y)
-
- [["jvm-deq" [?x ?y]]]
- (&&host/compile-jvm-deq compile-expression ?type ?x ?y)
-
- [["jvm-dlt" [?x ?y]]]
- (&&host/compile-jvm-dlt compile-expression ?type ?x ?y)
-
- [["jvm-dgt" [?x ?y]]]
- (&&host/compile-jvm-dgt compile-expression ?type ?x ?y)
-
- [["jvm-null" _]]
- (&&host/compile-jvm-null compile-expression ?type)
-
- [["jvm-null?" ?object]]
- (&&host/compile-jvm-null? compile-expression ?type ?object)
-
- [["jvm-new" [?class ?classes ?args]]]
- (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args)
-
- [["jvm-getstatic" [?class ?field]]]
- (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field)
-
- [["jvm-getfield" [?class ?field ?object]]]
- (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object)
-
- [["jvm-putstatic" [?class ?field ?value]]]
- (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value)
-
- [["jvm-putfield" [?class ?field ?object ?value]]]
- (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value)
-
- [["jvm-invokestatic" [?class ?method ?classes ?args]]]
- (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args)
-
- [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]]
- (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args)
-
- [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]]
- (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args)
-
- [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]]
- (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args)
-
- [["jvm-new-array" [?class ?length]]]
- (&&host/compile-jvm-new-array compile-expression ?type ?class ?length)
+ (matchv ::M/objects [?form]
+ [["bool" ?value]]
+ (&&lux/compile-bool compile-expression ?type ?value)
+
+ [["int" ?value]]
+ (&&lux/compile-int compile-expression ?type ?value)
+
+ [["real" ?value]]
+ (&&lux/compile-real compile-expression ?type ?value)
+
+ [["char" ?value]]
+ (&&lux/compile-char compile-expression ?type ?value)
+
+ [["text" ?value]]
+ (&&lux/compile-text compile-expression ?type ?value)
+
+ [["tuple" ?elems]]
+ (&&lux/compile-tuple compile-expression ?type ?elems)
+
+ [["record" ?elems]]
+ (&&lux/compile-record compile-expression ?type ?elems)
+
+ [["lux;Local" ?idx]]
+ (&&lux/compile-local compile-expression ?type ?idx)
+
+ [["captured" [?scope ?captured-id ?source]]]
+ (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source)
+
+ [["lux;Global" [?owner-class ?name]]]
+ (&&lux/compile-global compile-expression ?type ?owner-class ?name)
+
+ [["apply" [?fn ?args]]]
+ (&&lux/compile-apply compile-expression ?type ?fn ?args)
+
+ [["variant" [?tag ?members]]]
+ (&&lux/compile-variant compile-expression ?type ?tag ?members)
+
+ [["case" [?value ?match]]]
+ (&&case/compile-case compile-expression ?type ?value ?match)
+
+ [["lambda" [?scope ?env ?body]]]
+ (&&lambda/compile-lambda compile-expression ?scope ?env ?body)
+
+ [["ann" [?value-ex ?type-ex]]]
+ (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex)
+
+ ;; Characters
+ [["jvm-ceq" [?x ?y]]]
+ (&&host/compile-jvm-ceq compile-expression ?type ?x ?y)
+
+ [["jvm-clt" [?x ?y]]]
+ (&&host/compile-jvm-clt compile-expression ?type ?x ?y)
+
+ [["jvm-cgt" [?x ?y]]]
+ (&&host/compile-jvm-cgt compile-expression ?type ?x ?y)
+
+ ;; Integer arithmetic
+ [["jvm-iadd" [?x ?y]]]
+ (&&host/compile-jvm-iadd compile-expression ?type ?x ?y)
+
+ [["jvm-isub" [?x ?y]]]
+ (&&host/compile-jvm-isub compile-expression ?type ?x ?y)
+
+ [["jvm-imul" [?x ?y]]]
+ (&&host/compile-jvm-imul compile-expression ?type ?x ?y)
+
+ [["jvm-idiv" [?x ?y]]]
+ (&&host/compile-jvm-idiv compile-expression ?type ?x ?y)
+
+ [["jvm-irem" [?x ?y]]]
+ (&&host/compile-jvm-irem compile-expression ?type ?x ?y)
+
+ [["jvm-ieq" [?x ?y]]]
+ (&&host/compile-jvm-ieq compile-expression ?type ?x ?y)
+
+ [["jvm-ilt" [?x ?y]]]
+ (&&host/compile-jvm-ilt compile-expression ?type ?x ?y)
+
+ [["jvm-igt" [?x ?y]]]
+ (&&host/compile-jvm-igt compile-expression ?type ?x ?y)
+
+ ;; Long arithmetic
+ [["jvm-ladd" [?x ?y]]]
+ (&&host/compile-jvm-ladd compile-expression ?type ?x ?y)
+
+ [["jvm-lsub" [?x ?y]]]
+ (&&host/compile-jvm-lsub compile-expression ?type ?x ?y)
+
+ [["jvm-lmul" [?x ?y]]]
+ (&&host/compile-jvm-lmul compile-expression ?type ?x ?y)
+
+ [["jvm-ldiv" [?x ?y]]]
+ (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y)
+
+ [["jvm-lrem" [?x ?y]]]
+ (&&host/compile-jvm-lrem compile-expression ?type ?x ?y)
+
+ [["jvm-leq" [?x ?y]]]
+ (&&host/compile-jvm-leq compile-expression ?type ?x ?y)
+
+ [["jvm-llt" [?x ?y]]]
+ (&&host/compile-jvm-llt compile-expression ?type ?x ?y)
+
+ [["jvm-lgt" [?x ?y]]]
+ (&&host/compile-jvm-lgt compile-expression ?type ?x ?y)
+
+ ;; Float arithmetic
+ [["jvm-fadd" [?x ?y]]]
+ (&&host/compile-jvm-fadd compile-expression ?type ?x ?y)
+
+ [["jvm-fsub" [?x ?y]]]
+ (&&host/compile-jvm-fsub compile-expression ?type ?x ?y)
+
+ [["jvm-fmul" [?x ?y]]]
+ (&&host/compile-jvm-fmul compile-expression ?type ?x ?y)
+
+ [["jvm-fdiv" [?x ?y]]]
+ (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y)
+
+ [["jvm-frem" [?x ?y]]]
+ (&&host/compile-jvm-frem compile-expression ?type ?x ?y)
+
+ [["jvm-feq" [?x ?y]]]
+ (&&host/compile-jvm-feq compile-expression ?type ?x ?y)
+
+ [["jvm-flt" [?x ?y]]]
+ (&&host/compile-jvm-flt compile-expression ?type ?x ?y)
+
+ [["jvm-fgt" [?x ?y]]]
+ (&&host/compile-jvm-fgt compile-expression ?type ?x ?y)
+
+ ;; Double arithmetic
+ [["jvm-dadd" [?x ?y]]]
+ (&&host/compile-jvm-dadd compile-expression ?type ?x ?y)
+
+ [["jvm-dsub" [?x ?y]]]
+ (&&host/compile-jvm-dsub compile-expression ?type ?x ?y)
+
+ [["jvm-dmul" [?x ?y]]]
+ (&&host/compile-jvm-dmul compile-expression ?type ?x ?y)
+
+ [["jvm-ddiv" [?x ?y]]]
+ (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y)
+
+ [["jvm-drem" [?x ?y]]]
+ (&&host/compile-jvm-drem compile-expression ?type ?x ?y)
+
+ [["jvm-deq" [?x ?y]]]
+ (&&host/compile-jvm-deq compile-expression ?type ?x ?y)
+
+ [["jvm-dlt" [?x ?y]]]
+ (&&host/compile-jvm-dlt compile-expression ?type ?x ?y)
+
+ [["jvm-dgt" [?x ?y]]]
+ (&&host/compile-jvm-dgt compile-expression ?type ?x ?y)
+
+ [["jvm-null" _]]
+ (&&host/compile-jvm-null compile-expression ?type)
+
+ [["jvm-null?" ?object]]
+ (&&host/compile-jvm-null? compile-expression ?type ?object)
+
+ [["jvm-new" [?class ?classes ?args]]]
+ (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args)
+
+ [["jvm-getstatic" [?class ?field]]]
+ (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field)
+
+ [["jvm-getfield" [?class ?field ?object]]]
+ (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object)
+
+ [["jvm-putstatic" [?class ?field ?value]]]
+ (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value)
+
+ [["jvm-putfield" [?class ?field ?object ?value]]]
+ (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value)
+
+ [["jvm-invokestatic" [?class ?method ?classes ?args]]]
+ (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args)
+
+ [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]]
+ (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args)
+
+ [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]]
+ (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args)
+
+ [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]]
+ (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args)
+
+ [["jvm-new-array" [?class ?length]]]
+ (&&host/compile-jvm-new-array compile-expression ?type ?class ?length)
- [["jvm-aastore" [?array ?idx ?elem]]]
- (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem)
+ [["jvm-aastore" [?array ?idx ?elem]]]
+ (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem)
- [["jvm-aaload" [?array ?idx]]]
- (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx)
+ [["jvm-aaload" [?array ?idx]]]
+ (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx)
- [["jvm-try" [?body ?catches ?finally]]]
- (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally)
+ [["jvm-try" [?body ?catches ?finally]]]
+ (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally)
- [["jvm-throw" ?ex]]
- (&&host/compile-jvm-throw compile-expression ?type ?ex)
+ [["jvm-throw" ?ex]]
+ (&&host/compile-jvm-throw compile-expression ?type ?ex)
- [["jvm-monitorenter" ?monitor]]
- (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor)
+ [["jvm-monitorenter" ?monitor]]
+ (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor)
- [["jvm-monitorexit" ?monitor]]
- (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor)
+ [["jvm-monitorexit" ?monitor]]
+ (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor)
- [["jvm-d2f" ?value]]
- (&&host/compile-jvm-d2f compile-expression ?type ?value)
+ [["jvm-d2f" ?value]]
+ (&&host/compile-jvm-d2f compile-expression ?type ?value)
- [["jvm-d2i" ?value]]
- (&&host/compile-jvm-d2i compile-expression ?type ?value)
+ [["jvm-d2i" ?value]]
+ (&&host/compile-jvm-d2i compile-expression ?type ?value)
- [["jvm-d2l" ?value]]
- (&&host/compile-jvm-d2l compile-expression ?type ?value)
-
- [["jvm-f2d" ?value]]
- (&&host/compile-jvm-f2d compile-expression ?type ?value)
+ [["jvm-d2l" ?value]]
+ (&&host/compile-jvm-d2l compile-expression ?type ?value)
+
+ [["jvm-f2d" ?value]]
+ (&&host/compile-jvm-f2d compile-expression ?type ?value)
- [["jvm-f2i" ?value]]
- (&&host/compile-jvm-f2i compile-expression ?type ?value)
+ [["jvm-f2i" ?value]]
+ (&&host/compile-jvm-f2i compile-expression ?type ?value)
- [["jvm-f2l" ?value]]
- (&&host/compile-jvm-f2l compile-expression ?type ?value)
-
- [["jvm-i2b" ?value]]
- (&&host/compile-jvm-i2b compile-expression ?type ?value)
+ [["jvm-f2l" ?value]]
+ (&&host/compile-jvm-f2l compile-expression ?type ?value)
+
+ [["jvm-i2b" ?value]]
+ (&&host/compile-jvm-i2b compile-expression ?type ?value)
- [["jvm-i2c" ?value]]
- (&&host/compile-jvm-i2c compile-expression ?type ?value)
+ [["jvm-i2c" ?value]]
+ (&&host/compile-jvm-i2c compile-expression ?type ?value)
- [["jvm-i2d" ?value]]
- (&&host/compile-jvm-i2d compile-expression ?type ?value)
+ [["jvm-i2d" ?value]]
+ (&&host/compile-jvm-i2d compile-expression ?type ?value)
- [["jvm-i2f" ?value]]
- (&&host/compile-jvm-i2f compile-expression ?type ?value)
+ [["jvm-i2f" ?value]]
+ (&&host/compile-jvm-i2f compile-expression ?type ?value)
- [["jvm-i2l" ?value]]
- (&&host/compile-jvm-i2l compile-expression ?type ?value)
+ [["jvm-i2l" ?value]]
+ (&&host/compile-jvm-i2l compile-expression ?type ?value)
- [["jvm-i2s" ?value]]
- (&&host/compile-jvm-i2s compile-expression ?type ?value)
+ [["jvm-i2s" ?value]]
+ (&&host/compile-jvm-i2s compile-expression ?type ?value)
- [["jvm-l2d" ?value]]
- (&&host/compile-jvm-l2d compile-expression ?type ?value)
+ [["jvm-l2d" ?value]]
+ (&&host/compile-jvm-l2d compile-expression ?type ?value)
- [["jvm-l2f" ?value]]
- (&&host/compile-jvm-l2f compile-expression ?type ?value)
+ [["jvm-l2f" ?value]]
+ (&&host/compile-jvm-l2f compile-expression ?type ?value)
- [["jvm-l2i" ?value]]
- (&&host/compile-jvm-l2i compile-expression ?type ?value)
+ [["jvm-l2i" ?value]]
+ (&&host/compile-jvm-l2i compile-expression ?type ?value)
- [["jvm-iand" [?x ?y]]]
- (&&host/compile-jvm-iand compile-expression ?type ?x ?y)
+ [["jvm-iand" [?x ?y]]]
+ (&&host/compile-jvm-iand compile-expression ?type ?x ?y)
- [["jvm-ior" [?x ?y]]]
- (&&host/compile-jvm-ior compile-expression ?type ?x ?y)
+ [["jvm-ior" [?x ?y]]]
+ (&&host/compile-jvm-ior compile-expression ?type ?x ?y)
- [["jvm-land" [?x ?y]]]
- (&&host/compile-jvm-land compile-expression ?type ?x ?y)
+ [["jvm-land" [?x ?y]]]
+ (&&host/compile-jvm-land compile-expression ?type ?x ?y)
- [["jvm-lor" [?x ?y]]]
- (&&host/compile-jvm-lor compile-expression ?type ?x ?y)
+ [["jvm-lor" [?x ?y]]]
+ (&&host/compile-jvm-lor compile-expression ?type ?x ?y)
- [["jvm-lxor" [?x ?y]]]
- (&&host/compile-jvm-lxor compile-expression ?type ?x ?y)
+ [["jvm-lxor" [?x ?y]]]
+ (&&host/compile-jvm-lxor compile-expression ?type ?x ?y)
- [["jvm-lshl" [?x ?y]]]
- (&&host/compile-jvm-lshl compile-expression ?type ?x ?y)
+ [["jvm-lshl" [?x ?y]]]
+ (&&host/compile-jvm-lshl compile-expression ?type ?x ?y)
- [["jvm-lshr" [?x ?y]]]
- (&&host/compile-jvm-lshr compile-expression ?type ?x ?y)
+ [["jvm-lshr" [?x ?y]]]
+ (&&host/compile-jvm-lshr compile-expression ?type ?x ?y)
- [["jvm-lushr" [?x ?y]]]
- (&&host/compile-jvm-lushr compile-expression ?type ?x ?y)
- ))
+ [["jvm-lushr" [?x ?y]]]
+ (&&host/compile-jvm-lushr compile-expression ?type ?x ?y)
+
+ [["jvm-instanceof" [?class ?object]]]
+ (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object)
+ )
))
(defn ^:private compile-statement [syntax]
- ;; (prn 'compile-statement syntax)
(matchv ::M/objects [syntax]
[["def" [?name ?body ?def-data]]]
(&&lux/compile-def compile-expression ?name ?body ?def-data)
@@ -313,24 +334,25 @@
[["jvm-program" ?body]]
(&&host/compile-jvm-program compile-expression ?body)
- [["jvm-interface" [?package ?name ?methods]]]
- (&&host/compile-jvm-interface compile-expression ?package ?name ?methods)
+ [["jvm-interface" [?name ?supers ?methods]]]
+ (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods)
- [["jvm-class" [?package ?name ?super-class ?fields ?methods]]]
- (&&host/compile-jvm-class compile-expression ?package ?name ?super-class ?fields ?methods)))
+ [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]]
+ (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods)))
(defn ^:private eval! [expr]
- ;; (prn 'eval! (aget expr 0))
- ;; (assert false)
- (|do [eval-ctor &/get-eval-ctor
- :let [class-name (str eval-ctor)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- class-name nil "java/lang/Object" nil)
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil)
- (doto (.visitEnd))))]
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor *writer* &/get-writer
+ (&/with-eval
+ (|do [module &/get-module-name
+ id &/gen-id
+ :let [class-name (str (&host/->module-class module) "/" id)
+ ;; _ (prn 'eval! id class-name)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+ class-name nil "java/lang/Object" nil)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil)
+ (doto (.visitEnd))))]
+ _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
+ (|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitCode *writer*)]
_ (compile-expression expr)
:let [_ (doto *writer*
@@ -338,62 +360,78 @@
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))]]
- (return nil)))
- :let [bytecode (.toByteArray (doto =class
- .visitEnd))]
- _ (&&/save-class! class-name bytecode)
- loader &/loader]
- (-> (.loadClass ^ClassLoader loader class-name)
- (.getField "_eval")
- (.get nil)
- return)))
-
-(let [compiler-step (|do [analysis+ (&optimizer/optimize eval!)
- ;; :let [_ (prn 'analysis+ analysis+)]
- ]
- (&/map% compile-statement analysis+)
- ;; (if (&/|empty? analysis+)
- ;; (fail "[Compiler Error] No more to compile.")
- ;; (&/map% compile-statement analysis+))
- )]
- (defn ^:private compile-module [name]
- (fn [state]
- (prn 'compile-module name (->> state (&/get$ &/$MODULES) &/|keys &/->seq))
- (if (->> state (&/get$ &/$MODULES) (&/|contains? name))
- (if (= name "lux")
- (return* state nil)
- (fail* "[Compiler Error] Can't redefine a module!"))
- (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- (&host/->class name) nil "java/lang/Object" nil))]
- (matchv ::M/objects [(&/run-state (&/exhaust% compiler-step) (->> state
- (&/set$ &/$SOURCE (&/V "lux;Some" (&reader/from (str "source/" name ".lux"))))
- (&/set$ &/$ENVS (&/|list (&/env name)))
- (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %))
- (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))]
- [["lux;Right" [?state _]]]
- (do (.visitEnd =class)
- ;; (prn 'compile-module 'DONE name)
- ;; (prn 'compile-module/?vals ?vals)
- (&/run-state (&&/save-class! name (.toByteArray =class)) ?state))
-
- [["lux;Left" ?message]]
- (fail* ?message)))))))
+ (return nil)))
+ :let [bytecode (.toByteArray (doto =class
+ .visitEnd))]
+ _ (&&/save-class! (str id) bytecode)
+ loader &/loader]
+ (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id))
+ (.getField "_eval")
+ (.get nil)
+ return))))
+
+(defn ^:private compile-module [name]
+ ;; (prn 'compile-module name (&&cache/cached? name))
+ (let [file-name (str &&/input-dir "/" name ".lux")
+ file-content (slurp file-name)
+ file-hash (hash file-content)]
+ (if (&&cache/cached? name)
+ (&&cache/load name file-hash compile-module)
+ (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)]
+ (&/map% compile-statement analysis+))]
+ (|do [module-exists? (&a-module/exists? name)]
+ (if module-exists?
+ (fail "[Compiler Error] Can't redefine a module!")
+ (|do [_ (&a-module/enter-module name)
+ :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+ (str (&host/->module-class name) "/_") nil "java/lang/Object" nil)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash)
+ .visitEnd)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version)
+ .visitEnd))
+ ;; _ (prn 'compile-module name =class)
+ ]]
+ (fn [state]
+ (matchv ::M/objects [((&/with-writer =class
+ (&/exhaust% compiler-step))
+ (&/set$ &/$SOURCE (&reader/from file-name file-content) state))]
+ [["lux;Right" [?state _]]]
+ (&/run-state (|do [defs &a-module/defs
+ imports &a-module/imports
+ :let [_ (doto =class
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil
+ (->> defs
+ (&/|map (fn [_def]
+ (|let [[?exported ?name ?ann] _def]
+ (str (if ?exported "1" "0") " " ?name " " ?ann))))
+ (&/|interpose "\t")
+ (&/fold str "")))
+ .visitEnd)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil
+ (->> imports (&/|interpose "\t") (&/fold str "")))
+ .visitEnd)
+ (.visitEnd))
+ ;; _ (prn 'CLOSED name =class)
+ ]]
+ (&&/save-class! "_" (.toByteArray =class)))
+ ?state)
+
+ [["lux;Left" ?message]]
+ (fail* ?message)))))))
+ )))
+
+(defn ^:private init! []
+ (.mkdirs (java.io.File. &&/output-dir)))
;; [Resources]
-(defn compile-all [modules]
- (.mkdir (java.io.File. "output"))
- (matchv ::M/objects [(&/run-state (&/map% compile-module (&/|cons "lux" modules)) (&/init-state nil))]
+(defn compile-program [program-module]
+ (init!)
+ (matchv ::M/objects [((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))]
[["lux;Right" [?state _]]]
- (println (str "Compilation complete! " (str "[" (->> modules
- (&/|interpose " ")
- (&/fold str ""))
- "]")))
+ (do (println "Compilation complete!")
+ (&&cache/clean ?state)
+ (&&package/package program-module))
[["lux;Left" ?message]]
- (do (prn 'compile-all '?message ?message)
- (assert false ?message))))
-
-(comment
- (compile-all ["lux"])
- )
+ (assert false ?message)))
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index dd7e0ae13..28339c162 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -1,135 +1,91 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.compiler.base
- (:require [clojure.string :as string]
+ (:require (clojure [template :refer [do-template]]
+ [string :as string])
+ [clojure.java.io :as io]
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail*]])
- [lux.analyser.base :as &a])
+ (lux [base :as & :refer [|do return* return fail fail*]]
+ [type :as &type]
+ [host :as &host])
+ (lux.analyser [base :as &a]
+ [module :as &a-module]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
- MethodVisitor)))
+ MethodVisitor)
+ (java.io File
+ BufferedOutputStream
+ FileOutputStream)
+ (java.lang.reflect Field)))
-;; [Exports]
-(def local-prefix "l")
-(def partial-prefix "p")
-(def closure-prefix "c")
-(def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;")
+;; [Constants]
+(def ^String version "0.2")
+(def ^String input-dir "source")
+(def ^String output-dir "target/jvm")
+(def ^String output-package (str output-dir "/program.jar"))
+(def ^String function-class "lux/Function")
+
+(def ^String local-prefix "l")
+(def ^String partial-prefix "p")
+(def ^String closure-prefix "c")
+(def ^String apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;")
-(defn write-file [^String file ^bytes data]
- (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))]
+;; [Utils]
+(defn ^:private write-file [^String file ^bytes data]
+ (with-open [stream (BufferedOutputStream. (FileOutputStream. file))]
(.write stream data)))
-(defn write-class [name data]
- (write-file (str "output/" name ".class") data))
+(defn ^:private write-output [module name data]
+ (let [module* (&host/->module-class module)
+ module-dir (str output-dir "/" module*)]
+ (.mkdirs (File. module-dir))
+ (write-file (str module-dir "/" name ".class") data)))
+;; [Exports]
(defn load-class! [^ClassLoader loader name]
+ ;; (prn 'load-class! name)
(.loadClass loader name))
(defn save-class! [name bytecode]
- (|do [loader &/loader
- :let [_ (write-class name bytecode)
- _ (load-class! loader (string/replace name #"/" "."))]]
+ (|do [eval? &/get-eval
+ module &/get-module-name
+ loader &/loader
+ !classes &/classes
+ :let [real-name (str (&host/->module-class module) "." name)
+ _ (swap! !classes assoc real-name bytecode)
+ _ (when (not eval?)
+ (write-output module name bytecode))
+ _ (load-class! loader real-name)]]
(return nil)))
-(defn total-locals [expr]
- ;; (prn 'total-locals1 (aget expr 0))
- (matchv ::M/objects [expr]
- [[?struct ?type]]
- (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)))
-
- [["tuple" ?members]]
- (&/fold max 0 (&/|map total-locals ?members))
-
- [["variant" [?tag ?value]]]
- (total-locals ?value)
-
- [["call" [?fn ?args]]]
- (&/fold max 0 (&/|map total-locals (&/|cons ?fn ?args)))
-
- [["jvm-iadd" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-isub" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-imul" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-idiv" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-irem" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-ladd" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-lsub" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-lmul" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-ldiv" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-lrem" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-fadd" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-fsub" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-fmul" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-fdiv" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-frem" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-dadd" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-dsub" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-dmul" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-ddiv" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["jvm-drem" [?x ?y]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?x ?y)))
-
- [["|do" ?exprs]]
- (&/fold max 0 (&/|map total-locals ?exprs))
-
- [["jvm-new" [?class ?classes ?args]]]
- (&/fold max 0 (&/|map total-locals ?args))
-
- [["jvm-invokestatic" [?class ?method ?classes ?args]]]
- (&/fold max 0 (&/|map total-locals ?args))
-
- [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]]
- (&/fold max 0 (&/|map total-locals ?args))
-
- [["jvm-aastore" [?array ?idx ?elem]]]
- (&/fold max 0 (&/|map total-locals (&/|list ?array ?elem)))
-
- [["jvm-aaload" [?array ?idx]]]
- (total-locals ?array)
+(do-template [<name> <class> <sig> <dup>]
+ (defn <name> [^MethodVisitor writer]
+ (doto writer
+ (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str <sig> (&host/->type-signature <class>))))
+ ;; (doto writer
+ ;; ;; X
+ ;; (.visitTypeInsn Opcodes/NEW <class>) ;; XW
+ ;; (.visitInsn <dup>) ;; WXW
+ ;; (.visitInsn <dup>) ;; WWXW
+ ;; (.visitInsn Opcodes/POP) ;; WWX
+ ;; (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>) ;; W
+ ;; )
+ )
- ;; [["lambda" _]]
- ;; 0
-
- [_]
- 0
- ))))
+ wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1
+ wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1
+ wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1
+ wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1
+ wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2
+ wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1
+ wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2
+ wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1
+ )
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
new file mode 100644
index 000000000..c0d978146
--- /dev/null
+++ b/src/lux/compiler/cache.clj
@@ -0,0 +1,138 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns lux.compiler.cache
+ (:refer-clojure :exclude [load])
+ (:require [clojure.string :as string]
+ [clojure.java.io :as io]
+ [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match.array
+ (lux [base :as & :refer [|do return* return fail fail*]]
+ [type :as &type]
+ [host :as &host])
+ (lux.analyser [base :as &a]
+ [module :as &a-module])
+ (lux.compiler [base :as &&]))
+ (:import (java.io File
+ BufferedOutputStream
+ FileOutputStream)
+ (java.lang.reflect Field)))
+
+;; [Utils]
+(defn ^:private read-file [^File file]
+ (with-open [reader (io/input-stream file)]
+ (let [length (.length file)
+ buffer (byte-array length)]
+ (.read reader buffer 0 length)
+ buffer)))
+
+(defn ^:private clean-file [^File file]
+ (if (.isDirectory file)
+ (do (doseq [f (seq (.listFiles file))]
+ (clean-file f))
+ (.delete file))
+ (.delete file)))
+
+(defn ^:private get-field [^String field-name ^Class class]
+ (-> class ^Field (.getField field-name) (.get nil)))
+
+;; [Resources]
+(defn cached? [module]
+ "(-> Text Bool)"
+ (.exists (new File (str &&/output-dir "/" (&host/->module-class module) "/_.class"))))
+
+(defn delete [module]
+ "(-> Text (Lux (,)))"
+ (fn [state]
+ (do (clean-file (new File (str &&/output-dir "/" (&host/->module-class module))))
+ (return* state nil))))
+
+(defn clean [state]
+ "(-> Compiler (,))"
+ (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set)
+ outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not)
+ outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?))
+ program-file (new File &&/output-package)]
+ (when (.exists program-file)
+ (.delete program-file))
+ (doseq [f outdate-files]
+ (clean-file f))
+ nil))
+
+(defn load [module module-hash compile-module]
+ (|do [loader &/loader
+ !classes &/classes
+ already-loaded? (&a-module/exists? module)
+ _modules &/modules
+ :let [redo-cache (|do [_ (delete module)
+ _ (compile-module module)]
+ (return false))]]
+ (do ;; (prn 'load module 'sources already-loaded?
+ ;; (&/->seq _modules))
+ (if already-loaded?
+ (return true)
+ (if (cached? module)
+ (do ;; (prn 'load/HASH module module-hash)
+ (let [module* (&host/->module-class module)
+ module-path (str &&/output-dir "/" module*)
+ class-name (str module* "._")
+ ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class"))))
+ (&&/load-class! loader class-name))]
+ (if (and (= module-hash (get-field "_hash" module-meta))
+ (= &&/version (get-field "_compiler" module-meta)))
+ (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t")
+ ;; _ (prn 'load/IMPORTS module imports)
+ ]
+ (|do [loads (&/map% (fn [_import]
+ (load _import (-> (str &&/input-dir "/" _import ".lux") slurp hash) compile-module))
+ (if (= [""] imports)
+ (&/|list)
+ (&/->list imports)))]
+ (if (->> loads &/->seq (every? true?))
+ (do (doseq [^File file (seq (.listFiles (File. module-path)))
+ :let [file-name (.getName file)]
+ :when (not= "_.class" file-name)]
+ (let [real-name (second (re-find #"^(.*)\.class$" file-name))
+ bytecode (read-file file)
+ ;; _ (prn 'load module real-name)
+ ]
+ (swap! !classes assoc (str module* "." real-name) bytecode)))
+ (let [defs (string/split (get-field "_defs" module-meta) #"\t")]
+ ;; (prn 'load module defs)
+ (|do [_ (&a-module/enter-module module)
+ _ (&/map% (fn [_def]
+ (let [[_exported? _name _ann] (string/split _def #" ")
+ ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann])
+ ]
+ (|do [_ (case _ann
+ "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type)
+ "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)]
+ (&a-module/declare-macro module _name))
+ "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
+ ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class)
+ def-type (get-field "_meta" def-class)]
+ (matchv ::M/objects [def-type]
+ [["lux;ValueD" _def-type]]
+ (&a-module/define module _name def-type _def-type)))
+ ;; else
+ (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)]
+ (|do [__type (&a-module/def-type __module __name)]
+ (do ;; (prn '__type [__module __name] (&type/show-type __type))
+ (&a-module/def-alias module _name __module __name __type)))))]
+ (if (= "1" _exported?)
+ (&a-module/export module _name)
+ (return nil)))
+ ))
+ (if (= [""] defs)
+ (&/|list)
+ (&/->list defs)))]
+ (return true))))
+ redo-cache)))
+ redo-cache)
+ ))
+ redo-cache)))))
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index 738d6bc35..fc0cce31f 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.compiler.case
(:require (clojure [set :as set]
[template :refer [do-template]])
@@ -16,12 +24,8 @@
MethodVisitor)))
;; [Utils]
-(let [+tag-sig+ (&host/->type-signature "java.lang.String")
- +oclass+ (&host/->class "java.lang.Object")
- +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z")
- compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))]
+(let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))]
(defn ^:private compile-match [^MethodVisitor writer ?match $target $else]
- ;; (prn 'compile-match (aget ?match 0) $target $else)
(matchv ::M/objects [?match]
[["StoreTestAC" ?idx]]
(doto writer
@@ -30,9 +34,9 @@
[["BoolTestAC" ?value]]
(doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Boolean"))
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean")
(.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Boolean") "booleanValue" "()Z")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Boolean" "booleanValue" "()Z")
(.visitLdcInsn ?value)
(.visitJumpInsn Opcodes/IF_ICMPNE $else)
(.visitInsn Opcodes/POP)
@@ -40,9 +44,9 @@
[["IntTestAC" ?value]]
(doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Long"))
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long")
(.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Long") "longValue" "()J")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J")
(.visitLdcInsn ?value)
(.visitInsn Opcodes/LCMP)
(.visitJumpInsn Opcodes/IFNE $else)
@@ -51,9 +55,9 @@
[["RealTestAC" ?value]]
(doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Double"))
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double")
(.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Double") "doubleValue" "()D")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D")
(.visitLdcInsn ?value)
(.visitInsn Opcodes/DCMPL)
(.visitJumpInsn Opcodes/IFNE $else)
@@ -62,9 +66,9 @@
[["CharTestAC" ?value]]
(doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Character"))
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character")
(.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Character") "charValue" "()C")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Character" "charValue" "()C")
(.visitLdcInsn ?value)
(.visitJumpInsn Opcodes/IF_ICMPNE $else)
(.visitInsn Opcodes/POP)
@@ -74,7 +78,7 @@
(doto writer
(.visitInsn Opcodes/DUP)
(.visitLdcInsn ?value)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Object") "equals" (str "(" (&host/->type-signature "java.lang.Object") ")Z"))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
(.visitJumpInsn Opcodes/IFEQ $else)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
@@ -93,7 +97,7 @@
(->> (|let [[idx test] idx+member
$next (new Label)
$sub-else (new Label)])
- (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))])))
+ (doseq [idx+member (->> ?members &/enumerate &/->seq)])))
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
@@ -111,11 +115,12 @@
(->> (|let [[idx [_ test]] idx+member
$next (new Label)
$sub-else (new Label)])
- (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?slots))
- (->> ?slots
- &/->seq
- (sort compare-kv)
- &/->list)))])))
+ (doseq [idx+member (->> ?slots
+ &/->seq
+ (sort compare-kv)
+ &/->list
+ &/enumerate
+ &/->seq)])))
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
@@ -126,7 +131,7 @@
(.visitLdcInsn (int 0))
(.visitInsn Opcodes/AALOAD)
(.visitLdcInsn ?tag)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +oclass+ "equals" +equals-sig+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
(.visitJumpInsn Opcodes/IFEQ $else)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1))
@@ -143,7 +148,6 @@
)))
(defn ^:private separate-bodies [patterns]
- ;; (prn 'separate-bodies (aget matches 0))
(|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body]
(|let [[$id mappings =matches] $id+mappings+=matches
[pattern body] pattern+body]
@@ -152,42 +156,36 @@
patterns)]
(&/T mappings (&/|reverse patterns*))))
-(let [ex-class (&host/->class "java.lang.IllegalStateException")]
- (defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end]
- ;; (prn 'compile-pattern-matching ?matches $end)
- (let [entries (&/|map (fn [?branch+?body]
- (|let [[?branch ?body] ?branch+?body
- label (new Label)]
- (&/T (&/T ?branch label)
- (&/T label ?body))))
- mappings)
- mappings* (&/|map &/|first entries)]
- (doto writer
- (-> (doto (compile-match ?match (&/|get ?body mappings*) $else)
- (.visitLabel $else))
- (->> (|let [[?body ?match] ?body+?match])
- (doseq [?body+?match (&/->seq patterns)
- :let [;; _ (prn 'compile-pattern-matching/pattern pattern)
- ;; _ (prn '?body+?match (alength ?body+?match) (aget ?body+?match 0))
- ;; _ (prn '?body+?match (aget ?body+?match 0))
- $else (new Label)]])))
- (.visitInsn Opcodes/POP)
- (.visitTypeInsn Opcodes/NEW ex-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
- (.visitInsn Opcodes/ATHROW))
- (&/map% (fn [?label+?body]
- (|let [[?label ?body] ?label+?body]
- (|do [:let [_ (.visitLabel writer ?label)]
- ret (compile ?body)
- :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]]
- (return ret))))
- (&/|map &/|second entries))
- )))
+(defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end]
+ (let [entries (&/|map (fn [?branch+?body]
+ (|let [[?branch ?body] ?branch+?body
+ label (new Label)]
+ (&/T (&/T ?branch label)
+ (&/T label ?body))))
+ mappings)
+ mappings* (&/|map &/|first entries)]
+ (doto writer
+ (-> (doto (compile-match ?match (&/|get ?body mappings*) $else)
+ (.visitLabel $else))
+ (->> (|let [[?body ?match] ?body+?match])
+ (doseq [?body+?match (&/->seq patterns)
+ :let [$else (new Label)]])))
+ (.visitInsn Opcodes/POP)
+ (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "()V")
+ (.visitInsn Opcodes/ATHROW))
+ (&/map% (fn [?label+?body]
+ (|let [[?label ?body] ?label+?body]
+ (|do [:let [_ (.visitLabel writer ?label)]
+ ret (compile ?body)
+ :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]]
+ (return ret))))
+ (&/|map &/|second entries))
+ ))
;; [Resources]
(defn compile-case [compile *type* ?value ?matches]
- ;; (prn 'compile-case ?value ?matches)
(|do [^MethodVisitor *writer* &/get-writer
:let [$end (new Label)]
_ (compile ?value)
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 71d3ced53..346b66fd2 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.compiler.host
(:require (clojure [string :as string]
[set :as set]
@@ -44,7 +52,7 @@
char-class "java.lang.Character"]
(defn prepare-return! [^MethodVisitor *writer* *type*]
(matchv ::M/objects [*type*]
- [["lux;VariantT" ["lux;Nil" _]]]
+ [["lux;TupleT" ["lux;Nil" _]]]
(.visitInsn *writer* Opcodes/ACONST_NULL)
[["lux;DataT" "boolean"]]
@@ -76,7 +84,7 @@
*writer*))
;; [Resources]
-(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>]
+(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>]
(defn <name> [compile *type* ?x ?y]
(|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
^MethodVisitor *writer* &/get-writer
@@ -90,32 +98,32 @@
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
_ (doto *writer*
(.visitInsn <opcode>)
- (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (&host/->type-signature <wrapper-class>))))]]
+ (<wrap>))]]
(return nil)))
- compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" &&/wrap-int
+ compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" &&/wrap-int
+ compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" &&/wrap-int
+ compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" &&/wrap-int
+ compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" &&/wrap-int
- compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
-
- compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long
+ compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long
+ compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long
+ compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" &&/wrap-long
+ compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" &&/wrap-long
+
+ compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" &&/wrap-float
+ compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" &&/wrap-float
+ compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" &&/wrap-float
+ compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" &&/wrap-float
+ compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" &&/wrap-float
- compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" &&/wrap-double
+ compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" &&/wrap-double
+ compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" &&/wrap-double
+ compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" &&/wrap-double
+ compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" &&/wrap-double
)
(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>]
@@ -144,9 +152,13 @@
compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I"
compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I"
compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I"
+
+ compile-jvm-ceq Opcodes/IF_ICMPEQ "java.lang.Character" "charValue" "()C"
+ compile-jvm-clt Opcodes/IF_ICMPLT "java.lang.Character" "charValue" "()C"
+ compile-jvm-cgt Opcodes/IF_ICMPGT "java.lang.Character" "charValue" "()C"
)
-(do-template [<name> <cmpcode> <ifcode> <wrapper-class> <value-method> <value-method-sig>]
+(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>]
(defn <name> [compile *type* ?x ?y]
(|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
^MethodVisitor *writer* &/get-writer
@@ -162,63 +174,81 @@
$end (new Label)
_ (doto *writer*
(.visitInsn <cmpcode>)
- (.visitJumpInsn <ifcode> $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean"))
+ (.visitLdcInsn (int <cmp-output>))
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean"))
(.visitJumpInsn Opcodes/GOTO $end)
(.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean"))
+ (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean"))
(.visitLabel $end))]]
(return nil)))
- compile-jvm-leq Opcodes/LCMP Opcodes/IFEQ "java.lang.Long" "longValue" "()J"
- compile-jvm-llt Opcodes/LCMP Opcodes/IFLT "java.lang.Long" "longValue" "()J"
- compile-jvm-lgt Opcodes/LCMP Opcodes/IFGT "java.lang.Long" "longValue" "()J"
+ compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J"
+ compile-jvm-llt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J"
+ compile-jvm-lgt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J"
- compile-jvm-feq Opcodes/FCMPG Opcodes/IFEQ "java.lang.Float" "floatValue" "()F"
- compile-jvm-flt Opcodes/FCMPG Opcodes/IFLT "java.lang.Float" "floatValue" "()F"
- compile-jvm-fgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Float" "floatValue" "()F"
+ compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F"
+ compile-jvm-flt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F"
+ compile-jvm-fgt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F"
- compile-jvm-deq Opcodes/DCMPG Opcodes/IFEQ "java.lang.Double" "doubleValue" "()I"
- compile-jvm-dlt Opcodes/DCMPG Opcodes/IFLT "java.lang.Double" "doubleValue" "()I"
- compile-jvm-dgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Double" "doubleValue" "()I"
+ compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()I"
+ compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()I"
+ compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()I"
)
(defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args]
(|do [^MethodVisitor *writer* &/get-writer
- :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
- _ (&/map% (fn [[class-name arg]]
- (|do [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- (map vector ?classes ?args))
+ :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
+ _ (&/map2% (fn [class-name arg]
+ (|do [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ ?classes ?args)
:let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig)
+ (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig)
(prepare-return! *type*))]]
(return nil)))
(do-template [<name> <op>]
(defn <name> [compile *type* ?class ?method ?classes ?object ?args]
- ;; (prn 'compile-jvm-invokevirtual ?classes *type*)
- (|do [^MethodVisitor *writer* &/get-writer
+ (|do [:let [?class* (&host/->class (&type/as-obj ?class))]
+ ^MethodVisitor *writer* &/get-writer
:let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
_ (compile ?object)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))]
- _ (&/map% (fn [class-name+arg]
- (|let [[class-name arg] class-name+arg]
- (|do [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret))))
- (&/zip2 ?classes ?args))
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)]
+ _ (&/map2% (fn [class-name arg]
+ (|do [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ ?classes ?args)
:let [_ (doto *writer*
- (.visitMethodInsn <op> (&host/->class ?class) ?method method-sig)
+ (.visitMethodInsn <op> ?class* ?method method-sig)
(prepare-return! *type*))]]
(return nil)))
compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL
compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE
- compile-jvm-invokespecial Opcodes/INVOKESPECIAL
+ ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL
)
+(defn compile-jvm-invokespecial [compile *type* ?class ?method ?classes ?object ?args]
+ (|do [:let [?class* (&host/->class (&type/as-obj ?class))]
+ ^MethodVisitor *writer* &/get-writer
+ :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
+ _ (compile ?object)
+ ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)]
+ :let [_ (when (not= "<init>" ?method)
+ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))]
+ _ (&/map2% (fn [class-name arg]
+ (|do [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ ?classes ?args)
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig)
+ (prepare-return! *type*))]]
+ (return nil)))
+
(defn compile-jvm-null [compile *type*]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
@@ -240,7 +270,7 @@
(defn compile-jvm-new [compile *type* ?class ?classes ?args]
(|do [^MethodVisitor *writer* &/get-writer
- :let [init-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")V")
+ :let [init-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")V")
class* (&host/->class ?class)
_ (doto *writer*
(.visitTypeInsn Opcodes/NEW class*)
@@ -249,7 +279,7 @@
(|do [ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
(return ret)))
- (map vector ?classes ?args))
+ (&/zip2 ?classes ?args))
:let [_ (doto *writer*
(.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
(return nil)))
@@ -281,68 +311,101 @@
(defn compile-jvm-getstatic [compile *type* ?class ?field]
(|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]]
+ :let [_ (doto *writer*
+ (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))
+ (prepare-return! *type*))]]
(return nil)))
(defn compile-jvm-getfield [compile *type* ?class ?field ?object]
- (|do [^MethodVisitor *writer* &/get-writer
+ (|do [:let [class* (&host/->class (&type/as-obj ?class))]
+ ^MethodVisitor *writer* &/get-writer
_ (compile ?object)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))]
- :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]]
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST class*)
+ (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig *type*))
+ (prepare-return! *type*))]]
(return nil)))
(defn compile-jvm-putstatic [compile *type* ?class ?field ?value]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?value)
- :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))]]
(return nil)))
(defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value]
- (|do [^MethodVisitor *writer* &/get-writer
+ (|do [:let [class* (&host/->class (&type/as-obj ?class))]
+ ^MethodVisitor *writer* &/get-writer
_ (compile ?object)
_ (compile ?value)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))]
- :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]]
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)]
+ :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig *type*))]]
+ (return nil)))
+
+(defn ^:private modifiers->int [mods]
+ (+ (case (:visibility mods)
+ "default" 0
+ "public" Opcodes/ACC_PUBLIC
+ "private" Opcodes/ACC_PRIVATE
+ "protected" Opcodes/ACC_PROTECTED)
+ (if (:static? mods) Opcodes/ACC_STATIC 0)
+ (if (:final? mods) Opcodes/ACC_FINAL 0)
+ (if (:abstract? mods) Opcodes/ACC_ABSTRACT 0)
+ (case (:concurrency mods)
+ "synchronized" Opcodes/ACC_SYNCHRONIZED
+ "volatile" Opcodes/ACC_VOLATILE
+ ;; else
+ 0)))
+
+(defn compile-jvm-instanceof [compile *type* class object]
+ (|do [:let [class* (&host/->class class)]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile object)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/INSTANCEOF class*)
+ (&&/wrap-boolean))]]
(return nil)))
-(defn compile-jvm-class [compile ?package ?name ?super-class ?fields ?methods]
- (let [parent-dir (&host/->package ?package)
- full-name (str parent-dir "/" ?name)
- super-class* (&host/->class ?super-class)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- full-name nil super-class* nil))
- _ (do (doseq [[field props] ?fields]
- (doto (.visitField =class Opcodes/ACC_PUBLIC field (&host/->type-signature (:type props)) nil nil)
- (.visitEnd)))
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL super-class* "<init>" "()V")
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- (.visitEnd =class)
- (.mkdirs (java.io.File. (str "output/" parent-dir))))]
- (&&/save-class! full-name (.toByteArray =class))))
-
-(defn compile-jvm-interface [compile ?package ?name ?methods]
- ;; (prn 'compile-jvm-interface ?package ?name ?methods)
- (let [parent-dir (&host/->package ?package)
- full-name (str parent-dir "/" ?name)
- =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE)
- full-name nil "java/lang/Object" nil))
- _ (do (doseq [[?method ?props] ?methods
- :let [[?args ?return] (:type ?props)
- signature (str "(" (&/fold str "" (&/|map &host/->type-signature ?args)) ")" (&host/->type-signature ?return))
- ;; _ (prn 'signature signature)
- ]]
- (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil))
- (.visitEnd =interface)
- (.mkdirs (java.io.File. (str "output/" parent-dir))))]
- ;; (prn 'SAVED_CLASS full-name)
- (&&/save-class! full-name (.toByteArray =interface))))
+(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods]
+ (|do [module &/get-module-name]
+ (let [super-class* (&host/->class ?super-class)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+ (str module "/" ?name) nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String))))
+ _ (&/|map (fn [field]
+ (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field)
+ (&host/->type-signature (:type field)) nil nil)
+ (.visitEnd)))
+ ?fields)]
+ (|do [_ (&/map% (fn [method]
+ (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")"
+ (&host/->type-signature (:output method)))]
+ (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method))
+ (:name method)
+ signature nil nil)
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (.visitCode =method)]
+ _ (compile (:body method))
+ :let [_ (doto =method
+ (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN))
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))))
+ ?methods)]
+ (&&/save-class! ?name (.toByteArray (doto =class .visitEnd)))))))
+
+(defn compile-jvm-interface [compile ?name ?supers ?methods]
+ ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str))
+ (|do [module &/get-module-name]
+ (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE)
+ (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String))))
+ _ (do (&/|map (fn [method]
+ (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")"
+ (&host/->type-signature (:output method)))]
+ (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil)))
+ ?methods)
+ (.visitEnd =interface))]
+ (&&/save-class! ?name (.toByteArray =interface)))))
(defn compile-jvm-try [compile *type* ?body ?catches ?finally]
(|do [^MethodVisitor *writer* &/get-writer
@@ -350,46 +413,50 @@
$to (new Label)
$end (new Label)
$catch-finally (new Label)
- compile-finally (if ?finally
- (|do [_ (return nil)
- _ (compile ?finally)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $end))]]
- (return nil))
- (|do [_ (return nil)
- :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]]
- (return nil)))
- _ (.visitLabel *writer* $from)]
+ compile-finally (matchv ::M/objects [?finally]
+ [["lux;Some" ?finally*]] (|do [_ (return nil)
+ _ (compile ?finally*)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $end))]]
+ (return nil))
+ [["lux;None" _]] (|do [_ (return nil)
+ :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]]
+ (return nil)))
+ catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)])
+ ?catches)
+ _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries)
+ ;; :let [_ (prn 'HANDLER ?ex-class (&host/->class ?ex-class) $handler-start $handler-end $from $to $catch-finally)]
+ ]
+ (doto *writer*
+ (.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class))
+ (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil)))
+ _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)]
+ :let [_ (.visitLabel *writer* $from)]
_ (compile ?body)
:let [_ (.visitLabel *writer* $to)]
_ compile-finally
- handlers (&/map% (fn [[?ex-class ?ex-arg ?catch-body]]
- (|do [:let [$handler-start (new Label)
- $handler-end (new Label)]
- _ (compile ?catch-body)
- :let [_ (.visitLabel *writer* $handler-end)]
- _ compile-finally]
- (return [?ex-class $handler-start $handler-end])))
- ?catches)
+ handlers (&/map2% (fn [[?ex-class ?ex-idx ?catch-body] [_ $handler-start $handler-end]]
+ (|do [:let [_ (doto *writer*
+ (.visitLabel $handler-start)
+ (.visitVarInsn Opcodes/ASTORE ?ex-idx))]
+ _ (compile ?catch-body)
+ :let [_ (.visitLabel *writer* $handler-end)]]
+ compile-finally))
+ ?catches
+ catch-boundaries)
+ ;; :let [_ (prn 'handlers (&/->seq handlers))]
:let [_ (.visitLabel *writer* $catch-finally)]
- _ (if ?finally
- (|do [_ (compile ?finally)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/POP)
- (.visitInsn Opcodes/ATHROW))]]
- (return nil))
- (|do [_ (return nil)
- :let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
- (return nil)))
+ _ (matchv ::M/objects [?finally]
+ [["lux;Some" ?finally*]] (|do [_ (compile ?finally*)
+ :let [_ (.visitInsn *writer* Opcodes/POP)]
+ :let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
+ (return nil))
+ [["lux;None" _]] (|do [_ (return nil)
+ :let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
+ (return nil)))
:let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]
- :let [_ (.visitLabel *writer* $end)]
- :let [_ (doseq [[?ex-class $handler-start $handler-end] handlers]
- (doto *writer*
- (.visitTryCatchBlock $from $to $handler-start ?ex-class)
- (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil))
- )
- _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)]]
+ :let [_ (.visitLabel *writer* $end)]]
(return nil)))
(defn compile-jvm-throw [compile *type* ?ex]
@@ -477,14 +544,97 @@
)
(defn compile-jvm-program [compile ?body]
- (|do [^ClassWriter *writer* &/get-writer]
+ (|do [module-name &/get-module-name
+ ;; :let [_ (prn 'compile-jvm-program module-name)]
+ ^ClassWriter *writer* &/get-writer]
(&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil)
(.visitCode))
- (|do [main-writer &/get-writer
+ (|do [^MethodVisitor main-writer &/get-writer
+ :let [;; _ (prn "#1" module-name *writer*)
+ $loop (new Label)
+ ;; _ (prn "#2")
+ $end (new Label)
+ ;; _ (prn "#3")
+ _ (doto main-writer
+ ;; Tail: Begin
+ (.visitLdcInsn (int 2)) ;; S
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V
+ (.visitInsn Opcodes/DUP) ;; VV
+ (.visitLdcInsn (int 0)) ;; VVI
+ (.visitLdcInsn "lux;Nil") ;; VVIT
+ (.visitInsn Opcodes/AASTORE) ;; V
+ (.visitInsn Opcodes/DUP) ;; VV
+ (.visitLdcInsn (int 1)) ;; VVI
+ (.visitInsn Opcodes/ACONST_NULL) ;; VVIN
+ (.visitInsn Opcodes/AASTORE) ;; V
+ ;; Tail: End
+ ;; Size: Begin
+ (.visitVarInsn Opcodes/ALOAD 0) ;; VA
+ (.visitInsn Opcodes/ARRAYLENGTH) ;; VI
+ ;; Size: End
+ ;; Loop: Begin
+ (.visitLabel $loop)
+ (.visitLdcInsn (int 1)) ;; VII
+ (.visitInsn Opcodes/ISUB) ;; VI
+ (.visitInsn Opcodes/DUP) ;; VII
+ (.visitJumpInsn Opcodes/IFLT $end) ;; VI
+ ;; Head: Begin
+ (.visitInsn Opcodes/DUP) ;; VII
+ (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA
+ (.visitInsn Opcodes/SWAP) ;; VIAI
+ (.visitInsn Opcodes/AALOAD) ;; VIO
+ (.visitInsn Opcodes/SWAP) ;; VOI
+ (.visitInsn Opcodes/DUP_X2) ;; IVOI
+ (.visitInsn Opcodes/POP) ;; IVO
+ ;; Head: End
+ ;; Tuple: Begin
+ (.visitLdcInsn (int 2)) ;; IVOS
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2
+ (.visitInsn Opcodes/DUP_X1) ;; IV2O2
+ (.visitInsn Opcodes/SWAP) ;; IV22O
+ (.visitLdcInsn (int 0)) ;; IV22OI
+ (.visitInsn Opcodes/SWAP) ;; IV22IO
+ (.visitInsn Opcodes/AASTORE) ;; IV2
+ (.visitInsn Opcodes/DUP_X1) ;; I2V2
+ (.visitInsn Opcodes/SWAP) ;; I22V
+ (.visitLdcInsn (int 1)) ;; I22VI
+ (.visitInsn Opcodes/SWAP) ;; I22IV
+ (.visitInsn Opcodes/AASTORE) ;; I2
+ ;; Tuple: End
+ ;; Cons: Begin
+ (.visitLdcInsn (int 2)) ;; I2I
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; I2V
+ (.visitInsn Opcodes/DUP) ;; I2VV
+ (.visitLdcInsn (int 0)) ;; I2VVI
+ (.visitLdcInsn "lux;Cons") ;; I2VVIT
+ (.visitInsn Opcodes/AASTORE) ;; I2V
+ (.visitInsn Opcodes/DUP_X1) ;; IV2V
+ (.visitInsn Opcodes/SWAP) ;; IVV2
+ (.visitLdcInsn (int 1)) ;; IVV2I
+ (.visitInsn Opcodes/SWAP) ;; IVVI2
+ (.visitInsn Opcodes/AASTORE) ;; IV
+ ;; Cons: End
+ (.visitInsn Opcodes/SWAP) ;; VI
+ (.visitJumpInsn Opcodes/GOTO $loop)
+ ;; Loop: End
+ (.visitLabel $end) ;; VI
+ (.visitInsn Opcodes/POP) ;; V
+ (.visitVarInsn Opcodes/ASTORE (int 0)) ;;
+ )
+ ;; _ (prn "#4")
+ ]
_ (compile ?body)
- :let [_ (doto ^MethodVisitor main-writer
+ :let [;; _ (prn "#5")
+ _ (doto main-writer
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))
+ ;; _ (prn "#6")
+ ]
+ :let [_ (doto main-writer
(.visitInsn Opcodes/POP)
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
- (.visitEnd))]]
+ (.visitEnd))
+ ;; _ (prn "#7")
+ ]]
(return nil)))))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index 962a32ab6..ccd12e68a 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.compiler.lambda
(:require (clojure [string :as string]
[set :as set]
@@ -11,9 +19,7 @@
[analyser :as &analyser]
[host :as &host])
[lux.analyser.base :as &a]
- (lux.compiler [base :as &&])
- ;; :reload
- )
+ (lux.compiler [base :as &&]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -39,9 +45,7 @@
(-> (doto (.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
(.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
- (->> (let [captured-name (str &&/closure-prefix ?captured-id)
- ;; _ (prn 'add-lambda-<init> class-name ?captured-id)
- ])
+ (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(matchv ::M/objects [?name+?captured]
[[?name [["captured" [_ ?captured-id ?source]] _]]])
(doseq [?name+?captured (&/->seq env)])))
@@ -63,13 +67,8 @@
(&/with-writer (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil)
(.visitCode))
(|do [^MethodVisitor *writer* &/get-writer
- :let [num-locals (&&/total-locals impl-body)
- $start (new Label)
- $end (new Label)
- _ (doto *writer*
- (-> (.visitLocalVariable (str &&/local-prefix idx) (&host/->java-sig (&/V "lux;DataT" "java.lang.Object")) nil $start $end (+ 2 idx))
- (->> (dotimes [idx num-locals])))
- (.visitLabel $start))]
+ :let [$start (new Label)
+ $end (new Label)]
ret (compile impl-body)
:let [_ (doto *writer*
(.visitLabel $end)
@@ -79,48 +78,36 @@
(return ret))))
(defn ^:private instance-closure [compile lambda-class closed-over init-signature]
- ;; (prn 'instance-closure lambda-class (&/|length closed-over) init-signature)
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW lambda-class)
(.visitInsn Opcodes/DUP))]
- _ (->> closed-over
- &/->seq
- (sort #(matchv ::M/objects [(&/|second %1) (&/|second %2)]
- [[["captured" [_ ?cid1 _]] _]
- [["captured" [_ ?cid2 _]] _]]
- (< ?cid1 ?cid2)))
- &/->list
- (&/map% (fn [?name+?captured]
- (matchv ::M/objects [?name+?captured]
- [[?name [["captured" [_ _ ?source]] _]]]
- (compile ?source)))))
+ _ (&/map% (fn [?name+?captured]
+ (matchv ::M/objects [?name+?captured]
+ [[?name [["captured" [_ _ ?source]] _]]]
+ (compile ?source)))
+ closed-over)
:let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature)]]
(return nil)))
;; [Exports]
(defn compile-lambda [compile ?scope ?env ?body]
- ;; (prn 'compile-lambda ?scope (&host/location ?scope) ?env)
- (|do [:let [lambda-class (&host/location ?scope)
+ ;; (prn 'compile-lambda (->> ?scope &/->seq))
+ (|do [:let [name (&host/location (&/|tail ?scope))
+ class-name (str (&host/->module-class (&/|head ?scope)) "/" name)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)]))
+ class-name nil "java/lang/Object" (into-array [&&/function-class]))
(-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil)
(.visitEnd))
(->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(matchv ::M/objects [?name+?captured]
[[?name [["captured" [_ ?captured-id ?source]] _]]])
- (doseq [?name+?captured (&/->seq ?env)
- ;; :let [_ (prn '?name+?captured (alength ?name+?captured))
- ;; _ (prn '?name+?captured (aget ?name+?captured 1 0))
- ;; _ (prn '?name+?captured (aget ?name+?captured 1 1 0 0))]
- ])))
- (add-lambda-apply lambda-class ?env)
- (add-lambda-<init> lambda-class ?env)
+ (doseq [?name+?captured (&/->seq ?env)])))
+ (add-lambda-apply class-name ?env)
+ (add-lambda-<init> class-name ?env)
)]
_ (add-lambda-impl =class compile lambda-impl-signature ?body)
- :let [_ (.visitEnd =class)
- ;; _ (prn 'SAVING_LAMBDA lambda-class)
- ]
- _ (&&/save-class! lambda-class (.toByteArray =class))]
- (instance-closure compile lambda-class ?env (lambda-<init>-signature ?env))))
+ :let [_ (.visitEnd =class)]
+ _ (&&/save-class! name (.toByteArray =class))]
+ (instance-closure compile class-name ?env (lambda-<init>-signature ?env))))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index ad2c9d0c6..b1023689e 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.compiler.lux
(:require (clojure [string :as string]
[set :as set]
@@ -13,36 +21,32 @@
(lux.analyser [base :as &a]
[module :as &a-module])
(lux.compiler [base :as &&]
- [lambda :as &&lambda])
- ;; :reload
- )
+ [lambda :as &&lambda]
+ [type :as &&type]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
MethodVisitor)))
;; [Exports]
-(let [+class+ (&host/->class "java.lang.Boolean")
- +sig+ (&host/->type-signature "java.lang.Boolean")]
- (defn compile-bool [compile *type* ?value]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (&host/->type-signature "java.lang.Boolean"))]]
- (return nil))))
+(defn compile-bool [compile *type* ?value]
+ (|do [^MethodVisitor *writer* &/get-writer
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]]
+ (return nil)))
(do-template [<name> <class> <sig> <caster>]
- (let [+class+ (&host/->class <class>)]
- (defn <name> [compile *type* value]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/NEW +class+)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (<caster> value))
- (.visitMethodInsn Opcodes/INVOKESPECIAL +class+ "<init>" <sig>))]]
- (return nil))))
-
- compile-int "java.lang.Long" "(J)V" long
- compile-real "java.lang.Double" "(D)V" double
- compile-char "java.lang.Character" "(C)V" char
+ (defn <name> [compile *type* value]
+ (|do [^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW <class>)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (<caster> value))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]]
+ (return nil)))
+
+ compile-int "java/lang/Long" "(J)V" long
+ compile-real "java/lang/Double" "(D)V" double
+ compile-char "java/lang/Character" "(C)V" char
)
(defn compile-text [compile *type* ?value]
@@ -55,46 +59,43 @@
:let [num-elems (&/|length ?elems)
_ (doto *writer*
(.visitLdcInsn (int num-elems))
- (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))]
- _ (&/map% (fn [idx+elem]
- (|let [[idx elem] idx+elem]
- (|do [:let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int idx)))]
- ret (compile elem)
- :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
- (return ret))))
- (&/zip2 (&/|range num-elems) ?elems))]
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))]
+ _ (&/map2% (fn [idx elem]
+ (|do [:let [_ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int idx)))]
+ ret (compile elem)
+ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
+ (return ret)))
+ (&/|range num-elems) ?elems)]
(return nil)))
(defn compile-record [compile *type* ?elems]
- ;; (prn 'compile-record (str "{{" (->> ?elems &/|keys (&/|interpose " ") (&/fold str "")) "}}"))
(|do [^MethodVisitor *writer* &/get-writer
:let [elems* (->> ?elems
&/->seq
(sort #(compare (&/|first %1) (&/|first %2)))
&/->list)
- ;; _ (prn 'compile-record (str "{{" (->> elems* &/|keys (&/|interpose " ") (&/fold str "")) "}}"))
num-elems (&/|length elems*)
_ (doto *writer*
(.visitLdcInsn (int num-elems))
- (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))]
- _ (&/map% (fn [idx+kv]
- (|let [[idx [k v]] idx+kv]
- (|do [:let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int idx)))]
- ret (compile v)
- :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
- (return ret))))
- (&/zip2 (&/|range num-elems) elems*))]
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))]
+ _ (&/map2% (fn [idx kv]
+ (|let [[k v] kv]
+ (|do [:let [_ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int idx)))]
+ ret (compile v)
+ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
+ (return ret))))
+ (&/|range num-elems) elems*)]
(return nil)))
(defn compile-variant [compile *type* ?tag ?value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitLdcInsn (int 2))
- (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object"))
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 0))
(.visitLdcInsn ?tag)
@@ -111,61 +112,106 @@
(return nil)))
(defn compile-captured [compile *type* ?scope ?captured-id ?source]
- ;; (prn 'compile-captured ?scope ?captured-id)
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitVarInsn Opcodes/ALOAD 0)
(.visitFieldInsn Opcodes/GETFIELD
- (&host/location ?scope)
+ (str (&host/->module-class (&/|head ?scope)) "/" (&host/location (&/|tail ?scope)))
(str &&/closure-prefix ?captured-id)
"Ljava/lang/Object;"))]]
(return nil)))
(defn compile-global [compile *type* ?owner-class ?name]
(|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) "_datum" "Ljava/lang/Object;")]]
(return nil)))
-(defn compile-apply [compile *type* ?fn ?arg]
+(defn compile-apply [compile *type* ?fn ?args]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?fn)
- _ (compile ?arg)
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]]
+ _ (&/map% (fn [?arg]
+ (|do [=arg (compile ?arg)
+ :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)]]
+ (return =arg)))
+ ?args)]
(return nil)))
+(defn ^:private compile-def-type [compile ?body ?def-data]
+ (|do [^MethodVisitor **writer** &/get-writer]
+ (matchv ::M/objects [?def-data]
+ [["lux;TypeD" _]]
+ (let [_ (doto **writer**
+ ;; Tail: Begin
+ (.visitLdcInsn (int 2)) ;; S
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V
+ (.visitInsn Opcodes/DUP) ;; VV
+ (.visitLdcInsn (int 0)) ;; VVI
+ (.visitLdcInsn "lux;TypeD") ;; VVIT
+ (.visitInsn Opcodes/AASTORE) ;; V
+ (.visitInsn Opcodes/DUP) ;; VV
+ (.visitLdcInsn (int 1)) ;; VVI
+ (.visitInsn Opcodes/ACONST_NULL) ;; VVIN
+ (.visitInsn Opcodes/AASTORE) ;; V
+ )]
+ (return nil))
+
+ [["lux;ValueD" _]]
+ (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0))
+ [?def-value ?def-type] (matchv ::M/objects [?body]
+ [[["ann" [?def-value ?type-expr]] ?def-type]]
+ (&/T ?def-value ?type-expr)
+
+ [[?def-value ?def-type]]
+ (&/T ?body (&&type/->analysis ?def-type)))]
+ (|do [:let [_ (doto **writer**
+ (.visitLdcInsn (int 2)) ;; S
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V
+ (.visitInsn Opcodes/DUP) ;; VV
+ (.visitLdcInsn (int 0)) ;; VVI
+ (.visitLdcInsn "lux;ValueD") ;; VVIT
+ (.visitInsn Opcodes/AASTORE) ;; V
+ (.visitInsn Opcodes/DUP) ;; VV
+ (.visitLdcInsn (int 1)) ;; VVI
+ )]
+ _ (compile ?def-type)
+ :let [_ (.visitInsn **writer** Opcodes/AASTORE)]]
+ (return nil)))
+ )))
+
(defn compile-def [compile ?name ?body ?def-data]
(|do [^ClassWriter *writer* &/get-writer
module-name &/get-module-name
- :let [outer-class (&host/->class module-name)
- datum-sig (&host/->type-signature "java.lang.Object")
- current-class (&host/location (&/|list outer-class ?name))
- _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
+ :let [datum-sig "Ljava/lang/Object;"
+ def-name (&/normalize-name ?name)
+ current-class (str (&host/->module-class module-name) "/" def-name)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)]))
+ current-class nil "java/lang/Object" (into-array [&&/function-class]))
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_name" "Ljava/lang/String;" nil ?name)
+ (doto (.visitEnd)))
(-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_meta" datum-sig nil nil)
(doto (.visitEnd))))]
- ;; :let [_ (prn 'compile-def/pre-body)]
_ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
(|do [^MethodVisitor **writer** &/get-writer
:let [_ (.visitCode **writer**)]
- ;; :let [_ (prn 'compile-def/pre-body2)]
_ (compile ?body)
- ;; :let [_ (prn 'compile-def/post-body2)]
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_datum" datum-sig)]
+ _ (compile-def-type compile ?body ?def-data)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_meta" datum-sig)]
:let [_ (doto **writer**
- (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig)
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))]]
(return nil)))
- ;; :let [_ (prn 'compile-def/post-body)]
:let [_ (.visitEnd *writer*)]
- ;; :let [_ (prn 'compile-def/_1 ?name current-class)]
- _ (&&/save-class! current-class (.toByteArray =class))
- ;; :let [_ (prn 'compile-def/_2 ?name)]
- ]
+ _ (&&/save-class! def-name (.toByteArray =class))]
(return nil)))
+(defn compile-ann [compile *type* ?value-ex ?type-ex]
+ (compile ?value-ex))
+
(defn compile-declare-macro [compile module name]
(|do [_ (&a-module/declare-macro module name)]
(return nil)))
diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj
new file mode 100644
index 000000000..40639e85a
--- /dev/null
+++ b/src/lux/compiler/package.clj
@@ -0,0 +1,61 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns lux.compiler.package
+ (:require [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match.array
+ (lux [base :as & :refer [|let |do return* return fail fail*]]
+ [host :as &host])
+ (lux.compiler [base :as &&]))
+ (:import (java.io File
+ FileInputStream
+ FileOutputStream
+ BufferedInputStream)
+ (java.util.jar Manifest
+ Attributes$Name
+ JarEntry
+ JarOutputStream
+ )))
+
+;; [Utils]
+(def ^:private kilobyte 1024)
+
+(defn ^:private manifest [^String module]
+ "(-> Text Manifest)"
+ (doto (new Manifest)
+ (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._"))
+ (.put Attributes$Name/MANIFEST_VERSION "1.0")))))
+
+(defn ^:private write-class! [^String path ^File file ^JarOutputStream out]
+ "(-> Text File JarOutputStream Unit)"
+ (with-open [in (new BufferedInputStream (new FileInputStream file))]
+ (let [buffer (byte-array (* 10 kilobyte))]
+ (doto out
+ (.putNextEntry (new JarEntry (str path "/" (.getName file))))
+ (-> (.write buffer 0 bytes-read)
+ (->> (when (not= -1 bytes-read))
+ (loop [bytes-read (.read in buffer)])))
+ (.flush)
+ (.closeEntry)
+ ))
+ ))
+
+(defn ^:private write-module! [^File file ^JarOutputStream out]
+ "(-> File JarOutputStream Unit)"
+ (let [module-name (.getName file)]
+ (doseq [$class (.listFiles file)]
+ (write-class! module-name $class out))))
+
+;; [Resources]
+(defn package [module]
+ "(-> Text (,))"
+ ;; (prn 'package module)
+ (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))]
+ (doseq [$group (.listFiles (new File &&/output-dir))]
+ (write-module! $group out))
+ ))
diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj
new file mode 100644
index 000000000..a92911444
--- /dev/null
+++ b/src/lux/compiler/type.clj
@@ -0,0 +1,97 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns lux.compiler.type
+ (:require [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match.array
+ (lux [base :as & :refer [|do return* return fail fail* |let]]
+ [type :as &type])))
+
+;; [Utils]
+(defn ^:private variant$ [tag body]
+ "(-> Text Analysis Analysis)"
+ (&/T (&/V "variant" (&/T tag body))
+ &type/$Void))
+
+(defn ^:private tuple$ [members]
+ "(-> (List Analysis) Analysis)"
+ (&/T (&/V "tuple" members)
+ &type/$Void))
+
+(defn ^:private text$ [text]
+ "(-> Text Analysis)"
+ (&/T (&/V "text" text)
+ &type/$Void))
+
+(def ^:private $Nil
+ "Analysis"
+ (variant$ "lux;Nil" (tuple$ (&/|list))))
+
+(defn ^:private Cons$ [head tail]
+ "(-> Analysis Analysis Analysis)"
+ (variant$ "lux;Cons" (tuple$ (&/|list head tail))))
+
+;; [Exports]
+(defn ->analysis [type]
+ "(-> Type Analysis)"
+ (matchv ::M/objects [type]
+ [["lux;DataT" ?class]]
+ (variant$ "lux;DataT" (text$ ?class))
+
+ [["lux;TupleT" ?members]]
+ (variant$ "lux;TupleT"
+ (&/fold (fn [tail head]
+ (Cons$ (->analysis head) tail))
+ $Nil
+ (&/|reverse ?members)))
+
+ [["lux;VariantT" ?cases]]
+ (variant$ "lux;VariantT"
+ (&/fold (fn [tail head]
+ (|let [[hlabel htype] head]
+ (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype)))
+ tail)))
+ $Nil
+ (&/|reverse ?cases)))
+
+ [["lux;RecordT" ?slots]]
+ (variant$ "lux;RecordT"
+ (&/fold (fn [tail head]
+ (|let [[hlabel htype] head]
+ (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype)))
+ tail)))
+ $Nil
+ (&/|reverse ?slots)))
+
+ [["lux;LambdaT" [?input ?output]]]
+ (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output))))
+
+ [["lux;AllT" [?env ?name ?arg ?body]]]
+ (variant$ "lux;AllT"
+ (tuple$ (&/|list (matchv ::M/objects [?env]
+ [["lux;None" _]]
+ (variant$ "lux;Some" (tuple$ (&/|list)))
+
+ [["lux;Some" ??env]]
+ (variant$ "lux;Some"
+ (&/fold (fn [tail head]
+ (|let [[hlabel htype] head]
+ (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype)))
+ tail)))
+ $Nil
+ (&/|reverse ??env))))
+ (text$ ?name)
+ (text$ ?arg)
+ (->analysis ?body))))
+
+ [["lux;BoundT" ?name]]
+ (variant$ "lux;BoundT" (text$ ?name))
+
+ [["lux;AppT" [?fun ?arg]]]
+ (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg))))
+ ))
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 80dfd78d5..906e3c714 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.host
(:require (clojure [string :as string]
[template :refer [do-template]])
@@ -10,6 +18,7 @@
;; [Constants]
(def prefix "lux.")
(def function-class (str prefix "Function"))
+(def module-separator "_")
;; [Utils]
(defn ^:private class->type [^Class class]
@@ -18,45 +27,26 @@
(str (.getName pkg) ".")
"")
(.getSimpleName class)))]
- (if (= "void" base)
- (return &type/$Void)
+ (if (.equals "void" base)
+ (return &type/Unit)
(return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "["))
base)))
)))
(defn ^:private method->type [^Method method]
- (|do [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method))))
- =return (class->type (.getReturnType method))]
- (return =return)))
+ (class->type (.getReturnType method)))
;; [Resources]
-(defn full-class [class-name]
- (case class-name
- "boolean" (return Boolean/TYPE)
- "byte" (return Byte/TYPE)
- "short" (return Short/TYPE)
- "int" (return Integer/TYPE)
- "long" (return Long/TYPE)
- "float" (return Float/TYPE)
- "double" (return Double/TYPE)
- "char" (return Character/TYPE)
- ;; else
- (try (return (Class/forName class-name))
- (catch Exception e
- (fail (str "[Analyser Error] Unknown class: " class-name))))))
-
-(defn full-class-name [class-name]
- ;; (prn 'full-class-name class-name)
- (|do [^Class =class (full-class class-name)]
- (return (.getName =class))))
-
(defn ^String ->class [class]
(string/replace class #"\." "/"))
-(def ->package ->class)
+(defn ^String ->module-class [module-name]
+ (string/replace module-name #"/" module-separator))
+
+(def ->package ->module-class)
(defn ->type-signature [class]
- (assert (string? class))
+ ;; (assert (string? class))
(case class
"void" "V"
"boolean" "Z"
@@ -82,58 +72,41 @@
[["lux;LambdaT" [_ _]]]
(->type-signature function-class)
- [["lux;VariantT" ["lux;Nil" _]]]
+ [["lux;TupleT" ["lux;Nil" _]]]
"V"
-
- [_]
- (assert false (prn-str '->java-sig (aget type 0)))))
-
-(defn extract-jvm-param [token]
- (matchv ::M/objects [token]
- [["lux;Meta" [_ ["lux;Symbol" [_ ?ident]]]]]
- (full-class-name ?ident)
-
- [_]
- (fail (str "[Host] Unknown JVM param: " (pr-str token)))))
+ ))
(do-template [<name> <static?>]
- (defn <name> [target field]
- (let [target (Class/forName target)]
- (if-let [type* (first (for [^Field =field (.getFields target)
- :when (and (= target (.getDeclaringClass =field))
- (= field (.getName =field))
- (= <static?> (Modifier/isStatic (.getModifiers =field))))]
- (.getType =field)))]
- (|do [=type (class->type type*)]
- (return =type))
- (fail (str "[Analyser Error] Field does not exist: " target field)))))
+ (defn <name> [class-loader target field]
+ (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&type/as-obj target) true class-loader))
+ :when (and (.equals ^Object field (.getName =field))
+ (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))]
+ (.getType =field)))]
+ (|do [=type (class->type type*)]
+ (return =type))
+ (fail (str "[Analyser Error] Field does not exist: " target "." field))))
lookup-static-field true
lookup-field false
)
(do-template [<name> <static?>]
- (defn <name> [target method-name args]
- (let [target (Class/forName target)]
- (if-let [method (first (for [^Method =method (.getMethods target)
- ;; :let [_ (prn '<name> '=method =method (mapv #(.getName %) (.getParameterTypes =method)))]
- :when (and (= target (.getDeclaringClass =method))
- (= method-name (.getName =method))
- (= <static?> (Modifier/isStatic (.getModifiers =method)))
- (&/fold #(and %1 %2)
- true
- (&/|map (fn [xy]
- (|let [[x y] xy]
- (= x y)))
- (&/zip2 args
- (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))]
- =method))]
- (method->type method)
- (fail (str "[Analyser Error] Method does not exist: " target method-name)))))
+ (defn <name> [class-loader target method-name args]
+ ;; (prn '<name> target method-name)
+ (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader))
+ :when (and (.equals ^Object method-name (.getName =method))
+ (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method)))
+ (&/fold2 #(and %1 (.equals ^Object %2 %3))
+ true
+ args
+ (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))]
+ =method))]
+ (method->type method)
+ (fail (str "[Analyser Error] Method does not exist: " target "." method-name))))
lookup-static-method true
lookup-virtual-method false
)
(defn location [scope]
- (->> scope (&/|map &/normalize-ident) (&/|interpose "$") (&/fold str "")))
+ (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str "")))
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index b7729156a..bb6e54cb4 100644
--- a/src/lux/lexer.clj
+++ b/src/lux/lexer.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.lexer
(:require [clojure.template :refer [do-template]]
(lux [base :as & :refer [|do return* return fail fail*]]
@@ -6,120 +14,120 @@
;; [Utils]
(defn ^:private escape-char [escaped]
- ;; (prn 'escape-char escaped)
- (condp = escaped
- "\\t" (return "\t")
- "\\b" (return "\b")
- "\\n" (return "\n")
- "\\r" (return "\r")
- "\\f" (return "\f")
- "\\\"" (return "\"")
- "\\\\" (return "\\")
- ;; else
- (fail (str "[Lexer Error] Unknown escape character: " escaped))))
+ (cond (.equals ^Object escaped "\\t") (return "\t")
+ (.equals ^Object escaped "\\b") (return "\b")
+ (.equals ^Object escaped "\\n") (return "\n")
+ (.equals ^Object escaped "\\r") (return "\r")
+ (.equals ^Object escaped "\\f") (return "\f")
+ (.equals ^Object escaped "\\\"") (return "\"")
+ (.equals ^Object escaped "\\\\") (return "\\")
+ :else
+ (fail (str "[Lexer Error] Unknown escape character: " escaped))))
(defn ^:private lex-text-body [_]
- (&/try-all% (&/|list (|do [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)")
- ;; :let [_ (prn '[prefix escaped] [prefix escaped])]
+ (&/try-all% (&/|list (|do [[_ [prefix escaped]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)")
unescaped (escape-char escaped)
- ;; :let [_ (prn 'unescaped unescaped)]
- postfix (lex-text-body nil)
- ;; :let [_ (prn 'postfix postfix)]
- ]
+ postfix (lex-text-body nil)]
(return (str prefix unescaped postfix)))
- (|do [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")]
+ (|do [[_ body] (&reader/read-regex #"(?s)^([^\"\\]*)")]
(return body)))))
-(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)")
+(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)"
+ ;; #"^([^0-9\[\]\(\)\{\};#\s\"][^\[\]\(\)\{\};#\s\"]*)"
+ )
;; [Lexers]
(def ^:private lex-white-space
- (|do [[_ [meta white-space]] (&reader/read-regex #"^(\s+)")]
+ (|do [[meta white-space] (&reader/read-regex #"^(\s+)")]
(return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space))))))
(def ^:private lex-single-line-comment
- (|do [[_ [meta _]] (&reader/read-text "##")
- [_ [_ comment]] (&reader/read-regex #"^(.*)$")]
+ (|do [_ (&reader/read-text "##")
+ [meta comment] (&reader/read-regex #"^(.*)$")]
(return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment))))))
(defn ^:private lex-multi-line-comment [_]
(|do [_ (&reader/read-text "#(")
- [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^((?!#\().)*?(?=\)#)")]
- (return comment))
- (|do [[_ [meta pre]] (&reader/read-regex #"(?is)^(.+?(?=#\())")
- [_ inner] (lex-multi-line-comment nil)
- [_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))")]
- (return (str pre "#(" inner ")#" post)))))
- _ (&reader/read-text ")#")]
+ [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))")
+ ;; :let [_ (prn 'immediate comment)]
+ _ (&reader/read-text ")#")]
+ (return (&/T meta comment)))
+ (|do [;; :let [_ (prn 'pre/_0)]
+ [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)")
+ ;; :let [_ (prn 'pre pre)]
+ [_ inner] (lex-multi-line-comment nil)
+ ;; :let [_ (prn 'inner inner)]
+ [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))")
+ ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))]
+ ]
+ (return (&/T meta (str pre "#(" inner ")#" post))))))
+ ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))]
+ _ (&reader/read-text ")#")]
(return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment))))))
(def ^:private lex-comment
(&/try-all% (&/|list lex-single-line-comment
- ;; (lex-multi-line-comment nil)
- )))
+ (lex-multi-line-comment nil))))
(do-template [<name> <tag> <regex>]
(def <name>
- (|do [[_ [meta token]] (&reader/read-regex <regex>)]
+ (|do [[meta token] (&reader/read-regex <regex>)]
(return (&/V "lux;Meta" (&/T meta (&/V <tag> token))))))
^:private lex-bool "Bool" #"^(true|false)"
- ^:private lex-int "Int" #"^-?(0|[1-9][0-9]*)"
- ^:private lex-real "Real" #"^-?(0|[1-9][0-9]*)\.[0-9]+"
+ ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)"
+ ^:private lex-real "Real" #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)"
)
(def ^:private lex-char
- (|do [[_ [meta _]] (&reader/read-text "#\"")
- token (&/try-all% (&/|list (|do [[_ [_ escaped]] (&reader/read-regex #"^(\\.)")]
- (escape-char escaped))
- (|do [[_ [_ char]] (&reader/read-regex #"^(.)")]
- (return char))))
- _ (&reader/read-text "\"")]
+ (|do [[meta _] (&reader/read-text "#\"")
+ token (&/try-all% (&/|list (|do [[_ escaped] (&reader/read-regex #"^(\\.)")]
+ (escape-char escaped))
+ (|do [[_ char] (&reader/read-regex #"^(.)")]
+ (return char))))
+ _ (&reader/read-text "\"")]
(return (&/V "lux;Meta" (&/T meta (&/V "Char" token))))))
(def ^:private lex-text
- (|do [[_ [meta _]] (&reader/read-text "\"")
- token (lex-text-body nil)
- _ (&reader/read-text "\"")]
+ (|do [[meta _] (&reader/read-text "\"")
+ token (lex-text-body nil)
+ _ (&reader/read-text "\"")]
(return (&/V "lux;Meta" (&/T meta (&/V "Text" token))))))
(def ^:private lex-ident
- (&/try-all% (&/|list (|do [[_ [meta token]] (&reader/read-regex +ident-re+)]
+ (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)]
(&/try-all% (&/|list (|do [_ (&reader/read-text ";")
- [_ [_ local-token]] (&reader/read-regex +ident-re+)]
- (&/try-all% (&/|list (|do [unaliased (&module/dealias token)]
- (return (&/V "lux;Meta" (&/T meta (&/T unaliased local-token)))))
- (|do [? (&module/exists? token)]
- (if ?
- (return (&/V "lux;Meta" (&/T meta (&/T token local-token))))
- (fail (str "[Lexer Error] Unknown module: " token))))
- )))
- (return (&/V "lux;Meta" (&/T meta (&/T "" token))))
+ [_ local-token] (&reader/read-regex +ident-re+)
+ ? (&module/exists? token)]
+ (if ?
+ (return (&/T meta (&/T token local-token)))
+ (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token)
+ (&module/dealias token))]
+ (do ;; (prn "Unaliased: " unaliased ";" local-token)
+ (return (&/T meta (&/T unaliased local-token)))))))
+ (return (&/T meta (&/T "" token)))
)))
- (|do [[_ [meta _]] (&reader/read-text ";;")
- [_ [_ token]] (&reader/read-regex +ident-re+)
+ (|do [[meta _] (&reader/read-text ";;")
+ [_ token] (&reader/read-regex +ident-re+)
module-name &/get-module-name]
- (return (&/V "lux;Meta" (&/T meta (&/T module-name token)))))
- (|do [[_ [meta _]] (&reader/read-text ";")
- [_ [_ token]] (&reader/read-regex +ident-re+)]
- (return (&/V "lux;Meta" (&/T meta (&/T "lux" token)))))
+ (return (&/T meta (&/T module-name token))))
+ (|do [[meta _] (&reader/read-text ";")
+ [_ token] (&reader/read-regex +ident-re+)]
+ (return (&/T meta (&/T "lux" token))))
)))
(def ^:private lex-symbol
- (|do [[_ [meta ident]] lex-ident]
+ (|do [[meta ident] lex-ident]
(return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident))))))
(def ^:private lex-tag
- (|do [[_ [meta _]] (&reader/read-text "#")
- ;; :let [_ (prn 'lex-tag)]
- [_ [_ ident]] lex-ident
- ;; :let [_ (prn 'lex-tag [(aget ident 0) (aget ident 1)])]
- ]
+ (|do [[meta _] (&reader/read-text "#")
+ [_ ident] lex-ident]
(return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident))))))
(do-template [<name> <text> <tag>]
(def <name>
- (|do [[_ [meta _]] (&reader/read-text <text>)]
+ (|do [[meta _] (&reader/read-text <text>)]
(return (&/V "lux;Meta" (&/T meta (&/V <tag> nil))))))
^:private lex-open-paren "(" "Open_Paren"
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index e50d2aae9..5056a09e0 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.optimizer
(:require [lux.analyser :as &analyser]))
@@ -12,8 +20,7 @@
;; Pre-compute constant expressions: Find function calls for which all arguments are known at compile-time and pre-calculate everything prior to compilation.
;; Convert pattern-matching on booleans into regular if-then-else structures
;; Local var aliasing.
-;; Global var aliasing.
;; [Exports]
-(defn optimize [eval!]
- (&analyser/analyse eval!))
+(defn optimize [eval! compile-module]
+ (&analyser/analyse eval! compile-module))
diff --git a/src/lux/parser.clj b/src/lux/parser.clj
index cb89f63a2..966c322bf 100644
--- a/src/lux/parser.clj
+++ b/src/lux/parser.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.parser
(:require [clojure.template :refer [do-template]]
[clojure.core.match :as M :refer [matchv]]
@@ -17,24 +25,18 @@
[_]
(fail (str "[Parser Error] Unbalanced " <description> ".")))))
- ^:private parse-form "Close_Paren" "parantheses" "lux;Form"
- ^:private parse-tuple "Close_Bracket" "brackets" "lux;Tuple"
+ ^:private parse-form "Close_Paren" "parantheses" "lux;FormS"
+ ^:private parse-tuple "Close_Bracket" "brackets" "lux;TupleS"
)
(defn ^:private parse-record [parse]
- (|do [;; :let [_ (prn 'parse-record 0)]
- elems* (&/repeat% parse)
- ;; :let [_ (prn 'parse-record 1)]
+ (|do [elems* (&/repeat% parse)
token &lexer/lex
- ;; :let [_ (prn 'parse-record 2)]
- :let [elems (&/fold &/|++ (&/|list) elems*)]
- ;; :let [_ (prn 'parse-record 3)]
- ]
+ :let [elems (&/fold &/|++ (&/|list) elems*)]]
(matchv ::M/objects [token]
[["lux;Meta" [meta ["Close_Brace" _]]]]
(if (even? (&/|length elems))
- (do ;; (prn 'PARSED_RECORD (&/|length elems))
- (return (&/V "lux;Record" (&/|as-pairs elems))))
+ (return (&/V "lux;RecordS" (&/|as-pairs elems)))
(fail (str "[Parser Error] Records must have an even number of elements.")))
[_]
@@ -42,50 +44,49 @@
;; [Interface]
(def parse
- (|do [token &lexer/lex
- ;; :let [_ (prn 'parse/token token)]
- ;; :let [_ (prn 'parse (aget token 0))]
- ]
+ (|do [token &lexer/lex]
(matchv ::M/objects [token]
- [["lux;Meta" [meta ["White_Space" _]]]]
- (return (&/|list))
+ [["lux;Meta" [meta token*]]]
+ (matchv ::M/objects [token*]
+ [["White_Space" _]]
+ (return (&/|list))
- [["lux;Meta" [meta ["Comment" _]]]]
- (return (&/|list))
-
- [["lux;Meta" [meta ["Bool" ?value]]]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Bool" (Boolean/parseBoolean ?value))))))
+ [["Comment" _]]
+ (return (&/|list))
+
+ [["Bool" ?value]]
+ (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value))))))
- [["lux;Meta" [meta ["Int" ?value]]]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Int" (Integer/parseInt ?value))))))
+ [["Int" ?value]]
+ (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value))))))
- [["lux;Meta" [meta ["Real" ?value]]]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Real" (Float/parseFloat ?value))))))
+ [["Real" ?value]]
+ (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value))))))
- [["lux;Meta" [meta ["Char" ^String ?value]]]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Char" (.charAt ?value 0))))))
+ [["Char" ^String ?value]]
+ (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0))))))
- [["lux;Meta" [meta ["Text" ?value]]]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Text" ?value)))))
+ [["Text" ?value]]
+ (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value)))))
- [["lux;Meta" [meta ["Symbol" ?ident]]]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Symbol" ?ident)))))
+ [["Symbol" ?ident]]
+ (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident)))))
- [["lux;Meta" [meta ["Tag" ?ident]]]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Tag" ?ident)))))
+ [["Tag" ?ident]]
+ (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident)))))
- [["lux;Meta" [meta ["Open_Paren" _]]]]
- (|do [syntax (parse-form parse)]
- (return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
-
- [["lux;Meta" [meta ["Open_Bracket" _]]]]
- (|do [syntax (parse-tuple parse)]
- (return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
+ [["Open_Paren" _]]
+ (|do [syntax (parse-form parse)]
+ (return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
+
+ [["Open_Bracket" _]]
+ (|do [syntax (parse-tuple parse)]
+ (return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
- [["lux;Meta" [meta ["Open_Brace" _]]]]
- (|do [syntax (parse-record parse)]
- (return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
+ [["Open_Brace" _]]
+ (|do [syntax (parse-record parse)]
+ (return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
- [_]
- (fail "[Parser Error] Unknown lexer token.")
- )))
+ [_]
+ (fail "[Parser Error] Unknown lexer token.")
+ ))))
diff --git a/src/lux/reader.clj b/src/lux/reader.clj
index d66a671aa..9fd9b14ea 100644
--- a/src/lux/reader.clj
+++ b/src/lux/reader.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.reader
(:require [clojure.string :as string]
[clojure.core.match :as M :refer [matchv]]
@@ -8,93 +16,131 @@
(defn ^:private with-line [body]
(fn [state]
(matchv ::M/objects [(&/get$ &/$SOURCE state)]
- [["lux;None" _]]
- (fail* "[Reader Error] No source code.")
-
- [["lux;Some" ["lux;Nil" _]]]
+ [["lux;Nil" _]]
(fail* "[Reader Error] EOF")
- [["lux;Some" ["lux;Cons" [["lux;Meta" [[file-name line-num column-num] line]]
- more]]]]
+ [["lux;Cons" [[[file-name line-num column-num] line]
+ more]]]
(matchv ::M/objects [(body file-name line-num column-num line)]
[["No" msg]]
(fail* msg)
- [["Yes" [meta ["lux;None" _]]]]
- (return* (&/set$ &/$SOURCE (&/V "lux;Some" more) state)
- meta)
+ [["Done" output]]
+ (return* (&/set$ &/$SOURCE more state)
+ output)
+
+ [["Yes" [output line*]]]
+ (return* (&/set$ &/$SOURCE (&/|cons line* more) state)
+ output))
+ )))
+
+(defn ^:private with-lines [body]
+ (fn [state]
+ (matchv ::M/objects [(body (&/get$ &/$SOURCE state))]
+ [["lux;Right" [reader* match]]]
+ (return* (&/set$ &/$SOURCE reader* state)
+ match)
- [["Yes" [meta ["lux;Some" line-meta]]]]
- (return* (&/set$ &/$SOURCE (&/V "lux;Some" (&/|cons line-meta more)) state)
- meta))
+ [["lux;Left" msg]]
+ (fail* msg)
)))
;; [Exports]
+(defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line]
+ (let [matcher (doto (.matcher regex line)
+ (.region column (.length line))
+ (.useAnchoringBounds true))]
+ (when (.find matcher)
+ (.group matcher 0))))
+
+(defn ^:private re-find1! [^java.util.regex.Pattern regex column ^String line]
+ (let [matcher (doto (.matcher regex line)
+ (.region column (.length line))
+ (.useAnchoringBounds true))]
+ (when (.find matcher)
+ (.group matcher 1))))
+
+(defn ^:private re-find3! [^java.util.regex.Pattern regex column ^String line]
+ (let [matcher (doto (.matcher regex line)
+ (.region column (.length line))
+ (.useAnchoringBounds true))]
+ (when (.find matcher)
+ (list (.group matcher 0)
+ (.group matcher 1)
+ (.group matcher 2)))))
+
(defn read-regex [regex]
(with-line
(fn [file-name line-num column-num ^String line]
- (if-let [[^String match] (re-find regex line)]
- (let [match-length (.length match)
- line* (.substring line match-length)
- ;; _ (prn 'with-line line*)
- ]
- (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match))
- (if (empty? line*)
- (&/V "lux;None" nil)
- (&/V "lux;Some" (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))))
+ ;; (prn 'read-regex [file-name line-num column-num regex line])
+ (if-let [^String match (do ;; (prn '[regex line] [regex line])
+ (re-find! regex column-num line))]
+ (let [;; _ (prn 'match match)
+ match-length (.length match)
+ column-num* (+ column-num match-length)]
+ (if (= column-num* (.length line))
+ (&/V "Done" (&/T (&/T file-name line-num column-num) match))
+ (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) match)
+ (&/T (&/T file-name line-num column-num*) line)))))
(&/V "No" (str "[Reader Error] Pattern failed: " regex))))))
(defn read-regex2 [regex]
(with-line
(fn [file-name line-num column-num ^String line]
- (if-let [[^String match tok1 tok2] (re-find regex line)]
+ ;; (prn 'read-regex2 [file-name line-num column-num regex line])
+ (if-let [[^String match tok1 tok2] (re-find3! regex column-num line)]
(let [match-length (.length match)
- line* (.substring line match-length)
- ;; _ (prn 'with-line line*)
- ]
- (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)))
- (if (empty? line*)
- (&/V "lux;None" nil)
- (&/V "lux;Some" (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))))
+ column-num* (+ column-num match-length)]
+ (if (= column-num* (.length line))
+ (&/V "Done" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)))
+ (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))
+ (&/T (&/T file-name line-num column-num*) line)))))
(&/V "No" (str "[Reader Error] Pattern failed: " regex))))))
+(defn read-regex+ [regex]
+ (with-lines
+ (fn [reader]
+ (loop [prefix ""
+ reader* reader]
+ (matchv ::M/objects [reader*]
+ [["lux;Nil" _]]
+ (&/V "lux;Left" "[Reader Error] EOF")
+
+ [["lux;Cons" [[[file-name line-num column-num] ^String line]
+ reader**]]]
+ (if-let [^String match (do ;; (prn 'read-regex+ regex line)
+ (re-find1! regex column-num line))]
+ (let [match-length (.length match)
+ column-num* (+ column-num match-length)]
+ (if (= column-num* (.length line))
+ (recur (str prefix match "\n") reader**)
+ (&/V "lux;Right" (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line)
+ reader**)
+ (&/T (&/T file-name line-num column-num) (str prefix match))))))
+ (&/V "lux;Left" (str "[Reader Error] Pattern failed: " regex))))))))
+
(defn read-text [^String text]
(with-line
(fn [file-name line-num column-num ^String line]
- ;; (prn 'read-text text line)
- (if (.startsWith line text)
+ ;; (prn 'read-text [file-name line-num column-num text line])
+ (if (.startsWith line text column-num)
(let [match-length (.length text)
- line* (.substring line match-length)
- ;; _ (prn 'with-line line*)
- ]
- (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text))
- (if (empty? line*)
- (&/V "lux;None" nil)
- (&/V "lux;Some" (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))))
+ column-num* (+ column-num match-length)]
+ (if (= column-num* (.length line))
+ (&/V "Done" (&/T (&/T file-name line-num column-num) text))
+ (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) text)
+ (&/T (&/T file-name line-num column-num*) line)))))
(&/V "No" (str "[Reader Error] Text failed: " text))))))
-(defn from [file-name]
- (let [lines (&/->list (string/split-lines (slurp file-name)))]
+(def ^:private ^String +source-dir+ "input/")
+(defn from [^String file-name ^String file-content]
+ (let [lines (&/->list (string/split-lines file-content))
+ file-name (.substring file-name (.length +source-dir+))]
(&/|map (fn [line+line-num]
- (|let [[line line-num] line+line-num]
- (&/V "lux;Meta" (&/T (&/T file-name line-num 0)
- line))))
+ (|let [[line-num line] line+line-num]
+ (&/T (&/T file-name (inc line-num) 0)
+ line)))
(&/|filter (fn [line+line-num]
- (|let [[line line-num] line+line-num]
- (not (empty? line))))
- (&/zip2 lines
- (&/|range (&/|length lines)))))))
-
-(def current-line
- (fn [state]
- (matchv ::M/objects [(&/get$ &/$SOURCE state)]
- [["lux;None" _]]
- (fail* "[Reader Error] No source code.")
-
- [["lux;Some" ["lux;Nil" _]]]
- (fail* "[Reader Error] EOF")
-
- [["lux;Some" ["lux;Cons" [["lux;Meta" [_ line]]
- more]]]]
- (return* state line)
- )))
+ (|let [[line-num line] line+line-num]
+ (not= "" line)))
+ (&/enumerate lines)))))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 0df628b15..f5b8d3f25 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -1,3 +1,11 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
(ns lux.type
(:refer-clojure :exclude [deref apply merge bound?])
(:require [clojure.core.match :as M :refer [match matchv]]
@@ -15,15 +23,19 @@
(def Unit (&/V "lux;TupleT" (&/|list)))
(def $Void (&/V "lux;VariantT" (&/|list)))
+(def IO
+ (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "IO" "a"
+ (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a"))))))
+
(def List
- (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "List" "a"
+ (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;List" "a"
(&/V "lux;VariantT" (&/|list (&/T "lux;Nil" Unit)
(&/T "lux;Cons" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a")
- (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "List")
+ (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List")
(&/V "lux;BoundT" "a")))))))))))
(def Maybe
- (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "Maybe" "a"
+ (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;Maybe" "a"
(&/V "lux;VariantT" (&/|list (&/T "lux;None" Unit)
(&/T "lux;Some" (&/V "lux;BoundT" "a")))))))
@@ -31,7 +43,7 @@
(let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_")))
TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type))))
TypePair (&/V "lux;TupleT" (&/|list Type Type))]
- (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "Type" "_"
+ (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "Type" "_"
(&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text)
(&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type)))
(&/T "lux;VariantT" TypeEnv)
@@ -49,7 +61,7 @@
(&/V "lux;AllT" (&/T (&/V "lux;None" nil) name arg body)))
(def Bindings
- (fAll "Bindings" "k"
+ (fAll "lux;Bindings" "k"
(fAll "" "v"
(&/V "lux;RecordT" (&/|list (&/T "lux;counter" Int)
(&/T "lux;mappings" (&/V "lux;AppT" (&/T List
@@ -59,7 +71,7 @@
(def Env
(let [bindings (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings (&/V "lux;BoundT" "k")))
(&/V "lux;BoundT" "v")))]
- (fAll "Env" "k"
+ (fAll "lux;Env" "k"
(fAll "" "v"
(&/V "lux;RecordT"
(&/|list (&/T "lux;name" Text)
@@ -72,7 +84,7 @@
(&/V "lux;TupleT" (&/|list Text Int Int)))
(def Meta
- (fAll "Meta" "m"
+ (fAll "lux;Meta" "m"
(fAll "" "v"
(&/V "lux;VariantT" (&/|list (&/T "lux;Meta" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m")
(&/V "lux;BoundT" "v")))))))))
@@ -81,20 +93,20 @@
(def Syntax*
(let [Syntax* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w")
- (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Syntax'")
+ (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Syntax'")
(&/V "lux;BoundT" "w")))))
Syntax*List (&/V "lux;AppT" (&/T List Syntax*))]
- (fAll "Syntax'" "w"
- (&/V "lux;VariantT" (&/|list (&/T "lux;Bool" Bool)
- (&/T "lux;Int" Int)
- (&/T "lux;Real" Real)
- (&/T "lux;Char" Char)
- (&/T "lux;Text" Text)
- (&/T "lux;Symbol" Ident)
- (&/T "lux;Tag" Ident)
- (&/T "lux;Form" Syntax*List)
- (&/T "lux;Tuple" Syntax*List)
- (&/T "lux;Record" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Syntax* Syntax*))))))
+ (fAll "lux;Syntax'" "w"
+ (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool)
+ (&/T "lux;IntS" Int)
+ (&/T "lux;RealS" Real)
+ (&/T "lux;CharS" Char)
+ (&/T "lux;TextS" Text)
+ (&/T "lux;SymbolS" Ident)
+ (&/T "lux;TagS" Ident)
+ (&/T "lux;FormS" Syntax*List)
+ (&/T "lux;TupleS" Syntax*List)
+ (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Syntax* Syntax*))))))
))))
(def Syntax
@@ -104,13 +116,13 @@
(def ^:private SyntaxList (&/V "lux;AppT" (&/T List Syntax)))
(def Either
- (fAll "_" "l"
+ (fAll "lux;Either" "l"
(fAll "" "r"
(&/V "lux;VariantT" (&/|list (&/T "lux;Left" (&/V "lux;BoundT" "l"))
(&/T "lux;Right" (&/V "lux;BoundT" "r")))))))
(def StateE
- (fAll "StateE" "s"
+ (fAll "lux;StateE" "s"
(fAll "" "a"
(&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s")
(&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text))
@@ -126,10 +138,10 @@
(&/V "lux;RecordT"
(&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter"))
(&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader"))
- (&/T "lux;eval-ctor" Int))))
+ (&/T "lux;classes" (&/V "lux;DataT" "clojure.lang.Atom")))))
(def DefData*
- (fAll "DefData'" ""
+ (fAll "lux;DefData'" ""
(&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Unit)
(&/T "lux;ValueD" Type)
(&/T "lux;MacroD" (&/V "lux;BoundT" ""))
@@ -139,32 +151,38 @@
(&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int)
(&/T "lux;Global" Ident))))
-(def CompilerState
- (&/V "lux;AppT" (&/T (fAll "CompilerState" ""
+(def $Module
+ (fAll "lux;$Module" "Compiler"
+ (&/V "lux;RecordT"
+ (&/|list (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Text)))))
+ (&/T "lux;defs" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT"
+ (&/|list Text
+ (&/V "lux;TupleT" (&/|list Bool
+ (&/V "lux;AppT" (&/T DefData*
+ (&/V "lux;LambdaT" (&/T SyntaxList
+ (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler")))
+ SyntaxList)))))))))))))
+ (&/T "lux;imports" (&/V "lux;AppT" (&/T List Text)))))))
+
+(def $Compiler
+ (&/V "lux;AppT" (&/T (fAll "lux;Compiler" ""
(&/V "lux;RecordT"
- (&/|list (&/T "lux;source" (&/V "lux;AppT" (&/T Maybe Reader)))
+ (&/|list (&/T "lux;source" Reader)
(&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT"
(&/|list Text
- (&/V "lux;AppT" (&/T List (&/V "lux;TupleT"
- (&/|list Text
- (&/V "lux;TupleT" (&/|list Bool
- (&/V "lux;AppT" (&/T DefData*
- (&/V "lux;LambdaT" (&/T SyntaxList
- (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "CompilerState")
- (&/V "lux;BoundT" "")))))
- SyntaxList)))))))))))))))))
- (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List $Void)))
+ (&/V "lux;AppT" (&/T $Module (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") (&/V "lux;BoundT" ""))))))))))
(&/T "lux;envs" (&/V "lux;AppT" (&/T List
(&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Env Text))
(&/V "lux;TupleT" (&/|list LuxVar Type)))))))
(&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type)))
(&/T "lux;host" HostState)
- (&/T "lux;seed" Int))))
+ (&/T "lux;seed" Int)
+ (&/T "lux;eval?" Bool))))
$Void)))
(def Macro
(&/V "lux;LambdaT" (&/T SyntaxList
- (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE CompilerState))
+ (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler))
SyntaxList)))))
(defn bound? [id]
@@ -180,39 +198,27 @@
(defn deref [id]
(fn [state]
- (let [mappings (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS))]
- (if-let [type* (->> mappings (&/|get id))]
- (matchv ::M/objects [type*]
- [["lux;Some" type]]
- (return* state type)
-
- [["lux;None" _]]
- (fail* (str "[Type Error] Unbound type-var: " id)))
- (fail* (str "[Type Error] <deref> Unknown type-var: " id))))))
-
-(defn set-var* [id type]
- (fn [state]
- (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
- (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %)
- ts))
- state)
- nil)
- (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length))))))
+ (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
+ (matchv ::M/objects [type*]
+ [["lux;Some" type]]
+ (return* state type)
+
+ [["lux;None" _]]
+ (fail* (str "[Type Error] Unbound type-var: " id)))
+ (fail* (str "[Type Error] <deref> Unknown type-var: " id)))))
(defn set-var [id type]
(fn [state]
(if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
- (do ;; (prn 'set-var (aget tvar 0))
- (matchv ::M/objects [tvar]
- [["lux;Some" bound]]
- (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound)))
-
- [["lux;None" _]]
- (do ;; (prn 'set-var id (show-type type))
- (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %)
- ts))
- state)
- nil))))
+ (matchv ::M/objects [tvar]
+ [["lux;Some" bound]]
+ (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound)))
+
+ [["lux;None" _]]
+ (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %)
+ ts))
+ state)
+ nil))
(fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length))))))
;; [Exports]
@@ -221,8 +227,8 @@
(fn [state]
(let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))]
(return* (&/update$ &/$TYPES #(->> %
- (&/update$ &/$COUNTER inc)
- (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V "lux;None" nil) ms))))
+ (&/update$ &/$COUNTER inc)
+ (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V "lux;None" nil) ms))))
state)
id))))
@@ -238,36 +244,33 @@
(|do [ex existential]
(set-var id ex)))]
(fn [state]
- (&/run-state (|do [mappings* (&/map% (fn [binding]
- (|let [[?id ?type] binding]
- (if (= id ?id)
- (return binding)
- (matchv ::M/objects [?type]
- [["lux;None" _]]
- (return binding)
-
- [["lux;Some" ?type*]]
- (matchv ::M/objects [?type*]
- [["lux;VarT" ?id*]]
- (if (= id ?id*)
- (return (&/T ?id (&/V "lux;None" nil)))
- (return binding)
- ;; (|do [?type** (clean* id ?type*)]
- ;; (return (&/T ?id (&/V "lux;Some" ?type**))))
- )
-
- [_]
- (|do [?type** (clean* id ?type*)]
- (return (&/T ?id (&/V "lux;Some" ?type**)))))
- ))))
- (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))]
- (fn [state]
- (return* (&/update$ &/$TYPES #(->> %
- (&/update$ &/$COUNTER dec)
- (&/set$ &/$MAPPINGS (&/|remove id mappings*)))
- state)
- nil)))
- state))))
+ ((|do [mappings* (&/map% (fn [binding]
+ (|let [[?id ?type] binding]
+ (if (.equals ^Object id ?id)
+ (return binding)
+ (matchv ::M/objects [?type]
+ [["lux;None" _]]
+ (return binding)
+
+ [["lux;Some" ?type*]]
+ (matchv ::M/objects [?type*]
+ [["lux;VarT" ?id*]]
+ (if (.equals ^Object id ?id*)
+ (return (&/T ?id (&/V "lux;None" nil)))
+ (return binding))
+
+ [_]
+ (|do [?type** (clean* id ?type*)]
+ (return (&/T ?id (&/V "lux;Some" ?type**)))))
+ ))))
+ (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))]
+ (fn [state]
+ (return* (&/update$ &/$TYPES #(->> %
+ (&/update$ &/$COUNTER dec)
+ (&/set$ &/$MAPPINGS (&/|remove id mappings*)))
+ state)
+ nil)))
+ state))))
(defn with-var [k]
(|do [id create-var
@@ -275,23 +278,17 @@
_ (delete-var id)]
(return output)))
-;; (def delete-vars
-;; (|do [vars #(->> % (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|keys (return* %))
-;; _ (&/map% delete-var vars)]
-;; (return nil)))
-
(defn with-vars [amount k]
(|do [=vars (&/map% (constantly create-var) (&/|range amount))
output (k (&/|map #(&/V "lux;VarT" %) =vars))
_ (&/map% delete-var (&/|reverse =vars))]
(return output)))
-(defn ^:private clean* [?tid type]
+(defn clean* [?tid type]
(matchv ::M/objects [type]
[["lux;VarT" ?id]]
- (if (= ?tid ?id)
- (&/try-all% (&/|list (deref ?id)
- (fail "##5##")))
+ (if (.equals ^Object ?tid ?id)
+ (deref ?id)
(return type))
[["lux;LambdaT" [?arg ?return]]]
@@ -341,7 +338,6 @@
))
(defn clean [tvar type]
- ;; (prn "^^ clean ^^")
(matchv ::M/objects [tvar]
[["lux;VarT" ?id]]
(clean* ?id type)
@@ -349,8 +345,25 @@
[_]
(fail (str "[Type Error] Not type-var: " (show-type tvar)))))
+(defn ^:private unravel-fun [type]
+ (matchv ::M/objects [type]
+ [["lux;LambdaT" [?in ?out]]]
+ (|let [[??out ?args] (unravel-fun ?out)]
+ (&/T ??out (&/|cons ?in ?args)))
+
+ [_]
+ (&/T type (&/|list))))
+
+(defn ^:private unravel-app [fun-type]
+ (matchv ::M/objects [fun-type]
+ [["lux;AppT" [?left ?right]]]
+ (|let [[?fun-type ?args] (unravel-app ?left)]
+ (&/T ?fun-type (&/|++ ?args (&/|list ?right))))
+
+ [_]
+ (&/T fun-type (&/|list))))
+
(defn show-type [^objects type]
- ;; (prn 'show-type (aget type 0))
(matchv ::M/objects [type]
[["lux;DataT" name]]
(str "(^ " name ")")
@@ -361,16 +374,18 @@
(str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
[["lux;VariantT" cases]]
- (str "(| " (->> cases
- (&/|map (fn [kv]
- (matchv ::M/objects [kv]
- [[k ["Tuple" ["Nil" _]]]]
- (str "#" k)
-
- [[k v]]
- (str "(#" k " " (show-type v) ")"))))
- (&/|interpose " ")
- (&/fold str "")) ")")
+ (if (&/|empty? cases)
+ "(|)"
+ (str "(| " (->> cases
+ (&/|map (fn [kv]
+ (matchv ::M/objects [kv]
+ [[k ["lux;TupleT" ["lux;Nil" _]]]]
+ (str "#" k)
+
+ [[k v]]
+ (str "(#" k " " (show-type v) ")"))))
+ (&/|interpose " ")
+ (&/fold str "")) ")"))
[["lux;RecordT" fields]]
@@ -383,89 +398,83 @@
(&/fold str "")) ")")
[["lux;LambdaT" [input output]]]
- (str "(-> " (show-type input) " " (show-type output) ")")
+ (|let [[?out ?ins] (unravel-fun type)]
+ (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")"))
[["lux;VarT" id]]
(str "⌈" id "⌋")
- [["lux;BoundT" name]]
- name
-
[["lux;ExT" ?id]]
(str "⟨" ?id "⟩")
- [["lux;AppT" [?lambda ?param]]]
- (str "(" (show-type ?lambda) " " (show-type ?param) ")")
+ [["lux;BoundT" name]]
+ name
+
+ [["lux;AppT" [_ _]]]
+ (|let [[?call-fun ?call-args] (unravel-app type)]
+ (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
[["lux;AllT" [?env ?name ?arg ?body]]]
- (let [[args body] (loop [args (list ?arg)
- body* ?body]
- (matchv ::M/objects [body*]
- [["lux;AllT" [?env* ?name* ?arg* ?body*]]]
- (recur (cons ?arg* args) ?body*)
-
- [_]
- [args body*]))]
- (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
-
- [_]
- (assert false (prn-str 'show-type (aget type 0) (class (aget type 1))))
+ (if (= "" ?name)
+ (let [[args body] (loop [args (list ?arg)
+ body* ?body]
+ (matchv ::M/objects [body*]
+ [["lux;AllT" [?env* ?name* ?arg* ?body*]]]
+ (recur (cons ?arg* args) ?body*)
+
+ [_]
+ [args body*]))]
+ (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
+ ?name)
))
(defn type= [x y]
- ;; (prn "^^ type= ^^")
- (let [output (matchv ::M/objects [x y]
- [["lux;DataT" xname] ["lux;DataT" yname]]
- (= xname yname)
-
- [["lux;TupleT" xelems] ["lux;TupleT" yelems]]
- (&/fold (fn [old xy]
- (|let [[x* y*] xy]
- (and old
- (type= x* y*))))
- true
- (&/zip2 xelems yelems))
-
- [["lux;VariantT" xcases] ["lux;VariantT" ycases]]
- (and (= (&/|length xcases) (&/|length ycases))
- (&/fold (fn [old case]
- (and old
- (type= (&/|get case xcases) (&/|get case ycases))))
+ (or (clojure.lang.Util/identical x y)
+ (let [output (matchv ::M/objects [x y]
+ [["lux;DataT" xname] ["lux;DataT" yname]]
+ (.equals ^Object xname yname)
+
+ [["lux;TupleT" xelems] ["lux;TupleT" yelems]]
+ (&/fold2 (fn [old x y]
+ (and old (type= x y)))
+ true
+ xelems yelems)
+
+ [["lux;VariantT" xcases] ["lux;VariantT" ycases]]
+ (&/fold2 (fn [old xcase ycase]
+ (|let [[xname xtype] xcase
+ [yname ytype] ycase]
+ (and old (.equals ^Object xname yname) (type= xtype ytype))))
true
- (&/|keys xcases)))
+ xcases ycases)
- [["lux;RecordT" xfields] ["lux;RecordT" yfields]]
- (and (= (&/|length xfields) (&/|length yfields))
- (&/fold (fn [old field]
- (and old
- (type= (&/|get field xfields) (&/|get field yfields))))
+ [["lux;RecordT" xslots] ["lux;RecordT" yslots]]
+ (&/fold2 (fn [old xslot yslot]
+ (|let [[xname xtype] xslot
+ [yname ytype] yslot]
+ (and old (.equals ^Object xname yname) (type= xtype ytype))))
true
- (&/|keys xfields)))
-
- [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]]
- (and (type= xinput yinput)
- (type= xoutput youtput))
-
- [["lux;VarT" xid] ["lux;VarT" yid]]
- (= xid yid)
-
- [["lux;BoundT" xname] ["lux;BoundT" yname]]
- (= xname yname)
-
- [["lux;ExT" xid] ["lux;ExT" yid]]
- (= xid yid)
-
- [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]]
- (and (type= xlambda ylambda)
- (type= xparam yparam))
-
- [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]]
- (do ;; (prn 'TESTING_ALLT
- ;; 'NAME [xname yname] (= xname yname)
- ;; 'ARG (= xarg yarg)
- ;; 'LENGTH [(&/|length xenv) (&/|length yenv)] (= (&/|length xenv) (&/|length yenv)))
- (and (= xname yname)
- (= xarg yarg)
+ xslots yslots)
+
+ [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]]
+ (and (type= xinput yinput)
+ (type= xoutput youtput))
+
+ [["lux;VarT" xid] ["lux;VarT" yid]]
+ (.equals ^Object xid yid)
+
+ [["lux;BoundT" xname] ["lux;BoundT" yname]]
+ (.equals ^Object xname yname)
+
+ [["lux;ExT" xid] ["lux;ExT" yid]]
+ (.equals ^Object xid yid)
+
+ [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]]
+ (and (type= xlambda ylambda) (type= xparam yparam))
+
+ [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]]
+ (and (.equals ^Object xname yname)
+ (.equals ^Object xarg yarg)
;; (matchv ::M/objects [xenv yenv]
;; [["lux;None" _] ["lux;None" _]]
;; true
@@ -480,14 +489,12 @@
;; [_ _]
;; false)
(type= xbody ybody)
- ))
+ )
- [_ _]
- (do ;; (prn 'type= (show-type x) (show-type y))
- false)
- )]
- ;; (prn 'type= output (show-type x) (show-type y))
- output))
+ [_ _]
+ false
+ )]
+ output)))
(defn ^:private fp-get [k fixpoints]
(|let [[e a] k]
@@ -506,10 +513,11 @@
(&/|cons (&/T k v) fixpoints))
(defn ^:private check-error [expected actual]
- (str "Type " (show-type expected) " does not subsume type " (show-type actual)))
+ (str "[Type Checker]\nExpected: " (show-type expected)
+ "\n\nActual: " (show-type actual)
+ "\n"))
(defn beta-reduce [env type]
- ;; (prn 'beta-reduce (aget type 0))
(matchv ::M/objects [type]
[["lux;VariantT" ?cases]]
(&/V "lux;VariantT" (&/|map (fn [kv]
@@ -559,11 +567,9 @@
(return* state type))))
(defn apply-type [type-fn param]
- ;; (prn 'apply-type (aget type-fn 0) (aget param 0))
(matchv ::M/objects [type-fn]
[["lux;AllT" [local-env local-name local-arg local-def]]]
- (let [;; _ (prn 'apply-type/local-env (aget local-env 0) (show-type type-fn))
- local-env* (matchv ::M/objects [local-env]
+ (let [local-env* (matchv ::M/objects [local-env]
[["lux;None" _]]
(&/|table)
@@ -579,261 +585,257 @@
(apply-type type-fn* param))
[_]
- (fail (str "[Type System] Can't apply type function " (show-type type-fn) " to type " (show-type param)))))
-
-(def init-fixpoints (&/|list))
-
-(defn ^:private check* [fixpoints expected actual]
- ;; (prn "^^ check* ^^")
- ;; (prn 'check* (aget expected 0) (aget actual 0))
- ;; (prn 'check* (show-type expected) (show-type actual))
- (matchv ::M/objects [expected actual]
- [["lux;VarT" ?eid] ["lux;VarT" ?aid]]
- (if (= ?eid ?aid)
- (return (&/T fixpoints nil))
- (|do [ebound (&/try-all% (&/|list (|do [ebound (&/try-all% (&/|list (deref ?eid)
- (fail "##4##")))]
- (return (&/V "lux;Some" ebound)))
- (return (&/V "lux;None" nil))))
- abound (&/try-all% (&/|list (|do [abound (&/try-all% (&/|list (deref ?aid)
- (fail "##3##")))]
- (return (&/V "lux;Some" abound)))
- (return (&/V "lux;None" nil))))]
- (matchv ::M/objects [ebound abound]
- [["lux;None" _] ["lux;None" _]]
- ;; (|do [_ (set-var ?aid expected)]
- ;; (return (&/T fixpoints nil)))
- (|do [_ (set-var ?eid actual)]
- (return (&/T fixpoints nil)))
-
- [["lux;Some" etype] ["lux;None" _]]
- (check* fixpoints etype actual)
-
- [["lux;None" _] ["lux;Some" atype]]
- (check* fixpoints expected atype)
-
- [["lux;Some" etype] ["lux;Some" atype]]
- (check* fixpoints etype atype)))
- )
-
- [["lux;VarT" ?id] _]
- (&/try-all% (&/|list (|do [_ (set-var ?id actual)]
- (return (&/T fixpoints nil)))
- (|do [bound (&/try-all% (&/|list (deref ?id)
- (fail "##1##")))]
- (check* fixpoints bound actual))))
-
- [_ ["lux;VarT" ?id]]
- (&/try-all% (&/|list (|do [_ (set-var ?id expected)]
- (return (&/T fixpoints nil)))
- (|do [bound (&/try-all% (&/|list (deref ?id)
- (fail "##2##")))]
- (check* fixpoints expected bound))))
-
- [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]]
- (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid))
- _ (check* fixpoints A1 A2)]
- (return (&/T fixpoints nil)))
-
- ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
- ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2)
- ;; [fixpoints** _] (check* fixpoints* A1 A2)]
- ;; (return (&/T fixpoints** nil)))
- [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
- (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2)
- e* (apply-type F2 A1)
- a* (apply-type F2 A2)
- [fixpoints** _] (check* fixpoints* e* a*)]
- (return (&/T fixpoints** nil)))
-
- ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]]
- ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id))
- ;; [fixpoints** _] (check* fixpoints* A1 A2)]
- ;; (return (&/T fixpoints** nil)))
- [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]]
- (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id))
- e* (apply-type F1 A1)
- a* (apply-type F1 A2)
- [fixpoints** _] (check* fixpoints* e* a*)]
- (return (&/T fixpoints** nil)))
-
- ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [F2 A2]]]
- ;; (|do [[fixpoints* _] (check* (fp-put fp-pair true fixpoints) F1 F2)
- ;; [fixpoints** _] (check* fixpoints* A1 A2)]
- ;; (return (&/T fixpoints** nil)))
-
- [["lux;AppT" [F A]] _]
- (let [fp-pair (&/T expected actual)
- ;; _ (prn 'LEFT_APP (&/|length fixpoints))
- _ (when (> (&/|length fixpoints) 40)
- (println 'FIXPOINTS (->> (&/|keys fixpoints)
- (&/|map (fn [pair]
- (|let [[e a] pair]
- (str (show-type e) ":+:"
- (show-type a)))))
- (&/|interpose "\n\n")
- (&/fold str "")))
- (assert false))]
- (matchv ::M/objects [(fp-get fp-pair fixpoints)]
- [["lux;Some" ?]]
- (if ?
- (return (&/T fixpoints nil))
- (fail (check-error expected actual)))
-
- [["lux;None" _]]
- (|do [expected* (apply-type F A)]
- (check* (fp-put fp-pair true fixpoints) expected* actual))))
-
- [_ ["lux;AppT" [F A]]]
- (|do [actual* (apply-type F A)]
- (check* fixpoints expected actual*))
- ;; (let [fp-pair (&/T expected actual)
- ;; _ (prn 'RIGHT_APP (&/|length fixpoints))
- ;; _ (when (> (&/|length fixpoints) 10)
- ;; (println 'FIXPOINTS (->> (&/|keys fixpoints)
- ;; (&/|map (fn [pair]
- ;; (|let [[e a] pair]
- ;; (str (show-type e) ":+:"
- ;; (show-type a)))))
- ;; (&/|interpose "\n\n")
- ;; (&/fold str "")))
- ;; (assert false))]
- ;; (matchv ::M/objects [(fp-get fp-pair fixpoints)]
- ;; [["lux;Some" ?]]
- ;; (if ?
- ;; (return (&/T fixpoints nil))
- ;; (fail (check-error expected actual)))
-
- ;; [["lux;None" _]]
- ;; (|do [actual* (apply-type F A)]
- ;; (check* (fp-put fp-pair true fixpoints) expected actual*))))
-
- [["lux;AllT" _] _]
- (with-var
- (fn [$arg]
- (|do [expected* (apply-type expected $arg)]
- (check* fixpoints expected* actual))))
-
- [_ ["lux;AllT" _]]
- (with-var
- (fn [$arg]
- (|do [actual* (apply-type actual $arg)]
- (check* fixpoints expected actual*))))
-
- [["lux;DataT" "boolean"] ["lux;DataT" "java.lang.Boolean"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "byte"] ["lux;DataT" "java.lang.Byte"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "short"] ["lux;DataT" "java.lang.Short"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "int"] ["lux;DataT" "java.lang.Integer"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "long"] ["lux;DataT" "java.lang.Long"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "float"] ["lux;DataT" "java.lang.Float"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "double"] ["lux;DataT" "java.lang.Double"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "char"] ["lux;DataT" "java.lang.Character"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "java.lang.Boolean"] ["lux;DataT" "boolean"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "java.lang.Byte"] ["lux;DataT" "byte"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "java.lang.Short"] ["lux;DataT" "short"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "java.lang.Integer"] ["lux;DataT" "int"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "java.lang.Long"] ["lux;DataT" "long"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "java.lang.Float"] ["lux;DataT" "float"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "java.lang.Double"] ["lux;DataT" "double"]]
- (return (&/T fixpoints nil))
-
- [["lux;DataT" "java.lang.Character"] ["lux;DataT" "char"]]
+ (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n"))))
+
+(defn as-obj [class]
+ (case class
+ "boolean" "java.lang.Boolean"
+ "byte" "java.lang.Byte"
+ "short" "java.lang.Short"
+ "int" "java.lang.Integer"
+ "long" "java.lang.Long"
+ "float" "java.lang.Float"
+ "double" "java.lang.Double"
+ "char" "java.lang.Character"
+ ;; else
+ class))
+
+(def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"})
+
+(def ^:private init-fixpoints (&/|list))
+
+(defn ^:private check* [class-loader fixpoints expected actual]
+ (if (clojure.lang.Util/identical expected actual)
(return (&/T fixpoints nil))
+ (matchv ::M/objects [expected actual]
+ [["lux;VarT" ?eid] ["lux;VarT" ?aid]]
+ (if (.equals ^Object ?eid ?aid)
+ (return (&/T fixpoints nil))
+ (|do [ebound (fn [state]
+ (matchv ::M/objects [((deref ?eid) state)]
+ [["lux;Right" [state* ebound]]]
+ (return* state* (&/V "lux;Some" ebound))
+
+ [["lux;Left" _]]
+ (return* state (&/V "lux;None" nil))))
+ abound (fn [state]
+ (matchv ::M/objects [((deref ?aid) state)]
+ [["lux;Right" [state* abound]]]
+ (return* state* (&/V "lux;Some" abound))
+
+ [["lux;Left" _]]
+ (return* state (&/V "lux;None" nil))))]
+ (matchv ::M/objects [ebound abound]
+ [["lux;None" _] ["lux;None" _]]
+ (|do [_ (set-var ?eid actual)]
+ (return (&/T fixpoints nil)))
+
+ [["lux;Some" etype] ["lux;None" _]]
+ (check* class-loader fixpoints etype actual)
+
+ [["lux;None" _] ["lux;Some" atype]]
+ (check* class-loader fixpoints expected atype)
+
+ [["lux;Some" etype] ["lux;Some" atype]]
+ (check* class-loader fixpoints etype atype))))
+
+ [["lux;VarT" ?id] _]
+ (fn [state]
+ (matchv ::M/objects [((set-var ?id actual) state)]
+ [["lux;Right" [state* _]]]
+ (return* state* (&/T fixpoints nil))
+
+ [["lux;Left" _]]
+ ((|do [bound (deref ?id)]
+ (check* class-loader fixpoints bound actual))
+ state)))
+
+ [_ ["lux;VarT" ?id]]
+ (fn [state]
+ (matchv ::M/objects [((set-var ?id expected) state)]
+ [["lux;Right" [state* _]]]
+ (return* state* (&/T fixpoints nil))
+
+ [["lux;Left" _]]
+ ((|do [bound (deref ?id)]
+ (check* class-loader fixpoints expected bound))
+ state)))
+
+ [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]]
+ (fn [state]
+ (matchv ::M/objects [((|do [F1 (deref ?eid)]
+ (fn [state]
+ (matchv ::M/objects [((|do [F2 (deref ?aid)]
+ (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2))))
+ state)]
+ [["lux;Right" [state* output]]]
+ (return* state* output)
+
+ [["lux;Left" _]]
+ ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)
+ state))))
+ state)]
+ [["lux;Right" [state* output]]]
+ (return* state* output)
+
+ [["lux;Left" _]]
+ (matchv ::M/objects [((|do [F2 (deref ?aid)]
+ (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2))))
+ state)]
+ [["lux;Right" [state* output]]]
+ (return* state* output)
+
+ [["lux;Left" _]]
+ ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid))
+ [fixpoints** _] (check* class-loader fixpoints* A1 A2)]
+ (return (&/T fixpoints** nil)))
+ state))))
+ ;; (|do [_ (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid))
+ ;; _ (check* class-loader fixpoints A1 A2)]
+ ;; (return (&/T fixpoints nil)))
+
+ [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
+ (fn [state]
+ (matchv ::M/objects [((|do [F1 (deref ?id)]
+ (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual))
+ state)]
+ [["lux;Right" [state* output]]]
+ (return* state* output)
+
+ [["lux;Left" _]]
+ ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2)
+ e* (apply-type F2 A1)
+ a* (apply-type F2 A2)
+ [fixpoints** _] (check* class-loader fixpoints* e* a*)]
+ (return (&/T fixpoints** nil)))
+ state)))
+ ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
+ ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2)
+ ;; e* (apply-type F2 A1)
+ ;; a* (apply-type F2 A2)
+ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)]
+ ;; (return (&/T fixpoints** nil)))
+
+ [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]]
+ (fn [state]
+ (matchv ::M/objects [((|do [F2 (deref ?id)]
+ (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2))))
+ state)]
+ [["lux;Right" [state* output]]]
+ (return* state* output)
+
+ [["lux;Left" _]]
+ ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id))
+ e* (apply-type F1 A1)
+ a* (apply-type F1 A2)
+ [fixpoints** _] (check* class-loader fixpoints* e* a*)]
+ (return (&/T fixpoints** nil)))
+ state)))
+ ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]]
+ ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id))
+ ;; e* (apply-type F1 A1)
+ ;; a* (apply-type F1 A2)
+ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)]
+ ;; (return (&/T fixpoints** nil)))
+
+ [["lux;AppT" [F A]] _]
+ (let [fp-pair (&/T expected actual)
+ _ (when (> (&/|length fixpoints) 40)
+ (println 'FIXPOINTS (->> (&/|keys fixpoints)
+ (&/|map (fn [pair]
+ (|let [[e a] pair]
+ (str (show-type e) ":+:"
+ (show-type a)))))
+ (&/|interpose "\n\n")
+ (&/fold str "")))
+ (assert false))]
+ (matchv ::M/objects [(fp-get fp-pair fixpoints)]
+ [["lux;Some" ?]]
+ (if ?
+ (return (&/T fixpoints nil))
+ (fail (check-error expected actual)))
- [["lux;DataT" e!name] ["lux;DataT" a!name]]
- (if (or (= e!name a!name)
- (.isAssignableFrom (Class/forName e!name) (Class/forName a!name)))
- (return (&/T fixpoints nil))
- (fail (str "[Type Error] Names don't match: " e!name " & " a!name)))
-
- [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]]
- (|do [[fixpoints* _] (check* fixpoints aI eI)]
- (check* fixpoints* eO aO))
-
- [["lux;TupleT" e!members] ["lux;TupleT" a!members]]
- (if (= (&/|length e!members) (&/|length a!members))
- (|do [fixpoints* (&/fold% (fn [fixp ea]
- (|let [[e a] ea]
- (do ;; (prn "lux;TupleT" 'ITER (show-type e) (show-type a))
- (|do [[fixp* _] (check* fixp e a)]
- (return fixp*)))))
- fixpoints
- (&/zip2 e!members a!members))
- ;; :let [_ (prn "lux;TupleT" 'DONE)]
- ]
+ [["lux;None" _]]
+ (|do [expected* (apply-type F A)]
+ (check* class-loader (fp-put fp-pair true fixpoints) expected* actual))))
+
+ [_ ["lux;AppT" [F A]]]
+ (|do [actual* (apply-type F A)]
+ (check* class-loader fixpoints expected actual*))
+
+ [["lux;AllT" _] _]
+ (with-var
+ (fn [$arg]
+ (|do [expected* (apply-type expected $arg)]
+ (check* class-loader fixpoints expected* actual))))
+
+ [_ ["lux;AllT" _]]
+ (with-var
+ (fn [$arg]
+ (|do [actual* (apply-type actual $arg)]
+ (check* class-loader fixpoints expected actual*))))
+
+ [["lux;DataT" e!name] ["lux;DataT" "null"]]
+ (if (contains? primitive-types e!name)
+ (fail (str "[Type Error] Can't use \"null\" with primitive types."))
+ (return (&/T fixpoints nil)))
+
+ [["lux;DataT" e!name] ["lux;DataT" a!name]]
+ (let [e!name (as-obj e!name)
+ a!name (as-obj a!name)]
+ (if (or (.equals ^Object e!name a!name)
+ (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)))
+ (return (&/T fixpoints nil))
+ (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))
+
+ [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]]
+ (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)]
+ (check* class-loader fixpoints* eO aO))
+
+ [["lux;TupleT" e!members] ["lux;TupleT" a!members]]
+ (|do [fixpoints* (&/fold2% (fn [fp e a]
+ (|do [[fp* _] (check* class-loader fp e a)]
+ (return fp*)))
+ fixpoints
+ e!members a!members)]
(return (&/T fixpoints* nil)))
- (fail "[Type Error] Tuples don't match in size."))
-
- [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]]
- (if (= (&/|length e!cases) (&/|length a!cases))
- (|do [fixpoints* (&/fold% (fn [fixp slot]
- ;; (prn 'VARIANT_CASE slot)
- (if-let [e!type (&/|get slot e!cases)]
- (if-let [a!type (&/|get slot a!cases)]
- (|do [[fixp* _] (check* fixp e!type a!type)]
- (return fixp*))
- (fail (check-error expected actual)))
- (fail (check-error expected actual))))
- fixpoints
- (&/|keys e!cases))]
+
+ [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]]
+ (|do [fixpoints* (&/fold2% (fn [fp e!case a!case]
+ (|let [[e!name e!type] e!case
+ [a!name a!type] a!case]
+ (if (.equals ^Object e!name a!name)
+ (|do [[fp* _] (check* class-loader fp e!type a!type)]
+ (return fp*))
+ (fail (check-error expected actual)))))
+ fixpoints
+ e!cases a!cases)]
(return (&/T fixpoints* nil)))
- (fail "[Type Error] Variants don't match in size."))
-
- [["lux;RecordT" e!fields] ["lux;RecordT" a!fields]]
- (if (= (&/|length e!fields) (&/|length a!fields))
- (|do [fixpoints* (&/fold% (fn [fixp slot]
- ;; (prn 'RECORD_FIELD slot)
- (if-let [e!type (&/|get slot e!fields)]
- (if-let [a!type (&/|get slot a!fields)]
- (|do [[fixp* _] (check* fixp e!type a!type)]
- (return fixp*))
- (fail (check-error expected actual)))
- (fail (check-error expected actual))))
- fixpoints
- (&/|keys e!fields))]
+
+ [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]]
+ (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot]
+ (|let [[e!name e!type] e!slot
+ [a!name a!type] a!slot]
+ (if (.equals ^Object e!name a!name)
+ (|do [[fp* _] (check* class-loader fp e!type a!type)]
+ (return fp*))
+ (fail (check-error expected actual)))))
+ fixpoints
+ e!slots a!slots)]
(return (&/T fixpoints* nil)))
- (fail "[Type Error] Records don't match in size."))
- [["lux;ExT" e!id] ["lux;ExT" a!id]]
- (if (= e!id a!id)
- (return (&/T fixpoints nil))
- (check-error expected actual))
+ [["lux;ExT" e!id] ["lux;ExT" a!id]]
+ (if (.equals ^Object e!id a!id)
+ (return (&/T fixpoints nil))
+ (fail (check-error expected actual)))
- [_ _]
- (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual)))
- ))
+ [_ _]
+ (fail (check-error expected actual))
+ )))
(defn check [expected actual]
- ;; (prn "^^ check ^^")
- (|do [_ (check* init-fixpoints expected actual)]
+ (|do [class-loader &/loader
+ _ (check* class-loader init-fixpoints expected actual)]
(return nil)))
(defn apply-lambda [func param]
@@ -850,7 +852,7 @@
(clean $var =return))))
[_]
- (fail (str "[Type System] Can't apply type " (show-type func) " to type " (show-type param)))
+ (fail (str "[Type System] Not a function type:\n" (show-type func) "\n"))
))
(defn actual-type [type]
@@ -859,6 +861,9 @@
(|do [type* (apply-type ?all ?param)]
(actual-type type*))
+ [["lux;VarT" ?id]]
+ (deref ?id)
+
[_]
(return type)
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 19:52:50 +0000