aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorLuxLang2015-10-01 12:50:27 -0400
committerLuxLang2015-10-01 12:50:27 -0400
commit3e2ce4d30fd457205b0d0268d870d47a8d1ec738 (patch)
tree580b42a5024c8767b2f2dd78a77a9911593acb77 /src
parente543739f21e03be7cc0192bf510f350f7065bfa5 (diff)
parent6fcf9690f914e9b8b4f0ab767164bc97aeb12ca4 (diff)
Merge pull request #12 from LuxLang/v0.3
V0.3
Diffstat (limited to '')
-rw-r--r--src/lux.clj37
-rw-r--r--src/lux/analyser.clj903
-rw-r--r--src/lux/analyser/base.clj204
-rw-r--r--src/lux/analyser/case.clj547
-rw-r--r--src/lux/analyser/env.clj46
-rw-r--r--src/lux/analyser/host.clj1069
-rw-r--r--src/lux/analyser/lambda.clj54
-rw-r--r--src/lux/analyser/lux.clj778
-rw-r--r--src/lux/analyser/module.clj332
-rw-r--r--src/lux/analyser/record.clj43
-rw-r--r--src/lux/base.clj772
-rw-r--r--src/lux/compiler.clj783
-rw-r--r--src/lux/compiler/base.clj79
-rw-r--r--src/lux/compiler/cache.clj175
-rw-r--r--src/lux/compiler/case.clj64
-rw-r--r--src/lux/compiler/host.clj472
-rw-r--r--src/lux/compiler/io.clj29
-rw-r--r--src/lux/compiler/lambda.clj93
-rw-r--r--src/lux/compiler/lux.clj195
-rw-r--r--src/lux/compiler/module.clj25
-rw-r--r--src/lux/compiler/package.clj61
-rw-r--r--src/lux/compiler/type.clj133
-rw-r--r--src/lux/host.clj251
-rw-r--r--src/lux/lexer.clj92
-rw-r--r--src/lux/lib/loader.clj60
-rw-r--r--src/lux/optimizer.clj15
-rw-r--r--src/lux/packager/lib.clj41
-rw-r--r--src/lux/packager/program.clj99
-rw-r--r--src/lux/parser.clj108
-rw-r--r--src/lux/reader.clj147
-rw-r--r--src/lux/type.clj1043
-rw-r--r--src/lux/type/host.clj220
32 files changed, 5390 insertions, 3580 deletions
diff --git a/src/lux.clj b/src/lux.clj
index 7e3627cd7..4b1c15ef7 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -1,24 +1,33 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux
(:gen-class)
- (:require [lux.base :as &]
+ (:require [lux.base :as & :refer [|let |do return fail return* fail* |case]]
+ [lux.compiler.base :as &compiler-base]
[lux.compiler :as &compiler]
- :reload-all))
+ [lux.packager.lib :as &lib]
+ :reload-all)
+ (:import (java.io File)))
-(defn -main [& [program-module & _]]
- (if program-module
- (time (&compiler/compile-program program-module))
- (println "Please provide a module name to compile."))
+(defn -main [& args]
+ (|case (&/->list args)
+ (&/$Cons "compile" (&/$Cons program-module (&/$Nil)))
+ (if program-module
+ (time (&compiler/compile-program program-module))
+ (println "Please provide a module name to compile."))
+
+ (&/$Cons "lib" (&/$Cons lib-module (&/$Nil)))
+ (&lib/package lib-module (new File &compiler-base/input-dir))
+
+ _
+ (println "Can't understand command."))
(System/exit 0)
)
(comment
- (-main "program")
+ (-main "compile" "program")
+ (-main "lib" "lux")
)
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index de7fc8497..70a4a6ee9 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -1,490 +1,652 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.analyser
(:require (clojure [template :refer [do-template]])
- [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|let |do return fail return* fail*]]
+ (lux [base :as & :refer [|let |do return fail return* fail* |case]]
[reader :as &reader]
[parser :as &parser]
[type :as &type]
[host :as &host])
(lux.analyser [base :as &&]
[lux :as &&lux]
- [host :as &&host])))
+ [host :as &&host]
+ [module :as &&module])))
;; [Utils]
(defn ^:private parse-handler [[catch+ finally+] token]
- (matchv ::M/objects [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]
+ (|case token
+ [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")]
+ (&/$Cons [_ (&/$TextS ?ex-class)]
+ (&/$Cons [_ (&/$SymbolS "" ?ex-arg)]
+ (&/$Cons ?catch-body
+ (&/$Nil))))))]
+ (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+))
+
+ [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")]
+ (&/$Cons ?finally-body
+ (&/$Nil))))]
+ (return (&/T catch+ (&/V &/$Some ?finally-body)))
+
+ _
+ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token)))))
+
+(defn ^:private parse-tag [ast]
+ (|case ast
+ [_ (&/$TagS "" name)]
+ (return name)
+
+ _
+ (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast)))))
+
+(defn ^:private extract-text [ast]
+ (|case ast
+ [_ (&/$TextS text)]
+ (return text)
+
+ _
+ (fail (str "[Analyser Error] Can't extract text: " (&/show-ast ast)))))
+
+(defn analyse-variant+ [analyser exo-type ident values]
+ (|do [[module tag-name] (&/normalize ident)
+ idx (&&module/tag-index module tag-name)]
+ (|case exo-type
+ (&/$VarT id)
+ (|do [? (&type/bound? id)]
+ (if (or ? (&&/type-tag? module tag-name))
+ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values)
+ (|do [wanted-type (&&module/tag-type module tag-name)
+ [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values))
+ _ (&type/check exo-type variant-type)]
+ (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis))))))
+
+ _
+ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values)
+ )))
+
+(defn ^:private aba10 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
+ ;; Arrays
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil))))
+ (&&host/analyse-jvm-znewarray analyse exo-type ?length)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
+ (&&host/analyse-jvm-zastore analyse exo-type ?array ?idx ?elem)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))
+ (&&host/analyse-jvm-zaload analyse exo-type ?array ?idx)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil)))))
+ (&&host/analyse-jvm-bnewarray analyse exo-type ?length)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
+ (&&host/analyse-jvm-bastore analyse exo-type ?array ?idx ?elem)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))
+ (&&host/analyse-jvm-baload analyse exo-type ?array ?idx)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil)))))
+ (&&host/analyse-jvm-snewarray analyse exo-type ?length)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
+ (&&host/analyse-jvm-sastore analyse exo-type ?array ?idx ?elem)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))
+ (&&host/analyse-jvm-saload analyse exo-type ?array ?idx)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil)))))
+ (&&host/analyse-jvm-inewarray analyse exo-type ?length)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
+ (&&host/analyse-jvm-iastore analyse exo-type ?array ?idx ?elem)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))
+ (&&host/analyse-jvm-iaload analyse exo-type ?array ?idx)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil)))))
+ (&&host/analyse-jvm-lnewarray analyse exo-type ?length)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
+ (&&host/analyse-jvm-lastore analyse exo-type ?array ?idx ?elem)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))
+ (&&host/analyse-jvm-laload analyse exo-type ?array ?idx)
+
+ _
+ (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&/T (&/T "" -1 -1) token)))))))
+
+(defn ^:private aba9 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
;; 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;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;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)
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil)))))
+ (&&host/analyse-jvm-fnewarray analyse exo-type ?length)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
+ (&&host/analyse-jvm-fastore analyse exo-type ?array ?idx ?elem)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))
+ (&&host/analyse-jvm-faload analyse exo-type ?array ?idx)
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil)))))
+ (&&host/analyse-jvm-dnewarray analyse exo-type ?length)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
+ (&&host/analyse-jvm-dastore analyse exo-type ?array ?idx ?elem)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))
+ (&&host/analyse-jvm-daload analyse exo-type ?array ?idx)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil)))))
+ (&&host/analyse-jvm-cnewarray analyse exo-type ?length)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
+ (&&host/analyse-jvm-castore analyse exo-type ?array ?idx ?elem)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))
+ (&&host/analyse-jvm-caload analyse exo-type ?array ?idx)
+
+ _
+ (aba10 analyse eval! compile-module compile-token exo-type token)))
+
+(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
+ ;; Arrays
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil)))))
+ (&&host/analyse-jvm-anewarray analyse exo-type ?class ?length)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
+ (&&host/analyse-jvm-aastore analyse exo-type ?array ?idx ?elem)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))
+ (&&host/analyse-jvm-aaload analyse exo-type ?array ?idx)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil))))
+ (&&host/analyse-jvm-arraylength analyse exo-type ?array)
+
+ _
+ (aba9 analyse eval! compile-module compile-token exo-type token)))
+
+(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
;; 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)
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")]
+ (&/$Cons [_ (&/$TextS ?name)]
+ (&/$Cons [_ (&/$TextS ?super-class)]
+ (&/$Cons [_ (&/$TupleS ?interfaces)]
+ (&/$Cons [_ (&/$TupleS ?anns)]
+ (&/$Cons [_ (&/$TupleS ?fields)]
+ (&/$Cons [_ (&/$TupleS ?methods)]
+ (&/$Nil)))))))))
+ (|do [=interfaces (&/map% extract-text ?interfaces)]
+ (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?anns ?fields ?methods))
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")]
+ (&/$Cons [_ (&/$TextS ?name)]
+ (&/$Cons [_ (&/$TupleS ?supers)]
+ (&/$Cons [_ (&/$TupleS ?anns)]
+ ?methods)))))
+ (|do [=supers (&/map% extract-text ?supers)]
+ (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?anns ?methods))
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")]
+ (&/$Cons [_ (&/$TextS ?super-class)]
+ (&/$Cons [_ (&/$TupleS ?interfaces)]
+ (&/$Cons [_ (&/$TupleS ?methods)]
+ (&/$Nil))))))
+ (|do [=interfaces (&/map% extract-text ?interfaces)]
+ (&&host/analyse-jvm-anon-class analyse compile-token exo-type ?super-class =interfaces ?methods))
;; 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)
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")]
+ (&/$Cons [_ (&/$SymbolS "" ?args)]
+ (&/$Cons ?body
+ (&/$Nil)))))
+ (&&host/analyse-jvm-program analyse compile-token ?args ?body)
- [_]
- (fail "")))
+ _
+ (aba8 analyse eval! compile-module compile-token exo-type token)))
+
+(defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
+ ;; Bitwise operators
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-iand analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-ior analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-ixor analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-ishl analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-ishr analyse exo-type ?x ?y)
-(defn ^:private aba6 [analyse eval! compile-module exo-type token]
- (matchv ::M/objects [token]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-iushr analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-land analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-lor analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-lxor analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-lshl analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-lshr analyse exo-type ?x ?y)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&&host/analyse-jvm-lushr analyse exo-type ?x ?y)
+
+ _
+ (aba7 analyse eval! compile-module compile-token exo-type token)))
+
+(defn ^:private aba5_5 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
;; Primitive conversions
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-d2f analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-d2i analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-d2l analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-f2d analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-f2i analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-f2l analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2b analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2c analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2d analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2f analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2l analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2s analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-l2d analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-l2f analyse exo-type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-l2i analyse exo-type ?value)
- ;; 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;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;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;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;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)
+ _
+ (aba6 analyse eval! compile-module compile-token exo-type token)))
- [["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;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;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)))
-
-(defn ^:private aba5 [analyse eval! compile-module exo-type token]
- (matchv ::M/objects [token]
+(defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
;; Objects
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]]
- ["lux;Cons" [?object
- ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")]
+ (&/$Cons ?object
+ (&/$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" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons ?object
+ (&/$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" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
+ (&/$Cons [_ (&/$TupleS ?args)]
+ (&/$Nil))))))
+ (|do [=classes (&/map% extract-text ?classes)]
+ (&&host/analyse-jvm-new analyse exo-type ?class =classes ?args))
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?field)]
+ (&/$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" _]]]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?field)]
+ (&/$Cons ?object
+ (&/$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" _]]]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?field)]
+ (&/$Cons ?value
+ (&/$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)
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?field)]
+ (&/$Cons ?value
+ (&/$Cons ?object
+ (&/$Nil)))))))
+ (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?value ?object)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?method)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
+ (&/$Cons [_ (&/$TupleS ?args)]
+ (&/$Nil)))))))
+ (|do [=classes (&/map% extract-text ?classes)]
+ (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method =classes ?args))
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?method)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
+ (&/$Cons ?object
+ (&/$Cons [_ (&/$TupleS ?args)]
+ (&/$Nil))))))))
+ (|do [=classes (&/map% extract-text ?classes)]
+ (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method =classes ?object ?args))
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?method)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
+ (&/$Cons ?object
+ (&/$Cons [_ (&/$TupleS ?args)]
+ (&/$Nil))))))))
+ (|do [=classes (&/map% extract-text ?classes)]
+ (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method =classes ?object ?args))
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?method)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
+ (&/$Cons ?object
+ (&/$Cons [_ (&/$TupleS ?args)]
+ (&/$Nil))))))))
+ (|do [=classes (&/map% extract-text ?classes)]
+ (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method =classes ?object ?args))
;; 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;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]]
- ["lux;Cons" [?ex
- ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")]
+ (&/$Cons ?body
+ ?handlers)))
+ (|do [catches+finally (&/fold% parse-handler (&/T &/Nil$ &/None$) ?handlers)]
+ (&&host/analyse-jvm-try analyse exo-type ?body catches+finally))
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")]
+ (&/$Cons ?ex
+ (&/$Nil))))
(&&host/analyse-jvm-throw analyse exo-type ?ex)
;; Syncronization/monitos
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]]
- ["lux;Cons" [?monitor
- ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")]
+ (&/$Cons ?monitor
+ (&/$Nil))))
(&&host/analyse-jvm-monitorenter analyse exo-type ?monitor)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]]
- ["lux;Cons" [?monitor
- ["lux;Nil" _]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")]
+ (&/$Cons ?monitor
+ (&/$Nil))))
(&&host/analyse-jvm-monitorexit analyse exo-type ?monitor)
- [_]
- (aba6 analyse eval! compile-module exo-type token)))
+ _
+ (aba5_5 analyse eval! compile-module compile-token exo-type token)))
-(defn ^:private aba4 [analyse eval! compile-module exo-type token]
- (matchv ::M/objects [token]
+(defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
;; Float arithmetic
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fadd analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fsub analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fmul analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fdiv analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-frem analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-feq analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-flt analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fgt analyse exo-type ?x ?y)
;; Double arithmetic
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-dadd analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-dsub analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-dmul analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ddiv analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-drem analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-deq analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-dlt analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-dgt analyse exo-type ?x ?y)
+
+ _
+ (aba5 analyse eval! compile-module compile-token exo-type token)))
- [_]
- (aba5 analyse eval! compile-module exo-type token)))
-
-(defn ^:private aba3 [analyse eval! compile-module exo-type token]
- (matchv ::M/objects [token]
+(defn ^:private aba3 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
;; Host special forms
;; Characters
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ceq analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-clt analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$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" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-iadd analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-isub analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-imul analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-idiv analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-irem analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ieq analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ilt analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-igt analyse exo-type ?x ?y)
;; Long arithmetic
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ladd analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lsub analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lmul analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ldiv analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lrem analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-leq analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-llt analyse exo-type ?x ?y)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lgt analyse exo-type ?x ?y)
- [_]
- (aba4 analyse eval! compile-module exo-type token)))
+ _
+ (aba4 analyse eval! compile-module compile-token exo-type token)))
-(defn ^:private aba2 [analyse eval! compile-module exo-type token]
- (matchv ::M/objects [token]
- [["lux;SymbolS" ?ident]]
+(defn ^:private aba2 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
+ (&/$SymbolS ?ident)
(&&lux/analyse-symbol analyse exo-type ?ident)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]]
- ["lux;Cons" [?value ?branches]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")]
+ (&/$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" _]]]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")]
+ (&/$Cons [_ (&/$SymbolS "" ?self)]
+ (&/$Cons [_ (&/$SymbolS "" ?arg)]
+ (&/$Cons ?body
+ (&/$Nil))))))
(&&lux/analyse-lambda analyse exo-type ?self ?arg ?body)
- [["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)
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")]
+ (&/$Cons [_ (&/$SymbolS "" ?name)]
+ (&/$Cons ?value
+ (&/$Nil)))))
+ (&&lux/analyse-def analyse compile-token ?name ?value)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")]
+ (&/$Cons [_ (&/$SymbolS "" ?name)]
+ (&/$Nil))))
+ (&&lux/analyse-declare-macro analyse compile-token ?name)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")]
+ (&/$Cons [_ (&/$TupleS tags)]
+ (&/$Cons [_ (&/$SymbolS "" type-name)]
+ (&/$Nil)))))
+ (|do [tags* (&/map% parse-tag tags)]
+ (&&lux/analyse-declare-tags tags* type-name))
- [["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;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;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]]
- ["lux;Cons" [?type
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")]
+ (&/$Cons [_ (&/$TextS ?path)]
+ (&/$Nil))))
+ (&&lux/analyse-import analyse compile-module compile-token ?path)
+
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")]
+ (&/$Cons ?type
+ (&/$Cons ?value
+ (&/$Nil)))))
(&&lux/analyse-check analyse eval! exo-type ?type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]]
- ["lux;Cons" [?type
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]]]
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")]
+ (&/$Cons ?type
+ (&/$Cons ?value
+ (&/$Nil)))))
(&&lux/analyse-coerce analyse eval! exo-type ?type ?value)
- [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]]
- ["lux;Nil" _]]]]]]]
- (&&lux/analyse-export analyse ?ident)
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")]
+ (&/$Cons [_ (&/$SymbolS "" ?ident)]
+ (&/$Nil))))
+ (&&lux/analyse-export analyse compile-token ?ident)
- [["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)
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")]
+ (&/$Cons [_ (&/$TextS ?alias)]
+ (&/$Cons [_ (&/$TextS ?module)]
+ (&/$Nil)))))
+ (&&lux/analyse-alias analyse compile-token ?alias ?module)
- [_]
- (aba3 analyse eval! compile-module exo-type token)))
-
-(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))))
-
- [["lux;IntS" ?value]]
- (|do [_ (&type/check exo-type &type/Int)]
- (return (&/|list (&/T (&/V "int" ?value) exo-type))))
-
- [["lux;RealS" ?value]]
- (|do [_ (&type/check exo-type &type/Real)]
- (return (&/|list (&/T (&/V "real" ?value) exo-type))))
-
- [["lux;CharS" ?value]]
- (|do [_ (&type/check exo-type &type/Char)]
- (return (&/|list (&/T (&/V "char" ?value) exo-type))))
-
- [["lux;TextS" ?value]]
- (|do [_ (&type/check exo-type &type/Text)]
- (return (&/|list (&/T (&/V "text" ?value) exo-type))))
-
- [["lux;TupleS" ?elems]]
- (&&lux/analyse-tuple analyse exo-type ?elems)
-
- [["lux;RecordS" ?elems]]
- (&&lux/analyse-record analyse exo-type ?elems)
-
- [["lux;TagS" ?ident]]
- (&&lux/analyse-variant analyse exo-type ?ident unit)
-
- [["lux;SymbolS" [_ "_jvm_null"]]]
- (&&host/analyse-jvm-null analyse exo-type)
-
- [_]
- (aba2 analyse eval! compile-module exo-type token)
- )))
+ _
+ (aba3 analyse eval! compile-module compile-token exo-type token)))
+
+(defn ^:private aba1 [analyse eval! compile-module compile-token exo-type token]
+ (|case token
+ ;; Standard special forms
+ (&/$BoolS ?value)
+ (|do [_ (&type/check exo-type &type/Bool)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$bool ?value)))))
+
+ (&/$IntS ?value)
+ (|do [_ (&type/check exo-type &type/Int)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$int ?value)))))
+
+ (&/$RealS ?value)
+ (|do [_ (&type/check exo-type &type/Real)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$real ?value)))))
+
+ (&/$CharS ?value)
+ (|do [_ (&type/check exo-type &type/Char)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$char ?value)))))
+
+ (&/$TextS ?value)
+ (|do [_ (&type/check exo-type &type/Text)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$text ?value)))))
+
+ (&/$TupleS ?elems)
+ (&&lux/analyse-tuple analyse (&/V &/$Right exo-type) ?elems)
+
+ (&/$RecordS ?elems)
+ (&&lux/analyse-record analyse exo-type ?elems)
+
+ (&/$TagS ?ident)
+ (analyse-variant+ analyse exo-type ?ident &/Nil$)
+
+ (&/$SymbolS _ "_jvm_null")
+ (&&host/analyse-jvm-null analyse exo-type)
+
+ _
+ (aba2 analyse eval! compile-module compile-token exo-type token)
+ ))
(defn ^:private add-loc [meta ^String msg]
(if (.startsWith msg "@")
@@ -492,63 +654,74 @@
(|let [[file line col] meta]
(str "@ " file "," line "," col "\n" msg))))
-(defn ^:private analyse-basic-ast [analyse eval! compile-module exo-type token]
+(defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token]
;; (prn 'analyse-basic-ast (&/show-ast token))
- (matchv ::M/objects [token]
- [["lux;Meta" [meta ?token]]]
+ (|case token
+ [meta ?token]
(fn [state]
- (matchv ::M/objects [((aba1 analyse eval! compile-module exo-type ?token) state)]
- [["lux;Right" [state* output]]]
+ (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state)
+ (catch Error e
+ (prn 'analyse-basic-ast/Error-1 e)
+ (prn 'analyse-basic-ast/Error-2 (&/show-ast token))
+ (prn 'analyse-basic-ast/Error-3 (&type/show-type exo-type))
+ (|case ((&type/deref+ exo-type) state)
+ (&/$Right [_state _exo-type])
+ (prn 'analyse-basic-ast/Error-4 (&type/show-type _exo-type))
+
+ _
+ (prn 'analyse-basic-ast/Error-4 'YOLO))
+ (throw e))
+ )
+ (&/$Right state* output)
(return* state* output)
- [["lux;Left" ""]]
- (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token))))
+ (&/$Left "")
+ (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token))))
- [["lux;Left" msg]]
- (fail* (add-loc meta msg))
+ (&/$Left msg)
+ (fail* (add-loc (&/get$ &/$cursor state) msg))
))
-
- ;; [_]
- ;; (assert false (aget token 0))
))
-(defn ^:private just-analyse [analyse-ast eval! compile-module syntax]
+(defn ^:private just-analyse [analyser 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]]
+ (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)]
+ (|case [?var ?output-type]
+ [(&/$VarT ?e-id) (&/$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 (&&/|meta ?output-type* ?output-cursor ?output-term)))
+ (return (&&/|meta ?output-type ?output-cursor ?output-term)))
[_ _]
- (return (&/T ?output-term ?output-type)))
+ (return (&&/|meta ?output-type ?output-cursor ?output-term)))
))))
-(defn ^:private analyse-ast [eval! compile-module exo-type token]
- (matchv ::M/objects [token]
- [["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;FormS" ["lux;Cons" [?fn ?args]]]]]]
- (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]]]
- (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*))
-
- [_]
- ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state)))
-
- [_]
- (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token)))
+(defn ^:private analyse-ast [eval! compile-module compile-token exo-type token]
+ (|let [[cursor _] token]
+ (&/with-cursor cursor
+ (&/with-expected-type exo-type
+ (|case token
+ [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))]
+ (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/V &/$Right exo-type) idx ?values)
+
+ [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))]
+ (analyse-variant+ (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values)
+
+ [meta (&/$FormS (&/$Cons ?fn ?args))]
+ (fn [state]
+ (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state)
+ (&/$Right state* =fn)
+ ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)
+
+ _
+ ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state)))
+
+ _
+ (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))))
;; [Resources]
-(defn analyse [eval! compile-module]
+(defn analyse [eval! compile-module compile-token]
(|do [asts &parser/parse]
- (&/flat-map% (partial analyse-ast eval! compile-module &type/$Void) asts)))
+ (&/flat-map% (partial analyse-ast eval! compile-module compile-token &type/$Void) asts)))
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 9fc3f1030..664ba4450 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -1,35 +1,193 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.analyser.base
- (:require [clojure.core.match :as M :refer [match matchv]]
+ (:require clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|let |do return fail]]
+ (lux [base :as & :refer [deftags |let |do return fail |case]]
[type :as &type])))
+;; [Tags]
+(deftags
+ ["bool"
+ "int"
+ "real"
+ "char"
+ "text"
+ "variant"
+ "tuple"
+ "apply"
+ "case"
+ "lambda"
+ "ann"
+ "def"
+ "declare-macro"
+ "var"
+ "captured"
+
+ "jvm-getstatic"
+ "jvm-getfield"
+ "jvm-putstatic"
+ "jvm-putfield"
+ "jvm-invokestatic"
+ "jvm-instanceof"
+ "jvm-invokevirtual"
+ "jvm-invokeinterface"
+ "jvm-invokespecial"
+ "jvm-null?"
+ "jvm-null"
+ "jvm-new"
+ "jvm-class"
+ "jvm-interface"
+ "jvm-try"
+ "jvm-throw"
+ "jvm-monitorenter"
+ "jvm-monitorexit"
+ "jvm-program"
+
+
+ "jvm-znewarray"
+ "jvm-zastore"
+ "jvm-zaload"
+ "jvm-bnewarray"
+ "jvm-bastore"
+ "jvm-baload"
+ "jvm-snewarray"
+ "jvm-sastore"
+ "jvm-saload"
+ "jvm-inewarray"
+ "jvm-iastore"
+ "jvm-iaload"
+ "jvm-lnewarray"
+ "jvm-lastore"
+ "jvm-laload"
+ "jvm-fnewarray"
+ "jvm-fastore"
+ "jvm-faload"
+ "jvm-dnewarray"
+ "jvm-dastore"
+ "jvm-daload"
+ "jvm-cnewarray"
+ "jvm-castore"
+ "jvm-caload"
+ "jvm-anewarray"
+ "jvm-aastore"
+ "jvm-aaload"
+ "jvm-arraylength"
+
+ "jvm-iadd"
+ "jvm-isub"
+ "jvm-imul"
+ "jvm-idiv"
+ "jvm-irem"
+ "jvm-ieq"
+ "jvm-ilt"
+ "jvm-igt"
+
+ "jvm-ceq"
+ "jvm-clt"
+ "jvm-cgt"
+
+ "jvm-ladd"
+ "jvm-lsub"
+ "jvm-lmul"
+ "jvm-ldiv"
+ "jvm-lrem"
+ "jvm-leq"
+ "jvm-llt"
+ "jvm-lgt"
+
+ "jvm-fadd"
+ "jvm-fsub"
+ "jvm-fmul"
+ "jvm-fdiv"
+ "jvm-frem"
+ "jvm-feq"
+ "jvm-flt"
+ "jvm-fgt"
+
+ "jvm-dadd"
+ "jvm-dsub"
+ "jvm-dmul"
+ "jvm-ddiv"
+ "jvm-drem"
+ "jvm-deq"
+ "jvm-dlt"
+ "jvm-dgt"
+
+ "jvm-d2f"
+ "jvm-d2i"
+ "jvm-d2l"
+
+ "jvm-f2d"
+ "jvm-f2i"
+ "jvm-f2l"
+
+ "jvm-i2b"
+ "jvm-i2c"
+ "jvm-i2d"
+ "jvm-i2f"
+ "jvm-i2l"
+ "jvm-i2s"
+
+ "jvm-l2d"
+ "jvm-l2f"
+ "jvm-l2i"
+
+ "jvm-iand"
+ "jvm-ior"
+ "jvm-ixor"
+ "jvm-ishl"
+ "jvm-ishr"
+ "jvm-iushr"
+
+ "jvm-land"
+ "jvm-lor"
+ "jvm-lxor"
+ "jvm-lshl"
+ "jvm-lshr"
+ "jvm-lushr"])
+
;; [Exports]
-(defn expr-type [syntax+]
- (matchv ::M/objects [syntax+]
- [[_ type]]
- (return type)))
+(defn expr-type* [syntax+]
+ (|let [[[type _] _] syntax+]
+ type))
-(defn analyse-1 [analyse exo-type elem]
- (|do [output (analyse exo-type elem)]
- (matchv ::M/objects [output]
- [["lux;Cons" [x ["lux;Nil" _]]]]
+(def jvm-this "_jvm_this")
+
+(defn cap-1 [action]
+ (|do [result action]
+ (|case result
+ (&/$Cons x (&/$Nil))
(return x)
- [_]
+ _
(fail "[Analyser Error] Can't expand to other than 1 element."))))
+(defn analyse-1 [analyse exo-type elem]
+ (cap-1 (analyse exo-type elem)))
+
+(defn analyse-1+ [analyse ?token]
+ (&type/with-var
+ (fn [$var]
+ (|do [=expr (analyse-1 analyse $var ?token)
+ :let [[[?type ?cursor] ?item] =expr]
+ =type (&type/clean $var ?type)]
+ (return (&/T (&/T =type ?cursor) ?item))))))
+
(defn resolved-ident [ident]
- (|let [[?module ?name] ident]
- (|do [module* (if (.equals "" ?module)
- &/get-module-name
- (return ?module))]
- (return (&/ident->text (&/T module* ?name))))))
+ (|do [:let [[?module ?name] ident]
+ module* (if (.equals "" ?module)
+ &/get-module-name
+ (return ?module))]
+ (return (&/T module* ?name))))
+
+(let [tag-names #{"DataT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}]
+ (defn type-tag? [module name]
+ (and (= "lux" module)
+ (contains? tag-names name))))
+
+(defn |meta [type cursor analysis]
+ (&/T (&/T type cursor) analysis))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index ebbb6911a..ca4e0edeb 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -1,386 +1,363 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.analyser.case
- (:require [clojure.core.match :as M :refer [match matchv]]
+ (:require clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return fail |let]]
+ (lux [base :as & :refer [deftags |do return fail |let |case]]
[parser :as &parser]
[type :as &type])
(lux.analyser [base :as &&]
- [env :as &env])))
+ [env :as &env]
+ [module :as &module]
+ [record :as &&record])))
+
+;; [Tags]
+(deftags
+ ["DefaultTotal"
+ "BoolTotal"
+ "IntTotal"
+ "RealTotal"
+ "CharTotal"
+ "TextTotal"
+ "TupleTotal"
+ "VariantTotal"]
+ )
+
+(deftags
+ ["StoreTestAC"
+ "BoolTestAC"
+ "IntTestAC"
+ "RealTestAC"
+ "CharTestAC"
+ "TextTestAC"
+ "TupleTestAC"
+ "VariantTestAC"]
+ )
;; [Utils]
+(def ^:private unit
+ (&/T (&/T "" -1 -1) (&/V &/$TupleS &/Nil$)))
+
(defn ^:private resolve-type [type]
- (matchv ::M/objects [type]
- [["lux;VarT" ?id]]
+ (|case type
+ (&/$VarT ?id)
(|do [type* (&/try-all% (&/|list (&type/deref ?id)
(fail "##9##")))]
(resolve-type type*))
- [["lux;AllT" [_aenv _aname _aarg _abody]]]
- ;; (&type/actual-type _abody)
+ (&/$UnivQ _)
(|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 update-up-frame [frame]
+ (|let [[_env _idx _var] frame]
+ (&/T _env (+ 2 _idx) _var)))
+
(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]]]
+ "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))"
+ (|case type
+ (&/$UnivQ _aenv _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]]]
+ (adjust-type* (&/Cons$ (&/T _aenv 1 $var) (&/|map update-up-frame up)) =type))))
+
+ (&/$TupleT ?members)
+ (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena]
+ (|let [[_aenv _aidx (&/$VarT _avar)] ena]
+ (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))]
+ (&type/clean* _avar _abody))))
+ type
+ up)]
+ (return (&type/Tuple$ (&/|map (fn [v]
+ (&/fold (fn [_abody ena]
+ (|let [[_aenv _aidx _avar] ena]
+ (&/V &/$UnivQ (&/T _aenv _abody))))
+ v
+ up))
+ ?members*))))
+
+ (&/$VariantT ?members)
+ (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena]
+ (|let [[_aenv _aidx (&/$VarT _avar)] ena]
+ (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))]
+ (&type/clean* _avar _abody))))
+ type
+ up)]
+ (return (&/V &/$VariantT (&/|map (fn [v]
+ (&/fold (fn [_abody ena]
+ (|let [[_aenv _aidx _avar] ena]
+ (&/V &/$UnivQ (&/T _aenv _abody))))
+ v
+ up))
+ ?members*))))
+
+ (&/$AppT ?tfun ?targ)
(|do [=type (&type/apply-type ?tfun ?targ)]
(adjust-type* up =type))
- [["lux;VarT" ?id]]
+ (&/$VarT ?id)
(|do [type* (&/try-all% (&/|list (&type/deref ?id)
(fail "##9##")))]
(adjust-type* up type*))
- ;; [_]
- ;; (assert false (aget type 0))
+ (&/$NamedT ?name ?type)
+ (adjust-type* up ?type)
+
+ _
+ (assert false (prn-str 'adjust-type* (&type/show-type type)))
))
(defn adjust-type [type]
"(-> Type (Lux Type))"
- (adjust-type* (&/|list) type))
+ (adjust-type* &/Nil$ type))
(defn ^:private analyse-pattern [value-type pattern kont]
- (matchv ::M/objects [pattern]
- [["lux;Meta" [_ pattern*]]]
- (matchv ::M/objects [pattern*]
- [["lux;SymbolS" ?ident]]
- (|do [=kont (&env/with-local (&/ident->text ?ident) value-type
+ (|let [[meta pattern*] pattern]
+ (|case pattern*
+ (&/$SymbolS "" name)
+ (|do [=kont (&env/with-local name value-type
kont)
idx &env/next-local-idx]
- (return (&/T (&/V "StoreTestAC" idx) =kont)))
+ (return (&/T (&/V $StoreTestAC idx) =kont)))
+
+ (&/$SymbolS ident)
+ (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident)))
- [["lux;BoolS" ?value]]
+ (&/$BoolS ?value)
(|do [_ (&type/check value-type &type/Bool)
=kont kont]
- (return (&/T (&/V "BoolTestAC" ?value) =kont)))
+ (return (&/T (&/V $BoolTestAC ?value) =kont)))
- [["lux;IntS" ?value]]
+ (&/$IntS ?value)
(|do [_ (&type/check value-type &type/Int)
=kont kont]
- (return (&/T (&/V "IntTestAC" ?value) =kont)))
+ (return (&/T (&/V $IntTestAC ?value) =kont)))
- [["lux;RealS" ?value]]
+ (&/$RealS ?value)
(|do [_ (&type/check value-type &type/Real)
=kont kont]
- (return (&/T (&/V "RealTestAC" ?value) =kont)))
+ (return (&/T (&/V $RealTestAC ?value) =kont)))
- [["lux;CharS" ?value]]
+ (&/$CharS ?value)
(|do [_ (&type/check value-type &type/Char)
=kont kont]
- (return (&/T (&/V "CharTestAC" ?value) =kont)))
+ (return (&/T (&/V $CharTestAC ?value) =kont)))
- [["lux;TextS" ?value]]
+ (&/$TextS ?value)
(|do [_ (&type/check value-type &type/Text)
=kont kont]
- (return (&/T (&/V "TextTestAC" ?value) =kont)))
+ (return (&/T (&/V $TextTestAC ?value) =kont)))
- [["lux;TupleS" ?members]]
+ (&/$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))))))
+ (|case value-type*
+ (&/$TupleT ?member-types)
+ (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 (&/|table) =kont)))
- (&/|reverse ?slots))]
- (return (&/T (&/V "RecordTestAC" =tests) =kont))))
-
- [_]
- (fail "[Pattern-matching Error] Record requires record-type.")))
-
- [["lux;TagS" ?ident]]
- (|do [=tag (&&/resolved-ident ?ident)
+ (return (&/T &/Nil$ =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*)))))
+
+ (&/$RecordS pairs)
+ (|do [[rec-members rec-type] (&&record/order-record pairs)]
+ (analyse-pattern value-type (&/T meta (&/V &/$TupleS rec-members)) kont))
+
+ (&/$TagS ?ident)
+ (|do [[=module =name] (&&/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)
+ idx (&module/tag-index =module =name)
+ group (&module/tag-group =module =name)
+ case-type (&type/variant-case idx value-type*)
+ [=test =kont] (analyse-pattern case-type unit kont)]
+ (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont)))
+
+ (&/$FormS (&/$Cons [_ (&/$TagS ?ident)]
+ ?values))
+ (|do [[=module =name] (&&/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)))
+ idx (&module/tag-index =module =name)
+ group (&module/tag-group =module =name)
+ case-type (&type/variant-case idx value-type*)
+ [=test =kont] (case (int (&/|length ?values))
+ 0 (analyse-pattern case-type unit kont)
+ 1 (analyse-pattern case-type (&/|head ?values) kont)
+ ;; 1+
+ (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont))]
+ (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont)))
+
+ _
+ (fail (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern)))
)))
(defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns]
(|do [pattern+body (analyse-pattern value-type pattern
(&&/analyse-1 analyse exo-type body))]
- (return (&/|cons pattern+body patterns))))
+ (return (&/Cons$ pattern+body patterns))))
(let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))]
(defn ^:private merge-total [struct test+body]
(|let [[test ?body] test+body]
- (matchv ::M/objects [struct test]
- [["DefaultTotal" total?] ["StoreTestAC" ?idx]]
- (return (&/V "DefaultTotal" true))
+ (|case [struct test]
+ [($DefaultTotal total?) ($StoreTestAC ?idx)]
+ (return (&/V $DefaultTotal true))
- [[?tag [total? ?values]] ["StoreTestAC" ?idx]]
+ [[?tag [total? ?values]] ($StoreTestAC ?idx)]
(return (&/V ?tag (&/T true ?values)))
- [["DefaultTotal" total?] ["BoolTestAC" ?value]]
- (return (&/V "BoolTotal" (&/T total? (&/|list ?value))))
+ [($DefaultTotal total?) ($BoolTestAC ?value)]
+ (return (&/V $BoolTotal (&/T total? (&/|list ?value))))
- [["BoolTotal" [total? ?values]] ["BoolTestAC" ?value]]
- (return (&/V "BoolTotal" (&/T total? (&/|cons ?value ?values))))
+ [($BoolTotal total? ?values) ($BoolTestAC ?value)]
+ (return (&/V $BoolTotal (&/T total? (&/Cons$ ?value ?values))))
- [["DefaultTotal" total?] ["IntTestAC" ?value]]
- (return (&/V "IntTotal" (&/T total? (&/|list ?value))))
+ [($DefaultTotal total?) ($IntTestAC ?value)]
+ (return (&/V $IntTotal (&/T total? (&/|list ?value))))
- [["IntTotal" [total? ?values]] ["IntTestAC" ?value]]
- (return (&/V "IntTotal" (&/T total? (&/|cons ?value ?values))))
+ [($IntTotal total? ?values) ($IntTestAC ?value)]
+ (return (&/V $IntTotal (&/T total? (&/Cons$ ?value ?values))))
- [["DefaultTotal" total?] ["RealTestAC" ?value]]
- (return (&/V "RealTotal" (&/T total? (&/|list ?value))))
+ [($DefaultTotal total?) ($RealTestAC ?value)]
+ (return (&/V $RealTotal (&/T total? (&/|list ?value))))
- [["RealTotal" [total? ?values]] ["RealTestAC" ?value]]
- (return (&/V "RealTotal" (&/T total? (&/|cons ?value ?values))))
+ [($RealTotal total? ?values) ($RealTestAC ?value)]
+ (return (&/V $RealTotal (&/T total? (&/Cons$ ?value ?values))))
- [["DefaultTotal" total?] ["CharTestAC" ?value]]
- (return (&/V "CharTotal" (&/T total? (&/|list ?value))))
+ [($DefaultTotal total?) ($CharTestAC ?value)]
+ (return (&/V $CharTotal (&/T total? (&/|list ?value))))
- [["CharTotal" [total? ?values]] ["CharTestAC" ?value]]
- (return (&/V "CharTotal" (&/T total? (&/|cons ?value ?values))))
+ [($CharTotal total? ?values) ($CharTestAC ?value)]
+ (return (&/V $CharTotal (&/T total? (&/Cons$ ?value ?values))))
- [["DefaultTotal" total?] ["TextTestAC" ?value]]
- (return (&/V "TextTotal" (&/T total? (&/|list ?value))))
+ [($DefaultTotal total?) ($TextTestAC ?value)]
+ (return (&/V $TextTotal (&/T total? (&/|list ?value))))
- [["TextTotal" [total? ?values]] ["TextTestAC" ?value]]
- (return (&/V "TextTotal" (&/T total? (&/|cons ?value ?values))))
+ [($TextTotal total? ?values) ($TextTestAC ?value)]
+ (return (&/V $TextTotal (&/T total? (&/Cons$ ?value ?values))))
- [["DefaultTotal" total?] ["TupleTestAC" ?tests]]
+ [($DefaultTotal total?) ($TupleTestAC ?tests)]
(|do [structs (&/map% (fn [t]
- (merge-total (&/V "DefaultTotal" total?) (&/T t ?body)))
+ (merge-total (&/V $DefaultTotal total?) (&/T t ?body)))
?tests)]
- (return (&/V "TupleTotal" (&/T total? structs))))
+ (return (&/V $TupleTotal (&/T total? structs))))
- [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]]
+ [($TupleTotal total? ?values) ($TupleTestAC ?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))))
+ (return (&/V $TupleTotal (&/T total? structs))))
(fail "[Pattern-matching Error] Inconsistent tuple-size."))
- [["DefaultTotal" total?] ["RecordTestAC" ?tests]]
- (|do [structs (&/map% (fn [t]
- (|let [[slot value] t]
- (|do [struct* (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))]
- (return (&/T slot struct*)))))
- (->> ?tests
- &/->seq
- (sort compare-kv)
- &/->list))]
- (return (&/V "RecordTotal" (&/T total? structs))))
-
- [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]]
- (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."))
-
- [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]]
- (|do [sub-struct (merge-total (&/V "DefaultTotal" total?)
- (&/T ?test ?body))]
- (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct (&/|table))))))
-
- [["VariantTotal" [total? ?branches]] ["VariantTestAC" [?tag ?test]]]
- (|do [sub-struct (merge-total (or (&/|get ?tag ?branches)
- (&/V "DefaultTotal" total?))
- (&/T ?test ?body))]
- (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct ?branches)))))
+ [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)]
+ (|do [sub-struct (merge-total (&/V $DefaultTotal total?)
+ (&/T ?test ?body))
+ structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?)))
+ (&/$Some list)
+ (return list)
+
+ (&/$None)
+ (fail "[Pattern-matching Error] YOLO"))]
+ (return (&/V $VariantTotal (&/T total? structs))))
+
+ [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)]
+ (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches)
+ (&/$Some sub)
+ sub
+
+ (&/$None)
+ (&/V $DefaultTotal total?))
+ (&/T ?test ?body))
+ structs (|case (&/|list-put ?tag sub-struct ?branches)
+ (&/$Some list)
+ (return list)
+
+ (&/$None)
+ (fail "[Pattern-matching Error] YOLO"))]
+ (return (&/V $VariantTotal (&/T total? structs))))
))))
-(defn ^:private check-totality [value-type struct]
- (matchv ::M/objects [struct]
- [["BoolTotal" [?total ?values]]]
- (return (or ?total
- (= #{true false} (set (&/->seq ?values)))))
-
- [["IntTotal" [?total _]]]
- (return ?total)
-
- [["RealTotal" [?total _]]]
- (return ?total)
-
- [["CharTotal" [?total _]]]
- (return ?total)
+(defn check-totality+ [check-totality]
+ (fn [?token]
+ (&type/with-var
+ (fn [$var]
+ (|do [=output (check-totality $var ?token)
+ ?type (&type/deref+ $var)
+ =type (&type/clean $var ?type)]
+ (return (&/T =output =type)))))))
- [["TextTotal" [?total _]]]
+(defn ^:private check-totality [value-type struct]
+ (|case struct
+ ($DefaultTotal ?total)
(return ?total)
- [["TupleTotal" [?total ?structs]]]
- (if ?total
- (return true)
- (|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 "[Pattern-maching Error] Tuple is not total."))))
-
- [["RecordTotal" [?total ?structs]]]
- (if ?total
- (return true)
- (|do [value-type* (resolve-type value-type)]
- (matchv ::M/objects [value-type*]
- [["lux;RecordT" ?fields]]
- (|do [totals (&/map% (fn [field]
- (|let [[?tk ?tv] field]
- (if-let [sub-struct (&/|get ?tk ?structs)]
- (check-totality ?tv sub-struct)
- (return false))))
- ?fields)]
- (return (&/fold #(and %1 %2) true totals)))
-
- [_]
- (fail "[Pattern-maching Error] Record is not total."))))
-
- [["VariantTotal" [?total ?structs]]]
+ ($BoolTotal ?total ?values)
+ (|do [_ (&type/check value-type &type/Bool)]
+ (return (or ?total
+ (= #{true false} (set (&/->seq ?values))))))
+
+ ($IntTotal ?total _)
+ (|do [_ (&type/check value-type &type/Int)]
+ (return ?total))
+
+ ($RealTotal ?total _)
+ (|do [_ (&type/check value-type &type/Real)]
+ (return ?total))
+
+ ($CharTotal ?total _)
+ (|do [_ (&type/check value-type &type/Char)]
+ (return ?total))
+
+ ($TextTotal ?total _)
+ (|do [_ (&type/check value-type &type/Text)]
+ (return ?total))
+
+ ($TupleTotal ?total ?structs)
+ (|do [unknown? (&type/unknown? value-type)]
+ (if unknown?
+ (|do [=structs (&/map% (check-totality+ check-totality) ?structs)
+ _ (&type/check value-type (&/V &/$TupleT (&/|map &/|second =structs)))]
+ (return (or ?total
+ (&/fold #(and %1 %2) true (&/|map &/|first =structs)))))
+ (if ?total
+ (return true)
+ (|do [value-type* (resolve-type value-type)]
+ (|case value-type*
+ (&/$TupleT ?members)
+ (|do [totals (&/map2% (fn [sub-struct ?member]
+ (check-totality ?member sub-struct))
+ ?structs ?members)]
+ (return (&/fold #(and %1 %2) true totals)))
+
+ _
+ (fail "[Pattern-maching Error] Tuple is not total."))))))
+
+ ($VariantTotal ?total ?structs)
(if ?total
(return true)
(|do [value-type* (resolve-type value-type)]
- (matchv ::M/objects [value-type*]
- [["lux;VariantT" ?cases]]
- (|do [totals (&/map% (fn [case]
- (|let [[?tk ?tv] case]
- (if-let [sub-struct (&/|get ?tk ?structs)]
- (check-totality ?tv sub-struct)
- (return false))))
- ?cases)]
+ (|case value-type*
+ (&/$VariantT ?members)
+ (|do [totals (&/map2% check-totality ?members ?structs)]
(return (&/fold #(and %1 %2) true totals)))
- [_]
+ _
(fail "[Pattern-maching Error] Variant is not total."))))
-
- [["DefaultTotal" ?total]]
- (return ?total)
))
;; [Exports]
@@ -388,9 +365,9 @@
(|do [patterns (&/fold% (fn [patterns branch]
(|let [[pattern body] branch]
(analyse-branch analyse exo-type value-type pattern body patterns)))
- (&/|list)
+ &/Nil$
branches)
- struct (&/fold% merge-total (&/V "DefaultTotal" false) patterns)
+ struct (&/fold% merge-total (&/V $DefaultTotal false) patterns)
? (check-totality value-type struct)]
(if ?
(return patterns)
diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj
index cac0f8cd4..81397a3f6 100644
--- a/src/lux/analyser/env.clj
+++ b/src/lux/analyser/env.clj
@@ -1,49 +1,45 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.analyser.env
- (:require [clojure.core.match :as M :refer [matchv]]
+ (:require clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return return* fail]])
+ (lux [base :as & :refer [|do return return* fail |case]])
[lux.analyser.base :as &&]))
;; [Exports]
(def next-local-idx
(fn [state]
- (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))))
+ (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter)))))
(defn with-local [name type body]
- ;; (prn 'with-local name)
(fn [state]
- (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS))
- =return (body (&/update$ &/$ENVS
+ (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings))
+ =return (body (&/update$ &/$envs
(fn [stack]
- (let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))]
- (&/|cons (&/update$ &/$LOCALS #(->> %
- (&/update$ &/$COUNTER inc)
- (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m))))
+ (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))]
+ (&/Cons$ (&/update$ &/$locals #(->> %
+ (&/update$ &/$counter inc)
+ (&/update$ &/$mappings (fn [m] (&/|put name (&&/|meta type &/empty-cursor bound-unit) m))))
(&/|head stack))
(&/|tail stack))))
state))]
- (matchv ::M/objects [=return]
- [["lux;Right" [?state ?value]]]
- (return* (&/update$ &/$ENVS (fn [stack*]
- (&/|cons (&/update$ &/$LOCALS #(->> %
- (&/update$ &/$COUNTER dec)
- (&/set$ &/$MAPPINGS old-mappings))
+ (|case =return
+ (&/$Right ?state ?value)
+ (return* (&/update$ &/$envs (fn [stack*]
+ (&/Cons$ (&/update$ &/$locals #(->> %
+ (&/update$ &/$counter dec)
+ (&/set$ &/$mappings old-mappings))
(&/|head stack*))
(&/|tail stack*)))
?state)
?value)
- [_]
+ _
=return))))
(def captured-vars
(fn [state]
- (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS)))))
+ (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 5033f4f2c..7e1f92d19 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -1,256 +1,480 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.analyser.host
(:require (clojure [template :refer [do-template]])
- [clojure.core.match :as M :refer [match matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|let |do return fail]]
+ (lux [base :as & :refer [|let |do return fail |case]]
[parser :as &parser]
[type :as &type]
[host :as &host])
+ [lux.type.host :as &host-type]
(lux.analyser [base :as &&]
- [env :as &&env])))
+ [lambda :as &&lambda]
+ [env :as &&env])
+ [lux.compiler.base :as &c!base])
+ (:import (java.lang.reflect TypeVariable)))
;; [Utils]
-(defn ^:private extract-text [text]
- (matchv ::M/objects [text]
- [["lux;Meta" [_ ["lux;TextS" ?text]]]]
- (return ?text)
-
- [_]
- (fail "[Analyser Error] Can't extract Text.")))
-
-(defn ^:private analyse-1+ [analyse ?token]
- (&type/with-var
- (fn [$var]
- (|do [=expr (&&/analyse-1 analyse $var ?token)]
- (matchv ::M/objects [=expr]
- [[?item ?type]]
- (|do [=type (&type/clean $var ?type)]
- (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 extract-text [ast]
+ (|case ast
+ [_ (&/$TextS text)]
+ (return text)
+
+ _
+ (fail "[Analyser/Host Error] Can't extract text.")))
+
+(defn ^:private ensure-catching [exceptions]
+ "(-> (List Text) (Lux (,)))"
+ (|do [class-loader &/loader]
+ (fn [state]
+ (let [exceptions (&/|map #(Class/forName % true class-loader) exceptions)
+ catching (->> state (&/get$ &/$host) (&/get$ &/$catching)
+ (&/|map #(Class/forName % true class-loader)))]
+ (if-let [missing-ex (&/fold (fn [prev ^Class now]
+ (or prev
+ (if (&/fold (fn [found? ^Class ex-catch]
+ (or found?
+ (.isAssignableFrom ex-catch now)))
+ false
+ catching)
+ nil
+ now)))
+ nil
+ exceptions)]
+ (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex))
+ (&/return* state nil)))
+ )))
+
+(defn ^:private with-catches [catches body]
+ "(All [a] (-> (List Text) (Lux a) (Lux a)))"
+ (fn [state]
+ (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching))
+ state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))]
+ (|case (&/run-state body state*)
+ (&/$Left msg)
+ (&/V &/$Left msg)
+
+ (&/$Right state** output)
+ (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %)))
+ output))))
+ ))
+
+(defn ^:private ensure-object [type]
+ "(-> Type (Lux (, Text (List Type))))"
+ (|case type
+ (&/$DataT payload)
+ (return payload)
+
+ (&/$NamedT _ type*)
+ (ensure-object type*)
+
+ (&/$UnivQ _ type*)
+ (ensure-object type*)
+
+ (&/$ExQ _ type*)
+ (ensure-object type*)
+
+ _
+ (fail (str "[Analyser Error] Expecting object: " (&type/show-type type)))))
(defn ^:private as-object [type]
"(-> Type Type)"
- (matchv ::M/objects [type]
- [["lux;DataT" class]]
- (&/V "lux;DataT" (&type/as-obj class))
+ (|case type
+ (&/$DataT class params)
+ (&type/Data$ (&host-type/as-obj class) params)
- [_]
+ _
type))
+(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 ^:private as-otype+ [type]
+ "(-> Type Type)"
+ (|case type
+ (&/$DataT name params)
+ (&type/Data$ (as-otype name) params)
+
+ _
+ type))
+
+(defn ^:private clean-gtype-var [idx gtype-var]
+ (|let [(&/$VarT id) gtype-var]
+ (|do [? (&type/bound? id)]
+ (if ?
+ (|do [real-type (&type/deref id)]
+ (return (&/T idx real-type)))
+ (return (&/T (+ 2 idx) (&type/Bound$ idx)))))))
+
+(defn ^:private clean-gtype-vars [gtype-vars]
+ (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var]
+ (|do [:let [[idx types] idx+types]
+ [idx* real-type] (clean-gtype-var idx gtype-var)]
+ (return (&/T idx* (&/Cons$ real-type types)))))
+ (&/T 1 (&/|list))
+ gtype-vars)]
+ (return clean-types)))
+
+(defn ^:private make-gtype [class-name type-args]
+ "(-> Text (List Type) Type)"
+ (&/fold (fn [base-type type-arg]
+ (|case type-arg
+ (&/$BoundT _)
+ (&type/Univ$ &type/empty-env base-type)
+
+ _
+ base-type))
+ (&type/Data$ class-name type-args)
+ type-args))
+
;; [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 exo-type ?x ?y]
- (|do [=x (&&/analyse-1 analyse input-type ?x)
- =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"
- analyse-jvm-isub "jvm-isub" "java.lang.Integer" "java.lang.Integer"
- analyse-jvm-imul "jvm-imul" "java.lang.Integer" "java.lang.Integer"
- analyse-jvm-idiv "jvm-idiv" "java.lang.Integer" "java.lang.Integer"
- analyse-jvm-irem "jvm-irem" "java.lang.Integer" "java.lang.Integer"
- analyse-jvm-ieq "jvm-ieq" "java.lang.Integer" "java.lang.Boolean"
- 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"
- analyse-jvm-ldiv "jvm-ldiv" "java.lang.Long" "java.lang.Long"
- analyse-jvm-lrem "jvm-lrem" "java.lang.Long" "java.lang.Long"
- analyse-jvm-leq "jvm-leq" "java.lang.Long" "java.lang.Boolean"
- analyse-jvm-llt "jvm-llt" "java.lang.Long" "java.lang.Boolean"
- analyse-jvm-lgt "jvm-lgt" "java.lang.Long" "java.lang.Boolean"
-
- analyse-jvm-fadd "jvm-fadd" "java.lang.Float" "java.lang.Float"
- analyse-jvm-fsub "jvm-fsub" "java.lang.Float" "java.lang.Float"
- analyse-jvm-fmul "jvm-fmul" "java.lang.Float" "java.lang.Float"
- analyse-jvm-fdiv "jvm-fdiv" "java.lang.Float" "java.lang.Float"
- analyse-jvm-frem "jvm-frem" "java.lang.Float" "java.lang.Float"
- analyse-jvm-feq "jvm-feq" "java.lang.Float" "java.lang.Boolean"
- analyse-jvm-flt "jvm-flt" "java.lang.Float" "java.lang.Boolean"
- analyse-jvm-fgt "jvm-fgt" "java.lang.Float" "java.lang.Boolean"
-
- analyse-jvm-dadd "jvm-dadd" "java.lang.Double" "java.lang.Double"
- analyse-jvm-dsub "jvm-dsub" "java.lang.Double" "java.lang.Double"
- analyse-jvm-dmul "jvm-dmul" "java.lang.Double" "java.lang.Double"
- analyse-jvm-ddiv "jvm-ddiv" "java.lang.Double" "java.lang.Double"
- analyse-jvm-drem "jvm-drem" "java.lang.Double" "java.lang.Double"
- analyse-jvm-deq "jvm-deq" "java.lang.Double" "java.lang.Boolean"
- analyse-jvm-dlt "jvm-dlt" "java.lang.Double" "java.lang.Boolean"
- analyse-jvm-dgt "jvm-dgt" "java.lang.Double" "java.lang.Boolean"
+ (let [input-type (&type/Data$ <input-class> &/Nil$)
+ output-type (&type/Data$ <output-class> &/Nil$)]
+ (defn <name> [analyse exo-type x y]
+ (|do [=x (&&/analyse-1 analyse input-type x)
+ =y (&&/analyse-1 analyse input-type y)
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta output-type _cursor
+ (&/V <output-tag> (&/T =x =y))))))))
+
+ analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-imul &&/$jvm-imul "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-idiv &&/$jvm-idiv "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-irem &&/$jvm-irem "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-ieq &&/$jvm-ieq "java.lang.Integer" "java.lang.Boolean"
+ 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"
+ analyse-jvm-ldiv &&/$jvm-ldiv "java.lang.Long" "java.lang.Long"
+ analyse-jvm-lrem &&/$jvm-lrem "java.lang.Long" "java.lang.Long"
+ analyse-jvm-leq &&/$jvm-leq "java.lang.Long" "java.lang.Boolean"
+ analyse-jvm-llt &&/$jvm-llt "java.lang.Long" "java.lang.Boolean"
+ analyse-jvm-lgt &&/$jvm-lgt "java.lang.Long" "java.lang.Boolean"
+
+ analyse-jvm-fadd &&/$jvm-fadd "java.lang.Float" "java.lang.Float"
+ analyse-jvm-fsub &&/$jvm-fsub "java.lang.Float" "java.lang.Float"
+ analyse-jvm-fmul &&/$jvm-fmul "java.lang.Float" "java.lang.Float"
+ analyse-jvm-fdiv &&/$jvm-fdiv "java.lang.Float" "java.lang.Float"
+ analyse-jvm-frem &&/$jvm-frem "java.lang.Float" "java.lang.Float"
+ analyse-jvm-feq &&/$jvm-feq "java.lang.Float" "java.lang.Boolean"
+ analyse-jvm-flt &&/$jvm-flt "java.lang.Float" "java.lang.Boolean"
+ analyse-jvm-fgt &&/$jvm-fgt "java.lang.Float" "java.lang.Boolean"
+
+ analyse-jvm-dadd &&/$jvm-dadd "java.lang.Double" "java.lang.Double"
+ analyse-jvm-dsub &&/$jvm-dsub "java.lang.Double" "java.lang.Double"
+ analyse-jvm-dmul &&/$jvm-dmul "java.lang.Double" "java.lang.Double"
+ analyse-jvm-ddiv &&/$jvm-ddiv "java.lang.Double" "java.lang.Double"
+ analyse-jvm-drem &&/$jvm-drem "java.lang.Double" "java.lang.Double"
+ analyse-jvm-deq &&/$jvm-deq "java.lang.Double" "java.lang.Boolean"
+ analyse-jvm-dlt &&/$jvm-dlt "java.lang.Double" "java.lang.Boolean"
+ analyse-jvm-dgt &&/$jvm-dgt "java.lang.Double" "java.lang.Boolean"
)
-(defn analyse-jvm-getstatic [analyse exo-type ?class ?field]
+(defn ^:private analyse-field-access-helper [obj-type gvars gtype]
+ "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))"
+ (|case obj-type
+ (&/$DataT class targs)
+ (if (= (&/|length targs) (&/|length gvars))
+ (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/Cons$ (&/T (.getName g) t) m))
+ (&/|table)
+ gvars
+ targs)]
+ (&host-type/instance-param &type/existential gtype-env gtype))
+ (fail (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type))))
+
+ _
+ (fail (str "[Type Error] Type is not an object type: " (&type/show-type obj-type)))))
+
+(defn analyse-jvm-getstatic [analyse exo-type class field]
(|do [class-loader &/loader
- =type (&host/lookup-static-field class-loader ?class ?field)
+ [gvars gtype] (&host/lookup-static-field class-loader class field)
+ :let [=type (&host-type/class->type (cast Class gtype))]
:let [output-type =type]
- _ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) output-type)))))
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-getstatic (&/T class field output-type)))))))
-(defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object]
+(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)
+ =object (&&/analyse-1 analyse object)
+ _ (ensure-object (&&/expr-type* =object))
+ [gvars gtype] (&host/lookup-field class-loader class field)
+ =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype)
:let [output-type =type]
- _ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) output-type)))))
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-getfield (&/T class field =object output-type)))))))
-(defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value]
+(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)
+ [gvars gtype] (&host/lookup-static-field class-loader class field)
+ :let [=type (&host-type/class->type (cast Class gtype))]
+ =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)))))
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-putstatic (&/T class field =value output-type)))))))
-(defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value]
+(defn analyse-jvm-putfield [analyse exo-type class field value object]
(|do [class-loader &/loader
- =type (&host/lookup-static-field class-loader ?class ?field)
- =object (&&/analyse-1 analyse ?object)
- =value (&&/analyse-1 analyse =type ?value)
+ =object (&&/analyse-1 analyse object)
+ _ (ensure-object (&&/expr-type* =object))
+ [gvars gtype] (&host/lookup-field class-loader class field)
+ =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype)
+ =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)))))
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-putfield (&/T class field =value =object (&&/expr-type* =object))))))))
+
+(defn analyse-jvm-instanceof [analyse exo-type class object]
+ (|do [=object (&&/analyse-1+ analyse object)
+ _ (ensure-object (&&/expr-type* =object))
+ :let [output-type &type/Bool]
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta output-type _cursor
+ (&/V &&/$jvm-instanceof (&/T class =object)))))))
+
+(defn ^:private analyse-method-call-helper [analyse gret gtype-env gtype-vars gtype-args args]
+ (|case gtype-vars
+ (&/$Nil)
+ (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args)
+ =args (&/map2% (partial &&/analyse-1 analyse) arg-types args)
+ =gret (&host-type/instance-param &type/existential gtype-env gret)]
+ (return (&/T =gret =args)))
+
+ (&/$Cons ^TypeVariable gtv gtype-vars*)
+ (&type/with-var
+ (fn [$var]
+ (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)]
+ (analyse-method-call-helper analyse gret gtype-env* gtype-vars* gtype-args args))))
+ ))
-(defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args]
+(let [dummy-type-param (&type/Data$ "java.lang.Object" (&/|list))]
+ (do-template [<name> <tag>]
+ (defn <name> [analyse exo-type class method classes object args]
+ (|do [class-loader &/loader
+ [gret exceptions parent-gvars gvars gargs] (if (= "<init>" method)
+ (return (&/T Void/TYPE &/Nil$ &/Nil$ &/Nil$ &/Nil$))
+ (&host/lookup-virtual-method class-loader class method classes))
+ _ (ensure-catching exceptions)
+ =object (&&/analyse-1+ analyse object)
+ [sub-class sub-params] (ensure-object (&&/expr-type* =object))
+ (&/$DataT super-class* super-params*) (&host-type/->super-type &type/existential class-loader class sub-class sub-params)
+ :let [gtype-env (&/fold2 (fn [m g t] (&/Cons$ (&/T g t) m))
+ (&/|table)
+ parent-gvars
+ super-params*)]
+ [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args)
+ _ (&type/check exo-type (as-otype+ output-type))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/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-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))]
+ [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes)
+ _ (ensure-catching exceptions)
=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)
+ (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg))
+ classes
+ args)
+ :let [output-type (&host-type/class->type (cast Class gret))]
+ _ (&type/check exo-type (as-otype+ output-type))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-invokestatic (&/T class method classes =args output-type)))))))
+
+(defn analyse-jvm-null? [analyse exo-type object]
+ (|do [=object (&&/analyse-1+ analyse object)
+ _ (ensure-object (&&/expr-type* =object))
:let [output-type &type/Bool]
- _ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class =object)) output-type)))))
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta output-type _cursor
+ (&/V &&/$jvm-null? =object))))))
-(do-template [<name> <tag>]
- (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)
- =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"
- )
+(defn analyse-jvm-null [analyse exo-type]
+ (|do [:let [output-type (&type/Data$ &host-type/null-data-tag &/Nil$)]
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta output-type _cursor
+ (&/V &&/$jvm-null nil))))))
+
+(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args]
+ (|case gtype-vars
+ (&/$Nil)
+ (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args)
+ =args (&/map2% (partial &&/analyse-1 analyse) arg-types args)
+ gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))]
+ (return (&/T (make-gtype gtype gtype-vars*)
+ =args)))
+
+ (&/$Cons ^TypeVariable gtv gtype-vars*)
+ (&type/with-var
+ (fn [$var]
+ (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)]
+ (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args))))
+ ))
-(defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args]
+(defn analyse-jvm-new [analyse exo-type class classes 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)))))
+ [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes)
+ _ (ensure-catching exceptions)
+ [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args)
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-new (&/T class classes =args)))))))
+
+(let [length-type &type/Int
+ idx-type &type/Int]
+ (do-template [<class> <new-name> <new-tag> <load-name> <load-tag> <store-name> <store-tag>]
+ (let [elem-type (&type/Data$ <class> &/Nil$)
+ array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))]
+ (defn <new-name> [analyse exo-type length]
+ (|do [=length (&&/analyse-1 analyse length-type length)
+ _ (&type/check exo-type array-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V <new-tag> =length))))))
+
+ (defn <load-name> [analyse exo-type array idx]
+ (|do [=array (&&/analyse-1 analyse array-type array)
+ =idx (&&/analyse-1 analyse idx-type idx)
+ _ (&type/check exo-type elem-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V <load-tag> (&/T =array =idx)))))))
+
+ (defn <store-name> [analyse exo-type array idx elem]
+ (|do [=array (&&/analyse-1 analyse array-type array)
+ =idx (&&/analyse-1 analyse idx-type idx)
+ =elem (&&/analyse-1 analyse elem-type elem)
+ _ (&type/check exo-type array-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V <store-tag> (&/T =array =idx =elem)))))))
+ )
+
+ "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore
+ "java.lang.Byte" analyse-jvm-bnewarray &&/$jvm-bnewarray analyse-jvm-baload &&/$jvm-baload analyse-jvm-bastore &&/$jvm-bastore
+ "java.lang.Short" analyse-jvm-snewarray &&/$jvm-snewarray analyse-jvm-saload &&/$jvm-saload analyse-jvm-sastore &&/$jvm-sastore
+ "java.lang.Integer" analyse-jvm-inewarray &&/$jvm-inewarray analyse-jvm-iaload &&/$jvm-iaload analyse-jvm-iastore &&/$jvm-iastore
+ "java.lang.Long" analyse-jvm-lnewarray &&/$jvm-lnewarray analyse-jvm-laload &&/$jvm-laload analyse-jvm-lastore &&/$jvm-lastore
+ "java.lang.Float" analyse-jvm-fnewarray &&/$jvm-fnewarray analyse-jvm-faload &&/$jvm-faload analyse-jvm-fastore &&/$jvm-fastore
+ "java.lang.Double" analyse-jvm-dnewarray &&/$jvm-dnewarray analyse-jvm-daload &&/$jvm-daload analyse-jvm-dastore &&/$jvm-dastore
+ "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore
+ ))
-(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]
- (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 ?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)
- =array-type (&&/expr-type =array)]
- (return (&/|list (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type)))))
+(let [length-type &type/Int
+ idx-type &type/Int]
+ (defn analyse-jvm-anewarray [analyse exo-type class length]
+ (|do [elem-type (&host-type/dummy-gtype class)
+ :let [array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))]
+ =length (&&/analyse-1 analyse length-type length)
+ _ (&type/check exo-type array-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-anewarray (&/T class =length)))))))
+
+ (defn analyse-jvm-aaload [analyse exo-type array idx]
+ (|do [=array (&&/analyse-1+ analyse array)
+ [arr-class arr-params] (ensure-object (&&/expr-type* =array))
+ _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
+ :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
+ =idx (&&/analyse-1 analyse idx-type idx)
+ _ (&type/check exo-type inner-arr-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-aaload (&/T =array =idx)))))))
+
+ (defn analyse-jvm-aastore [analyse exo-type array idx elem]
+ (|do [=array (&&/analyse-1+ analyse array)
+ :let [array-type (&&/expr-type* =array)]
+ [arr-class arr-params] (ensure-object array-type)
+ _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
+ :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
+ =idx (&&/analyse-1 analyse idx-type idx)
+ =elem (&&/analyse-1 analyse inner-arr-type elem)
+ _ (&type/check exo-type array-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-aastore (&/T =array =idx =elem))))))))
+
+(defn analyse-jvm-arraylength [analyse exo-type array]
+ (|do [=array (&&/analyse-1+ analyse array)
+ [arr-class arr-params] (ensure-object (&&/expr-type* =array))
+ _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
+ _ (&type/check exo-type &type/Int)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-arraylength =array)
+ )))))
(defn ^:private analyse-modifiers [modifiers]
(&/fold% (fn [so-far modif]
- (matchv ::M/objects [modif]
- [["lux;Meta" [_ ["lux;TextS" "public"]]]]
+ (|case modif
+ [_ (&/$TextS "public")]
(return (assoc so-far :visibility "public"))
- [["lux;Meta" [_ ["lux;TextS" "private"]]]]
+ [_ (&/$TextS "private")]
(return (assoc so-far :visibility "private"))
- [["lux;Meta" [_ ["lux;TextS" "protected"]]]]
+ [_ (&/$TextS "protected")]
(return (assoc so-far :visibility "protected"))
- [["lux;Meta" [_ ["lux;TextS" "static"]]]]
+ [_ (&/$TextS "static")]
(return (assoc so-far :static? true))
- [["lux;Meta" [_ ["lux;TextS" "final"]]]]
+ [_ (&/$TextS "final")]
(return (assoc so-far :final? true))
- [["lux;Meta" [_ ["lux;TextS" "abstract"]]]]
+ [_ (&/$TextS "abstract")]
(return (assoc so-far :abstract? true))
- [["lux;Meta" [_ ["lux;TextS" "synchronized"]]]]
+ [_ (&/$TextS "synchronized")]
(return (assoc so-far :concurrency "synchronized"))
- [["lux;Meta" [_ ["lux;TextS" "volatile"]]]]
+ [_ (&/$TextS "volatile")]
(return (assoc so-far :concurrency "volatile"))
- [_]
+ _
(fail (str "[Analyser Error] Unknown modifier: " (&/show-ast modif)))))
{:visibility "default"
:static? false
@@ -259,181 +483,332 @@
: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;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] Wrong syntax for field.")))
- ?fields)
- =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 (str "[Analyser Error] Invalid method signature: " (&/show-ast method)))))
- ?methods)]
- (return (&/|list (&/V "jvm-interface" (&/T ?name =supers =methods))))))
+(let [failure (fail (str "[Analyser Error] Invalid annotation parameter."))]
+ (defn ^:private extract-ann-param [param]
+ (|case param
+ [[_ (&/$TextS param-name)] param-value]
+ (|case param-value
+ [_ (&/$BoolS param-value*)] (return (&/T param-name (boolean param-value*)))
+ [_ (&/$IntS param-value*)] (return (&/T param-name (int param-value*)))
+ [_ (&/$RealS param-value*)] (return (&/T param-name (float param-value*)))
+ [_ (&/$CharS param-value*)] (return (&/T param-name (char param-value*)))
+ [_ (&/$TextS param-value*)] (return (&/T param-name param-value*))
+
+ _
+ failure)
+
+ _
+ failure)))
+
+(defn ^:private analyse-ann [ann]
+ (|case ann
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS ann-name)] (&/$Cons [_ (&/$RecordS ann-params)] (&/$Nil))))]
+ (|do [=ann-params (&/map% extract-ann-param ann-params)]
+ (return {:name ann-name
+ :params ann-params}))
+
+ _
+ (fail (str "[Analyser Error] Invalid annotation: " (&/show-ast ann)))))
+
+(defn ^:private analyse-field [field]
+ (|case field
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)]
+ (&/$Cons [_ (&/$TupleS ?field-modifiers)]
+ (&/$Cons [_ (&/$TupleS ?anns)]
+ (&/$Cons [_ (&/$TextS ?field-type)]
+ (&/$Nil))))))]
+ (|do [=field-modifiers (analyse-modifiers ?field-modifiers)
+ =anns (&/map% analyse-ann ?anns)]
+ (return {:name ?field-name
+ :modifiers =field-modifiers
+ :anns =anns
+ :type ?field-type}))
+
+ _
+ (fail "[Analyser Error] Wrong syntax for field.")))
+
+(defn ^:private dummy-method-desc [method]
+ (|case method
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)]
+ (&/$Cons [_ (&/$TupleS method-modifiers)]
+ (&/$Cons [_ (&/$TupleS method-anns)]
+ (&/$Cons [_ (&/$TupleS method-exs)]
+ (&/$Cons [_ (&/$TupleS method-inputs)]
+ (&/$Cons [_ (&/$TextS method-output)]
+ (&/$Cons method-body
+ (&/$Nil)))))))))]
+ (|do [=method-modifiers (analyse-modifiers method-modifiers)
+ =method-exs (&/map% extract-text method-exs)
+ =method-inputs (&/map% (fn [minput]
+ (|case minput
+ [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)]
+ (&/$Cons [_ (&/$TextS input-type)]
+ (&/$Nil))))]
+ (return (&/T input-name input-type))
+
+ _
+ (fail "[Analyser Error] Wrong syntax for method input.")))
+ method-inputs)]
+ (return {:name method-name
+ :modifiers =method-modifiers
+ :anns (&/|list)
+ :exceptions =method-exs
+ :inputs (&/|map &/|second =method-inputs)
+ :output method-output}))
+
+ _
+ (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method)))))
+
+(defn ^:private analyse-method [analyse owner-class method]
+ (|case method
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)]
+ (&/$Cons [_ (&/$TupleS method-modifiers)]
+ (&/$Cons [_ (&/$TupleS method-anns)]
+ (&/$Cons [_ (&/$TupleS method-exs)]
+ (&/$Cons [_ (&/$TupleS method-inputs)]
+ (&/$Cons [_ (&/$TextS method-output)]
+ (&/$Cons method-body
+ (&/$Nil)))))))))]
+ (|do [=method-modifiers (analyse-modifiers method-modifiers)
+ =anns (&/map% analyse-ann method-anns)
+ =method-exs (&/map% extract-text method-exs)
+ =method-inputs (&/map% (fn [minput]
+ (|case minput
+ [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)]
+ (&/$Cons [_ (&/$TextS input-type)]
+ (&/$Nil))))]
+ (return (&/T input-name input-type))
+
+ _
+ (fail "[Analyser Error] Wrong syntax for method input.")))
+ method-inputs)
+ =method-body (&/fold (fn [body* input*]
+ (|let [[iname itype] input*]
+ (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$)
+ body*)))
+ (if (= "void" method-output)
+ (&&/analyse-1+ analyse method-body)
+ (&&/analyse-1 analyse (&type/Data$ (as-otype method-output) &/Nil$) method-body))
+ (&/|reverse (&/Cons$ (&/T &&/jvm-this owner-class)
+ =method-inputs)))]
+ (return {:name method-name
+ :modifiers =method-modifiers
+ :anns =anns
+ :exceptions =method-exs
+ :inputs (&/|map &/|second =method-inputs)
+ :output method-output
+ :body =method-body}))
+
+ _
+ (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method)))))
+
+(defn ^:private analyse-method-decl [method]
+ (|case method
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)]
+ (&/$Cons [_ (&/$TupleS modifiers)]
+ (&/$Cons [_ (&/$TupleS ?anns)]
+ (&/$Cons [_ (&/$TupleS method-exs)]
+ (&/$Cons [_ (&/$TupleS inputs)]
+ (&/$Cons [_ (&/$TextS output)]
+ (&/$Nil))))))))]
+ (|do [=modifiers (analyse-modifiers modifiers)
+ =anns (&/map% analyse-ann ?anns)
+ =inputs (&/map% extract-text inputs)
+ =method-exs (&/map% extract-text method-exs)]
+ (return {:name method-name
+ :modifiers =modifiers
+ :anns =anns
+ :exceptions =method-exs
+ :inputs =inputs
+ :output output}))
+
+ _
+ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method)))))
+
+(defn ^:private mandatory-methods [supers]
+ (|do [class-loader &/loader]
+ (&/flat-map% (partial &host/abstract-methods class-loader) supers)))
+
+(defn ^:private check-method-completion [supers methods]
+ "(-> (List ClassName) (List MethodDesc) (Lux (,)))"
+ (|do [abstract-methods (mandatory-methods supers)
+ :let [methods-map (&/fold (fn [mmap mentry]
+ (assoc mmap (:name mentry) mentry))
+ {}
+ methods)
+ missing-method (&/fold (fn [missing abs-meth]
+ (|let [[am-name am-inputs] abs-meth]
+ (or missing
+ (if-let [meth-struct (get methods-map am-name)]
+ (let [meth-inputs (:inputs meth-struct)]
+ (if (and (= (&/|length meth-inputs) (&/|length am-inputs))
+ (&/fold2 (fn [prev mi ai] (and prev (= mi ai)))
+ true
+ meth-inputs am-inputs))
+ nil
+ am-name))
+ am-name))))
+ nil
+ abstract-methods)]]
+ (if (nil? missing-method)
+ (return nil)
+ (fail (str "[Analyser Error] Missing method: " missing-method)))))
+
+(defn analyse-jvm-class [analyse compile-token name super-class interfaces anns fields methods]
+ (&/with-closure
+ (|do [module &/get-module-name
+ :let [full-name (str module "." name)]
+ ;; :let [_ (prn 'analyse-jvm-class/_0)]
+ =anns (&/map% analyse-ann anns)
+ =fields (&/map% analyse-field fields)
+ ;; :let [_ (prn 'analyse-jvm-class/_1)]
+ =method-descs (&/map% dummy-method-desc methods)
+ _ (&host/use-dummy-class name super-class interfaces =fields =method-descs)
+ =methods (&/map% (partial analyse-method analyse full-name) methods)
+ ;; :let [_ (prn 'analyse-jvm-class/_2)]
+ _ (check-method-completion (&/Cons$ super-class interfaces) =methods)
+ ;; :let [_ (prn 'analyse-jvm-class/_3)]
+ _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =anns =fields =methods nil)))
+ :let [_ (println 'DEF (str module "." name))]]
+ (return &/Nil$))))
+
+(defn analyse-jvm-interface [analyse compile-token name supers anns methods]
+ (|do [module &/get-module-name
+ =anns (&/map% analyse-ann anns)
+ =methods (&/map% analyse-method-decl methods)
+ _ (compile-token (&/V &&/$jvm-interface (&/T name supers =anns =methods)))
+ :let [_ (println 'DEF (str module "." name))]]
+ (return &/Nil$)))
+
+(defn ^:private captured-source [env-entry]
+ (|case env-entry
+ [name [_ (&&/$captured _ _ source)]]
+ source))
+
+(let [captured-slot-modifier {:visibility "private"
+ :static? false
+ :final? false
+ :abstract? false
+ :concurrency nil}
+ captured-slot-type "java.lang.Object"]
+ (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods]
+ (&/with-closure
+ (|do [module &/get-module-name
+ scope &/get-scope-name
+ :let [name (&host/location (&/|tail scope))
+ anon-class (str module "." name)]
+ =method-descs (&/map% dummy-method-desc methods)
+ _ (&host/use-dummy-class name super-class interfaces (&/|list) =method-descs)
+ =methods (&/map% (partial analyse-method analyse anon-class) methods)
+ _ (check-method-completion (&/Cons$ super-class interfaces) =methods)
+ =captured &&env/captured-vars
+ :let [=fields (&/|map (fn [^objects idx+capt]
+ {:name (str &c!base/closure-prefix (aget idx+capt 0))
+ :modifiers captured-slot-modifier
+ :anns (&/|list)
+ :type captured-slot-type})
+ (&/enumerate =captured))]
+ :let [sources (&/|map captured-source =captured)]
+ _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured)))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor
+ (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources))
+ )))
+ ))))
(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]]
- (|do [=catch-body (&&env/with-local (str ";" ?ex-arg) (&/V "lux;DataT" ?ex-class)
+ (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class &/Nil$)
(&&/analyse-1 analyse exo-type ?catch-body))
idx &&env/next-local-idx]
(return (&/T ?ex-class idx =catch-body))))
?catches)
- =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)))))
+ :let [catched-exceptions (&/|map #(aget ^objects % 0) =catches)]
+ =body (with-catches catched-exceptions
+ (&&/analyse-1 analyse exo-type ?body))
+ =finally (|case ?finally
+ (&/$None) (return &/None$)
+ (&/$Some ?finally*) (|do [=finally (&&/analyse-1+ analyse ?finally*)]
+ (return (&/V &/$Some =finally))))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$jvm-try (&/T =body =catches =finally)))))))
(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)))))
+ (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-throw =ex))))))
(do-template [<name> <tag>]
(defn <name> [analyse exo-type ?monitor]
- (|do [=monitor (analyse-1+ analyse ?monitor)
- _ (ensure-object =monitor)
+ (|do [=monitor (&&/analyse-1+ analyse ?monitor)
+ _ (ensure-object (&&/expr-type* =monitor))
:let [output-type &type/Unit]
- _ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V <tag> =monitor) output-type)))))
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta output-type _cursor (&/V <tag> =monitor))))))
- analyse-jvm-monitorenter "jvm-monitorenter"
- analyse-jvm-monitorexit "jvm-monitorexit"
+ analyse-jvm-monitorenter &&/$jvm-monitorenter
+ analyse-jvm-monitorexit &&/$jvm-monitorexit
)
(do-template [<name> <tag> <from-class> <to-class>]
- (let [output-type (&/V "lux;DataT" <to-class>)]
+ (let [output-type (&type/Data$ <to-class> &/Nil$)]
(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"
- analyse-jvm-d2l "jvm-d2l" "java.lang.Double" "java.lang.Long"
-
- analyse-jvm-f2d "jvm-f2d" "java.lang.Float" "java.lang.Double"
- analyse-jvm-f2i "jvm-f2i" "java.lang.Float" "java.lang.Integer"
- analyse-jvm-f2l "jvm-f2l" "java.lang.Float" "java.lang.Long"
-
- analyse-jvm-i2b "jvm-i2b" "java.lang.Integer" "java.lang.Byte"
- analyse-jvm-i2c "jvm-i2c" "java.lang.Integer" "java.lang.Character"
- analyse-jvm-i2d "jvm-i2d" "java.lang.Integer" "java.lang.Double"
- analyse-jvm-i2f "jvm-i2f" "java.lang.Integer" "java.lang.Float"
- analyse-jvm-i2l "jvm-i2l" "java.lang.Integer" "java.lang.Long"
- analyse-jvm-i2s "jvm-i2s" "java.lang.Integer" "java.lang.Short"
-
- analyse-jvm-l2d "jvm-l2d" "java.lang.Long" "java.lang.Double"
- analyse-jvm-l2f "jvm-l2f" "java.lang.Long" "java.lang.Float"
- analyse-jvm-l2i "jvm-l2i" "java.lang.Long" "java.lang.Integer"
+ (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class> &/Nil$) ?value)
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta output-type _cursor (&/V <tag> =value)))))))
+
+ analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float"
+ analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer"
+ analyse-jvm-d2l &&/$jvm-d2l "java.lang.Double" "java.lang.Long"
+
+ analyse-jvm-f2d &&/$jvm-f2d "java.lang.Float" "java.lang.Double"
+ analyse-jvm-f2i &&/$jvm-f2i "java.lang.Float" "java.lang.Integer"
+ analyse-jvm-f2l &&/$jvm-f2l "java.lang.Float" "java.lang.Long"
+
+ analyse-jvm-i2b &&/$jvm-i2b "java.lang.Integer" "java.lang.Byte"
+ analyse-jvm-i2c &&/$jvm-i2c "java.lang.Integer" "java.lang.Character"
+ analyse-jvm-i2d &&/$jvm-i2d "java.lang.Integer" "java.lang.Double"
+ analyse-jvm-i2f &&/$jvm-i2f "java.lang.Integer" "java.lang.Float"
+ analyse-jvm-i2l &&/$jvm-i2l "java.lang.Integer" "java.lang.Long"
+ analyse-jvm-i2s &&/$jvm-i2s "java.lang.Integer" "java.lang.Short"
+
+ analyse-jvm-l2d &&/$jvm-l2d "java.lang.Long" "java.lang.Double"
+ analyse-jvm-l2f &&/$jvm-l2f "java.lang.Long" "java.lang.Float"
+ analyse-jvm-l2i &&/$jvm-l2i "java.lang.Long" "java.lang.Integer"
)
(do-template [<name> <tag> <from-class> <to-class>]
- (let [output-type (&/V "lux;DataT" <to-class>)]
+ (let [output-type (&type/Data$ <to-class> &/Nil$)]
(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"
-
- analyse-jvm-land "jvm-land" "java.lang.Long" "java.lang.Long"
- analyse-jvm-lor "jvm-lor" "java.lang.Long" "java.lang.Long"
- analyse-jvm-lxor "jvm-lxor" "java.lang.Long" "java.lang.Long"
-
- analyse-jvm-lshl "jvm-lshl" "java.lang.Long" "java.lang.Integer"
- analyse-jvm-lshr "jvm-lshr" "java.lang.Long" "java.lang.Integer"
- analyse-jvm-lushr "jvm-lushr" "java.lang.Long" "java.lang.Integer"
+ (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class> &/Nil$) ?value)
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta output-type _cursor (&/V <tag> =value)))))))
+
+ analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-ixor &&/$jvm-ixor "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-ishl &&/$jvm-ishl "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-ishr &&/$jvm-ishr "java.lang.Integer" "java.lang.Integer"
+ analyse-jvm-iushr &&/$jvm-iushr "java.lang.Integer" "java.lang.Integer"
+
+ analyse-jvm-land &&/$jvm-land "java.lang.Long" "java.lang.Long"
+ analyse-jvm-lor &&/$jvm-lor "java.lang.Long" "java.lang.Long"
+ analyse-jvm-lxor &&/$jvm-lxor "java.lang.Long" "java.lang.Long"
+ analyse-jvm-lshl &&/$jvm-lshl "java.lang.Long" "java.lang.Integer"
+ analyse-jvm-lshr &&/$jvm-lshr "java.lang.Long" "java.lang.Integer"
+ analyse-jvm-lushr &&/$jvm-lushr "java.lang.Long" "java.lang.Integer"
)
-(defn analyse-jvm-program [analyse ?args ?body]
- (|let [[_module _name] ?args]
+(let [input-type (&type/App$ &type/List &type/Text)
+ output-type (&type/App$ &type/IO &type/Unit)]
+ (defn analyse-jvm-program [analyse compile-token ?args ?body]
(|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))))))
+ (&&env/with-local ?args input-type
+ (&&/analyse-1 analyse output-type ?body)))
+ _ (compile-token (&/V &&/$jvm-program =body))]
+ (return &/Nil$))))
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index b1b9e2c22..bbb5d2dc7 100644
--- a/src/lux/analyser/lambda.clj
+++ b/src/lux/analyser/lambda.clj
@@ -1,41 +1,33 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.analyser.lambda
- (:require [clojure.core.match :as M :refer [matchv]]
+ (:require clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|let |do return fail]]
+ (lux [base :as & :refer [|let |do return fail |case]]
[host :as &host])
(lux.analyser [base :as &&]
[env :as &env])))
;; [Resource]
(defn with-lambda [self self-type arg arg-type body]
- (|let [[?module1 ?name1] self
- [?module2 ?name2] arg]
- (&/with-closure
- (|do [scope-name &/get-scope-name]
- (&env/with-local (str ?module1 ";" ?name1) self-type
- (&env/with-local (str ?module2 ";" ?name2) arg-type
- (|do [=return body
- =captured &env/captured-vars]
- (return (&/T scope-name =captured =return)))))))))
+ (&/with-closure
+ (|do [scope-name &/get-scope-name]
+ (&env/with-local self self-type
+ (&env/with-local arg arg-type
+ (|do [=return body
+ =captured &env/captured-vars]
+ (return (&/T scope-name =captured =return))))))))
-(defn close-over [scope ident register frame]
- (matchv ::M/objects [register]
- [[_ register-type]]
- (|let [register* (&/T (&/V "captured" (&/T scope
- (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER))
- register))
- register-type)
- [?module ?name] ident
- full-name (str ?module ";" ?name)]
- (&/T register* (&/update$ &/$CLOSURE #(->> %
- (&/update$ &/$COUNTER inc)
- (&/update$ &/$MAPPINGS (fn [mps] (&/|put full-name register* mps))))
- frame)))))
+(defn close-over [scope name register frame]
+ (|let [[[register-type register-cursor] _] register
+ register* (&&/|meta register-type register-cursor
+ (&/V &&/$captured (&/T scope
+ (->> frame (&/get$ &/$closure) (&/get$ &/$counter))
+ register)))]
+ (&/T register* (&/update$ &/$closure #(->> %
+ (&/update$ &/$counter inc)
+ (&/update$ &/$mappings (fn [mps] (&/|put name register* mps))))
+ frame))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 065e150d9..e938fa343 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -1,16 +1,13 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.analyser.lux
(:require (clojure [template :refer [do-template]])
- [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return return* fail fail* |let |list]]
+ (lux [base :as & :refer [|do return return* fail fail* |let |list |case]]
[parser :as &parser]
[type :as &type]
[host :as &host])
@@ -18,334 +15,442 @@
[lambda :as &&lambda]
[case :as &&case]
[env :as &&env]
- [module :as &&module])))
-
-(defn ^:private analyse-1+ [analyse ?token]
- (&type/with-var
- (fn [$var]
- (|do [=expr (&&/analyse-1 analyse $var ?token)]
- (matchv ::M/objects [=expr]
- [[?item ?type]]
- (|do [=type (&type/clean $var ?type)]
- (return (&/T ?item =type)))
- )))))
-
-(defn ^:private with-cursor [cursor form]
- (matchv ::M/objects [form]
- [["lux;Meta" [_ syntax]]]
- (&/V "lux;Meta" (&/T cursor syntax))))
+ [module :as &&module]
+ [record :as &&record])))
+
+;; [Utils]
+(defn ^:private count-univq [type]
+ "(-> Type Int)"
+ (|case type
+ (&/$UnivQ env type*)
+ (inc (count-univq type*))
+
+ _
+ 0))
+
+(defn ^:private next-bound-type [type]
+ "(-> Type Type)"
+ (&type/Bound$ (->> (count-univq type) (* 2) (+ 1))))
+
+(defn ^:private embed-inferred-input [input output]
+ "(-> Type Type Type)"
+ (|case output
+ (&/$UnivQ env output*)
+ (&type/Univ$ env (embed-inferred-input input output*))
+
+ _
+ (&type/Lambda$ input output)))
;; [Exports]
-(defn analyse-tuple [analyse exo-type ?elems]
- (|do [exo-type* (&type/actual-type exo-type)]
- (matchv ::M/objects [exo-type*]
- [["lux;TupleT" ?members]]
- (|do [=elems (&/map2% (fn [elem-t elem]
- (&&/analyse-1 analyse elem-t elem))
- ?members ?elems)]
- (return (&/|list (&/T (&/V "tuple" =elems)
- exo-type))))
-
- [["lux;AllT" _]]
- (&type/with-var
- (fn [$var]
- (|do [exo-type** (&type/apply-type exo-type* $var)]
- (analyse-tuple analyse exo-type** ?elems))))
-
- [_]
- (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))))
-
-(defn analyse-variant [analyse exo-type ident ?value]
- (|do [exo-type* (matchv ::M/objects [exo-type]
- [["lux;VarT" ?id]]
- (&/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))]
- (matchv ::M/objects [exo-type*]
- [["lux;VariantT" ?cases]]
- (|do [?tag (&&/resolved-ident ident)]
- (if-let [vtype (&/|get ?tag ?cases)]
- (|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*)))))
-
- [["lux;AllT" _]]
- (&type/with-var
- (fn [$var]
- (|do [exo-type** (&type/apply-type exo-type* $var)]
- (analyse-variant analyse exo-type** ident ?value))))
+(defn analyse-tuple [analyse ?exo-type ?elems]
+ (|case ?exo-type
+ (&/$Left exo-type)
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (|case exo-type*
+ (&/$UnivQ _)
+ (&type/with-var
+ (fn [$var]
+ (|do [exo-type** (&type/apply-type exo-type* $var)
+ [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems))
+ =var (&type/resolve-type $var)
+ inferred-type (|case =var
+ (&/$VarT iid)
+ (|do [:let [=var* (next-bound-type tuple-type)]
+ _ (&type/set-var iid =var*)
+ tuple-type* (&type/clean $var tuple-type)]
+ (return (&type/Univ$ &/Nil$ tuple-type*)))
+
+ _
+ (&type/clean $var tuple-type))]
+ (return (&/|list (&&/|meta inferred-type tuple-cursor
+ tuple-analysis))))))
+
+ _
+ (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems)))
+
+ (&/$Right exo-type)
+ (|do [unknown? (&type/unknown? exo-type)]
+ (if unknown?
+ (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)]
+ (return =analysis))
+ ?elems)
+ _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$tuple =elems)
+ ))))
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (|case exo-type*
+ (&/$TupleT ?members)
+ (|do [=elems (&/map2% (fn [elem-t elem]
+ (&&/analyse-1 analyse elem-t elem))
+ ?members ?elems)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$tuple =elems)
+ ))))
+
+ (&/$UnivQ _)
+ (|do [$var &type/existential
+ exo-type** (&type/apply-type exo-type* $var)
+ [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))]
+ (return (&/|list (&&/|meta exo-type tuple-cursor
+ tuple-analysis))))
+
+ _
+ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]"))
+ ))))))
+
+(defn with-attempt [m-value on-error]
+ (fn [state]
+ (|case (m-value state)
+ (&/$Left msg)
+ ((on-error msg) state)
- [_]
- (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))
+ output
+ output)))
+
+(defn ^:private analyse-variant-body [analyse exo-type ?values]
+ (|do [output (with-attempt
+ (|case ?values
+ (&/$Nil)
+ (analyse-tuple analyse (&/V &/$Right exo-type) &/Nil$)
+
+ (&/$Cons ?value (&/$Nil))
+ (analyse exo-type ?value)
+
+ _
+ (analyse-tuple analyse (&/V &/$Right exo-type) ?values))
+ (fn [err]
+ (fail (str err "\n"
+ 'analyse-variant-body " " (&type/show-type exo-type)
+ " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))
+ ))]
+ (|case output
+ (&/$Cons x (&/$Nil))
+ (return x)
+
+ _
+ (fail "[Analyser Error] Can't expand to other than 1 element."))))
+
+(defn analyse-variant [analyse ?exo-type idx ?values]
+ (|case ?exo-type
+ (&/$Left exo-type)
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (|case exo-type*
+ (&/$UnivQ _)
+ (&type/with-var
+ (fn [$var]
+ (|do [exo-type** (&type/apply-type exo-type* $var)
+ [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values))
+ =var (&type/resolve-type $var)
+ inferred-type (|case =var
+ (&/$VarT iid)
+ (|do [:let [=var* (next-bound-type variant-type)]
+ _ (&type/set-var iid =var*)
+ variant-type* (&type/clean $var variant-type)]
+ (return (&type/Univ$ &/Nil$ variant-type*)))
+
+ _
+ (&type/clean $var variant-type))]
+ (return (&/|list (&&/|meta inferred-type variant-cursor
+ variant-analysis))))))
+
+ _
+ (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values)))
+
+ (&/$Right exo-type)
+ (|do [exo-type* (|case exo-type
+ (&/$VarT ?id)
+ (&/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))]
+ (|case exo-type*
+ (&/$VariantT ?cases)
+ (|case (&/|at idx ?cases)
+ (&/$Some vtype)
+ (|do [=value (with-attempt
+ (analyse-variant-body analyse vtype ?values)
+ (fn [err]
+ (|do [_exo-type (&type/deref+ exo-type)]
+ (fail (str err "\n"
+ 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type)
+ " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$variant (&/T idx =value))
+ ))))
+
+ (&/$None)
+ (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*))))
+
+ (&/$UnivQ _)
+ (|do [$var &type/existential
+ exo-type** (&type/apply-type exo-type* $var)]
+ (analyse-variant analyse (&/V &/$Right exo-type**) idx ?values))
+
+ _
+ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))))
(defn analyse-record [analyse exo-type ?elems]
- (|do [exo-type* (matchv ::M/objects [exo-type]
- [["lux;VarT" ?id]]
- (|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*]
- [["lux;RecordT" ?table]]
- (return ?table)
-
- [_]
- (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;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)))
- =value (&&/analyse-1 analyse slot-type ?value)]
- (return (&/T ?tag =value)))
-
- [_]
- (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")))
- ?elems)]
- (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type))))))
+ (|do [[rec-members rec-type] (&&record/order-record ?elems)]
+ (|case exo-type
+ (&/$VarT id)
+ (|do [? (&type/bound? id)]
+ (if ?
+ (analyse-tuple analyse (&/V &/$Right exo-type) rec-members)
+ (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members))
+ _ (&type/check exo-type tuple-type)]
+ (return (&/|list (&&/|meta exo-type tuple-cursor
+ tuple-analysis))))))
+
+ _
+ (analyse-tuple analyse (&/V &/$Right exo-type) rec-members)
+ )))
+
+(defn ^:private analyse-global [analyse exo-type module name]
+ (|do [[[r-module r-name] $def] (&&module/find-def module name)
+ endo-type (|case $def
+ (&/$ValueD ?type _)
+ (return ?type)
+
+ (&/$MacroD _)
+ (return &type/Macro)
+
+ (&/$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))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta endo-type _cursor
+ (&/V &&/$var (&/V &/$Global (&/T r-module r-name)))
+ )))))
+
+(defn ^:private analyse-local [analyse exo-type name]
+ (fn [state]
+ (|let [stack (&/get$ &/$envs state)
+ no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not)
+ (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not))
+ [inner outer] (&/|split-with no-binding? stack)]
+ (|case outer
+ (&/$Nil)
+ (&/run-state (|do [module-name &/get-module-name]
+ (analyse-global analyse exo-type module-name name))
+ state)
+
+ (&/$Cons ?genv (&/$Nil))
+ (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))]
+ (|case global
+ [(&/$Global ?module* name*) _]
+ ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*)
+ endo-type (|case $def
+ (&/$ValueD ?type _)
+ (return ?type)
+
+ (&/$MacroD _)
+ (return &type/Macro)
+
+ (&/$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))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta endo-type _cursor
+ (&/V &&/$var (&/V &/$Global (&/T r-module r-name)))
+ ))))
+ state)
+
+ _
+ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))
+ (fail* ""))
+
+ (&/$Cons top-outer _)
+ (|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) name register frame)]
+ (&/T register* (&/Cons$ frame* new-inner))))
+ (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))
+ (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name)))
+ &/Nil$)
+ (&/|reverse inner) scopes)]
+ ((|do [_ (&type/check exo-type (&&/expr-type* =local))]
+ (return (&/|list =local)))
+ (&/set$ &/$envs (&/|++ inner* outer) state)))
+ ))))
(defn analyse-symbol [analyse exo-type ident]
- (|do [module-name &/get-module-name]
- (fn [state]
- (|let [[?module ?name] ident
- ;; _ (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)]
- (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))))
- )))
+ (|do [:let [[?module ?name] ident]]
+ (if (= "" ?module)
+ (analyse-local analyse exo-type ?name)
+ (analyse-global analyse exo-type ?module ?name))
))
(defn ^:private analyse-apply* [analyse exo-type fun-type ?args]
- ;; (prn 'analyse-apply* (aget fun-type 0))
- (matchv ::M/objects [?args]
- [["lux;Nil" _]]
+ (|case ?args
+ (&/$Nil)
(|do [_ (&type/check exo-type fun-type)]
- (return (&/T fun-type (&/|list))))
+ (return (&/T fun-type &/Nil$)))
- [["lux;Cons" [?arg ?args*]]]
+ (&/$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))
+ (|case ?fun-type*
+ (&/$UnivQ _)
(&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]]
+ (|case $var
+ (&/$VarT ?id)
(|do [? (&type/bound? ?id)
type** (if ?
(&type/clean $var =output-t)
- (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _aarg))]
+ (|do [_ (&type/set-var ?id (&/V &/$BoundT 1))]
(&type/clean $var =output-t)))]
(return (&/T type** =args)))
))))
- [["lux;LambdaT" [?input-t ?output-t]]]
+ (&/$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)])
-
- [_]
+ =arg (with-attempt
+ (&&/analyse-1 analyse ?input-t ?arg)
+ (fn [err]
+ (fail (str err "\n"
+ 'analyse-apply* " " (&type/show-type exo-type) " " (&type/show-type ?fun-type*)
+ " " "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))))]
+ (return (&/T =output-t (&/Cons$ =arg =args))))
+
+ _
(fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))))
))
(defn analyse-apply [analyse exo-type form-cursor =fn ?args]
(|do [loader &/loader]
- (matchv ::M/objects [=fn]
- [[=fn-form =fn-type]]
- (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]]
+ (|let [[[=fn-type =fn-cursor] =fn-form] =fn]
+ (|case =fn-form
+ (&&/$var (&/$Global ?module ?name))
+ (|do [[real-name $def] (&&module/find-def ?module ?name)]
+ (|case $def
+ (&/$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*)
+ ;; :let [_ (when (or (= "do" (aget real-name 1))
+ ;; ;; (= "..?" (aget real-name 1))
+ ;; ;; (= "try$" (aget real-name 1))
+ ;; )
+ ;; (->> (&/|map &/show-ast macro-expansion)
;; (&/|interpose "\n")
;; (&/fold str "")
- ;; (prn ?module "case")))]
+ ;; (prn (&/ident->text real-name))))]
]
- (&/flat-map% (partial analyse exo-type) macro-expansion*))
+ (&/flat-map% (partial analyse exo-type) macro-expansion))
- [_]
+ _
(|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
- (return (&/|list (&/T (&/V "apply" (&/T =fn =args))
- =output-t))))))
+ (return (&/|list (&&/|meta =output-t =fn-cursor
+ (&/V &&/$apply (&/T =fn =args))
+ ))))))
- [_]
+ _
(|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
- (return (&/|list (&/T (&/V "apply" (&/T =fn =args))
- =output-t)))))
+ (return (&/|list (&&/|meta =output-t =fn-cursor
+ (&/V &&/$apply (&/T =fn =args))
+ )))))
)))
(defn analyse-case [analyse exo-type ?value ?branches]
(|do [:let [num-branches (&/|length ?branches)]
_ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.")
_ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.")
- =value (analyse-1+ analyse ?value)
- =value-type (&&/expr-type =value)
- =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))]
- (return (&/|list (&/T (&/V "case" (&/T =value =match))
- exo-type)))))
+ =value (&&/analyse-1+ analyse ?value)
+ =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$case (&/T =value =match))
+ )))))
(defn analyse-lambda* [analyse exo-type ?self ?arg ?body]
- (|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*))))))
+ (|case exo-type
+ (&/$VarT id)
+ (|do [? (&type/bound? id)]
+ (if ?
+ (|do [exo-type* (&type/deref id)]
+ (analyse-lambda* analyse exo-type* ?self ?arg ?body))
+ ;; Inference
+ (&type/with-var
+ (fn [$input]
+ (&type/with-var
+ (fn [$output]
+ (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&type/Lambda$ $input $output) ?self ?arg ?body)
+ =input (&type/resolve-type $input)
+ =output (&type/resolve-type $output)
+ inferred-type (|case =input
+ (&/$VarT iid)
+ (|do [:let [=input* (next-bound-type =output)]
+ _ (&type/set-var iid =input*)
+ =output* (&type/clean $input =output)
+ =output** (&type/clean $output =output*)]
+ (return (&type/Univ$ &/Nil$ (embed-inferred-input =input* =output**))))
+
+ _
+ (|do [=output* (&type/clean $input =output)
+ =output** (&type/clean $output =output*)]
+ (return (embed-inferred-input =input =output**))))
+ _ (&type/check exo-type inferred-type)]
+ (return (&&/|meta inferred-type lambda-cursor
+ lambda-analysis)))
+ ))))))
+
+ _
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (|case exo-type
+ (&/$UnivQ _)
+ (|do [$var &type/existential
+ exo-type** (&type/apply-type exo-type* $var)]
+ (analyse-lambda* analyse exo-type** ?self ?arg ?body))
+
+ (&/$LambdaT ?arg-t ?return-t)
+ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type*
+ ?arg ?arg-t
+ (&&/analyse-1 analyse ?return-t ?body))
+ _cursor &/cursor]
+ (return (&&/|meta exo-type* _cursor
+ (&/V &&/$lambda (&/T =scope =captured =body)))))
+
+
+
+ _
+ (fail (str "[Analyser Error] Functions require function types: "
+ (&type/show-type exo-type*)))))
+ ))
(defn analyse-lambda** [analyse exo-type ?self ?arg ?body]
- (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)
- [_expr _] (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)
- ;; 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))))))))
+ (|case exo-type
+ (&/$UnivQ _)
+ (|do [$var &type/existential
+ exo-type* (&type/apply-type exo-type $var)
+ [_ _expr] (analyse-lambda** analyse exo-type* ?self ?arg ?body)
+ _cursor &/cursor]
+ (return (&&/|meta exo-type _cursor _expr)))
+
+ (&/$VarT id)
+ (|do [? (&type/bound? id)]
+ (if ?
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (analyse-lambda* analyse exo-type* ?self ?arg ?body))
+ ;; Inference
+ (analyse-lambda* analyse exo-type ?self ?arg ?body)))
- [_]
+ _
(|do [exo-type* (&type/actual-type exo-type)]
(analyse-lambda* analyse exo-type* ?self ?arg ?body))
))
@@ -354,75 +459,80 @@
(|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)]
(return (&/|list output))))
-(defn analyse-def [analyse ?name ?value]
- ;; (prn 'analyse-def/BEGIN ?name)
+(defn analyse-def [analyse compile-token ?name ?value]
(|do [module-name &/get-module-name
? (&&module/defined? module-name ?name)]
(if ?
(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)]
- (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)]
- ]
- (return (&/|list)))
-
- [_]
- (|do [=value-type (&&/expr-type =value)
- :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)
-
- :else
- (&/V "lux;ValueD" =value-type))]
- _ (&&module/define module-name ?name def-data =value-type)]
- (return (&/|list (&/V "def" (&/T ?name =value def-data))))))
+ (&&/analyse-1+ analyse ?value))]
+ (|case =value
+ [_ (&&/$var (&/$Global ?r-module ?r-name))]
+ (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value))]
+ (return &/Nil$))
+
+ _
+ (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
+ :let [[[def-type def-cursor] def-analysis] =value
+ _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type)
+ )]]
+ (return &/Nil$)))
))))
-(defn analyse-declare-macro [analyse ?name]
- (|do [module-name &/get-module-name]
- (return (&/|list (&/V "declare-macro" (&/T module-name ?name))))))
+(defn analyse-declare-macro [analyse compile-token ?name]
+ (|do [module-name &/get-module-name
+ _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))]
+ (return &/Nil$)))
+
+(defn analyse-declare-tags [tags type-name]
+ (|do [module-name &/get-module-name
+ [_ def-data] (&&module/find-def module-name type-name)
+ def-type (&&module/ensure-type-def def-data)
+ _ (&&module/declare-tags module-name tags def-type)]
+ (return &/Nil$)))
-(defn analyse-import [analyse compile-module ?path]
+(defn analyse-import [analyse compile-module compile-token path]
(|do [module-name &/get-module-name
- _ (if (= module-name ?path)
- (fail (str "[Analyser Error] Module can't import itself: " ?path))
+ _ (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 [already-compiled? (&&module/exists? path)
+ active? (&/active-module? path)
+ _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name))
+ _ (&&module/add-import path)
+ _ (if (not already-compiled?)
+ (compile-module path)
+ (return nil))]
+ (return &/Nil$)))))
+
+(defn analyse-export [analyse compile-token name]
(|do [module-name &/get-module-name
_ (&&module/export module-name name)]
- (return (&/|list))))
+ (return &/Nil$)))
-(defn analyse-alias [analyse ex-alias ex-module]
+(defn analyse-alias [analyse compile-token ex-alias ex-module]
(|do [module-name &/get-module-name
_ (&&module/alias module-name ex-alias ex-module)]
- (return (&/|list))))
+ (return &/Nil$)))
(defn analyse-check [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)]
- (return (&/|list (&/T (&/V "ann" (&/T =value =type))
- ==type)))))
+ =value (&&/analyse-1 analyse ==type ?value)
+ _cursor &/cursor
+ ]
+ (return (&/|list (&&/|meta ==type _cursor
+ (&/V &&/$ann (&/T =value =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)]
- (return (&/|list (&/T (&/V "ann" (&/T =value =type))
- ==type)))))
+ =value (&&/analyse-1+ analyse ?value)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta ==type _cursor
+ (&/V &&/$ann (&/T =value =type))
+ )))))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 68cdc4747..192e80153 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -1,32 +1,37 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.analyser.module
(:refer-clojure :exclude [alias])
- (:require [clojure.string :as string]
- [clojure.core.match :as M :refer [matchv]]
+ (:require (clojure [string :as string]
+ [template :refer [do-template]])
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|let |do return return* fail fail*]]
+ (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]]
[type :as &type]
- [host :as &host])
- [lux.analyser.base :as &&]))
+ [host :as &host])))
;; [Utils]
-(def ^:private $DEFS 0)
-(def ^:private $ALIASES 1)
-(def ^:private $IMPORTS 2)
+(deftags
+ ["module-aliases"
+ "defs"
+ "imports"
+ "tags"
+ "types"])
+
(def ^:private +init+
- (&/R ;; "lux;defs"
+ (&/T ;; "lux;module-aliases"
(&/|table)
- ;; "lux;module-aliases"
+ ;; "lux;defs"
(&/|table)
;; "lux;imports"
- (&/|list)
+ &/Nil$
+ ;; "lux;tags"
+ (&/|table)
+ ;; "lux;types"
+ (&/|table)
))
;; [Exports]
@@ -34,121 +39,154 @@
"(-> Text (Lux (,)))"
(|do [current-module &/get-module-name]
(fn [state]
- (return* (&/update$ &/$MODULES
+ (return* (&/update$ &/$modules
+ (fn [ms]
+ (&/|update current-module
+ (fn [m] (&/update$ $imports (partial &/Cons$ module) m))
+ ms))
+ state)
+ nil))))
+
+(defn set-imports [imports]
+ "(-> (List 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))
+ (fn [m] (&/set$ $imports imports m))
ms))
state)
nil))))
-(defn define [module name def-data type]
+(defn define [module name ^objects def-data type]
(fn [state]
- (matchv ::M/objects [(&/get$ &/$ENVS state)]
- [["lux;Cons" [?env ["lux;Nil" _]]]]
+ (when (and (= "Macro" name) (= "lux" module))
+ (&type/set-macro-type! (aget def-data 1)))
+ (|case (&/get$ &/$envs state)
+ (&/$Cons ?env (&/$Nil))
(return* (->> state
- (&/update$ &/$MODULES
+ (&/update$ &/$modules
(fn [ms]
(&/|update module
(fn [m]
- (&/update$ $DEFS
+ (&/update$ $defs
#(&/|put name (&/T false def-data) %)
m))
ms))))
nil)
- [_]
+ _
(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" _]]]
+ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
+ (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
+ (|case $def
+ [_ (&/$TypeD _)]
(return* state &type/Type)
- [[_ ["lux;MacroD" _]]]
+ [_ (&/$MacroD _)]
(return* state &type/Macro)
- [[_ ["lux;ValueD" _type]]]
+ [_ (&/$ValueD _type _)]
(return* state _type)
- [[_ ["lux;AliasD" [?r-module ?r-name]]]]
+ [_ (&/$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 type-def [module name]
+ "(-> Text Text (Lux Type))"
+ (fn [state]
+ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
+ (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
+ (|case $def
+ [_ (&/$TypeD _type)]
+ (return* state _type)
+
+ _
+ (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name)))))
+ (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T 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]
- (matchv ::M/objects [(&/get$ &/$ENVS state)]
- [["lux;Cons" [?env ["lux;Nil" _]]]]
+ (|case (&/get$ &/$envs state)
+ (&/$Cons ?env (&/$Nil))
(return* (->> state
- (&/update$ &/$MODULES
+ (&/update$ &/$modules
(fn [ms]
(&/|update a-module
(fn [m]
- (&/update$ $DEFS
- #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %)
+ (&/update$ $defs
+ #(&/|put a-name (&/T false (&/V &/$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]
(return* state
- (->> state (&/get$ &/$MODULES) (&/|contains? name)))))
-
-(defn alias [module alias reference]
- (fn [state]
- (return* (->> state
- (&/update$ &/$MODULES
- (fn [ms]
- (&/|update module
- #(&/update$ $ALIASES
- (fn [aliases]
- (&/|put alias reference aliases))
- %)
- ms))))
- nil)))
+ (->> state (&/get$ &/$modules) (&/|contains? name)))))
(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))]
+ (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))]
(return* state real-name)
(fail* (str "Unknown alias: " name))))))
+(defn alias [module alias reference]
+ (fn [state]
+ (if-let [real-name (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $module-aliases) (&/|get alias))]
+ (fail* (str "Can't re-use alias \"" alias "\" @ " module))
+ (return* (->> state
+ (&/update$ &/$modules
+ (fn [ms]
+ (&/|update module
+ #(&/update$ $module-aliases
+ (fn [aliases]
+ (&/|put alias reference aliases))
+ %)
+ ms))))
+ nil))))
+
(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))]
- (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)))))
+ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
+ (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
+ (|let [[exported? $$def] $def]
+ (if (or exported? (.equals ^Object current-module module))
+ (|case $$def
+ (&/$AliasD ?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 ensure-type-def [def-data]
+ "(-> DefData (Lux Type))"
+ (|case def-data
+ (&/$TypeD type)
+ (return type)
+
+ _
+ (fail (str "[Analyser Error] Not a type definition: " (&/adt->text def-data)))))
+
(defn defined? [module name]
(&/try-all% (&/|list (|do [_ (find-def module name)]
(return true))
@@ -156,57 +194,57 @@
(defn declare-macro [module name]
(fn [state]
- (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))]
+ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))]
(if-let [$def (&/|get name $module)]
- (matchv ::M/objects [$def]
- [[exported? ["lux;ValueD" ?type]]]
+ (|case $def
+ [exported? (&/$ValueD ?type _)]
((|do [_ (&type/check &type/Macro ?type)
^ClassLoader loader &/loader
- :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name)))
- (.getField "_datum")
+ :let [macro (-> (.loadClass loader (str (&host/->class-name module) "." (&/normalize-name name)))
+ (.getField &/datum-field)
(.get nil))]]
(fn [state*]
- (return* (&/update$ &/$MODULES
+ (return* (&/update$ &/$modules
(fn [$modules]
(&/|update module
(fn [m]
- (&/update$ $DEFS
- #(&/|put name (&/T exported? (&/V "lux;MacroD" macro)) %)
+ (&/update$ $defs
+ #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %)
m))
$modules))
state*)
nil)))
state)
- [[_ ["lux;MacroD" _]]]
+ [_ (&/$MacroD _)]
(fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name)))
- [[_ ["lux;TypeD" _]]]
+ [_ _]
(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$ $DEFS) (&/|get name))]
- (matchv ::M/objects [$def]
- [[true _]]
+ (|case (&/get$ &/$envs state)
+ (&/$Cons ?env (&/$Nil))
+ (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))]
+ (|case $def
+ [true _]
(fail* (str "[Analyser Error] Definition has already been exported: " module ";" name))
- [[false ?data]]
+ [false ?data]
(return* (->> state
- (&/update$ &/$MODULES (fn [ms]
+ (&/update$ &/$modules (fn [ms]
(&/|update module (fn [m]
- (&/update$ $DEFS
+ (&/update$ $defs
#(&/|put name (&/T true ?data) %)
m))
ms))))
nil))
(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
@@ -214,36 +252,104 @@
(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)))))))
+ (|let [[k [?exported? ?def]] kv]
+ (do ;; (prn 'defs k ?exported?)
+ (|case ?def
+ (&/$AliasD ?r-module ?r-name)
+ (&/T ?exported? k (str "A" ?r-module ";" ?r-name))
+
+ (&/$MacroD _)
+ (&/T ?exported? k "M")
+
+ (&/$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))))))
+ (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports))))))
(defn create-module [name]
+ "(-> Text (Lux (,)))"
(fn [state]
- (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil)))
+ (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil)))
(defn enter-module [name]
+ "(-> Text (Lux (,)))"
(fn [state]
(return* (->> state
- (&/update$ &/$MODULES #(&/|put name +init+ %))
- (&/set$ &/$ENVS (&/|list (&/env name))))
+ (&/update$ &/$modules #(&/|put name +init+ %))
+ (&/set$ &/$envs (&/|list (&/env name))))
nil)))
+
+(do-template [<name> <tag> <type>]
+ (defn <name> [module]
+ <type>
+ (fn [state]
+ (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
+ (return* state (&/get$ <tag> =module))
+ (fail* (str "[Lux Error] Unknown module: " module)))
+ ))
+
+ tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))"
+ types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))"
+ )
+
+(defn ensure-undeclared-tags [module tags]
+ (|do [tags-table (tags-by-module module)
+ _ (&/map% (fn [tag]
+ (if (&/|get tag tags-table)
+ (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag))))
+ (return nil)))
+ tags)]
+ (return nil)))
+
+(defn ensure-undeclared-type [module name]
+ (|do [types-table (types-by-module module)
+ _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))]
+ (return nil)))
+
+(defn declare-tags [module tag-names type]
+ "(-> Text (List Text) Type (Lux (,)))"
+ (|do [_ (ensure-undeclared-tags module tag-names)
+ type-name (&type/type-name type)
+ :let [[_module _name] type-name]
+ _ (&/assert! (= module _module)
+ (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name)))
+ _ (ensure-undeclared-type _module _name)]
+ (fn [state]
+ (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
+ (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)]
+ (return* (&/update$ &/$modules
+ (fn [=modules]
+ (&/|update module
+ #(->> %
+ (&/set$ $tags (&/fold (fn [table idx+tag-name]
+ (|let [[idx tag-name] idx+tag-name]
+ (&/|put tag-name (&/T idx tags type) table)))
+ (&/get$ $tags %)
+ (&/enumerate tag-names)))
+ (&/update$ $types (partial &/|put _name (&/T tags type))))
+ =modules))
+ state)
+ nil))
+ (fail* (str "[Lux Error] Unknown module: " module))))))
+
+(do-template [<name> <idx> <doc>]
+ (defn <name> [module tag-name]
+ <doc>
+ (fn [state]
+ (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
+ (if-let [^objects idx+tags+type (&/|get tag-name (&/get$ $tags =module))]
+ (return* state (aget idx+tags+type <idx>))
+ (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name)))))
+ (fail* (str "[Module Error] Unknown module: " module)))))
+
+ tag-index 0 "(-> Text Text (Lux Int))"
+ tag-group 1 "(-> Text Text (Lux (List Ident)))"
+ tag-type 2 "(-> Text Text (Lux Type))"
+ )
diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj
new file mode 100644
index 000000000..ddc9616fd
--- /dev/null
+++ b/src/lux/analyser/record.clj
@@ -0,0 +1,43 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns lux.analyser.record
+ (:require clojure.core.match
+ clojure.core.match.array
+ (lux [base :as & :refer [deftags |let |do return fail |case]]
+ [type :as &type])
+ (lux.analyser [base :as &&]
+ [module :as &&module])))
+
+;; [Exports]
+(defn order-record [pairs]
+ "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))"
+ (|do [[tag-group tag-type] (|case pairs
+ (&/$Nil)
+ (return (&/T &/Nil$ &type/Unit))
+
+ (&/$Cons [[_ (&/$TagS tag1)] _] _)
+ (|do [[module name] (&&/resolved-ident tag1)
+ tags (&&module/tag-group module name)
+ type (&&module/tag-type module name)]
+ (return (&/T tags type)))
+
+ _
+ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))
+ =pairs (&/map% (fn [kv]
+ (|case kv
+ [[_ (&/$TagS k)] v]
+ (|do [=k (&&/resolved-ident k)]
+ (return (&/T (&/ident->text =k) v)))
+
+ _
+ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")))
+ pairs)
+ =members (&/map% (fn [tag]
+ (if-let [member (&/|get tag =pairs)]
+ (return member)
+ (fail (str "[Analyser Error] Unknown tag: " tag))))
+ (&/|map &/ident->text tag-group))]
+ (return (&/T =members tag-type))))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index eb94c2c90..e9b8896bf 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -1,52 +1,139 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.base
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array))
-;; [Fields]
+;; [Tags]
+(defmacro deftags [names]
+ (assert (vector? names))
+ `(do ~@(for [[name idx] (map vector names (range (count names)))]
+ `(def ~(symbol (str "$" name)) ~idx))))
+
+;; List
+(deftags
+ ["Nil"
+ "Cons"])
+
+;; Maybe
+(deftags
+ ["None"
+ "Some"])
+
+;; Either
+(deftags
+ ["Left"
+ "Right"])
+
+;; AST
+(deftags
+ ["BoolS"
+ "IntS"
+ "RealS"
+ "CharS"
+ "TextS"
+ "SymbolS"
+ "TagS"
+ "FormS"
+ "TupleS"
+ "RecordS"])
+
+;; Type
+(deftags
+ ["DataT"
+ "VariantT"
+ "TupleT"
+ "LambdaT"
+ "BoundT"
+ "VarT"
+ "ExT"
+ "UnivQ"
+ "ExQ"
+ "AppT"
+ "NamedT"])
+
+;; Vars
+(deftags
+ ["Local"
+ "Global"])
+
+;; Definitions
+(deftags
+ ["ValueD"
+ "TypeD"
+ "MacroD"
+ "AliasD"])
+
;; Binding
-(def $COUNTER 0)
-(def $MAPPINGS 1)
+(deftags
+ ["counter"
+ "mappings"])
;; Env
-(def $CLOSURE 0)
-(def $INNER-CLOSURES 1)
-(def $LOCALS 2)
-(def $NAME 3)
+(deftags
+ ["name"
+ "inner-closures"
+ "locals"
+ "closure"])
+
+;; ModuleState
+(deftags
+ ["Active"
+ "Compiled"
+ "Cached"])
;; Host
-(def $CLASSES 0)
-(def $LOADER 1)
-(def $WRITER 2)
-
-;; CompilerState
-(def $ENVS 0)
-(def $EVAL? 1)
-(def $HOST 2)
-(def $MODULES 3)
-(def $SEED 4)
-(def $SOURCE 5)
-(def $TYPES 6)
+(deftags
+ ["writer"
+ "loader"
+ "classes"
+ "catching"
+ "module-states"])
+
+;; Compiler
+(deftags
+ ["source"
+ "cursor"
+ "modules"
+ "envs"
+ "type-vars"
+ "expected"
+ "seed"
+ "eval?"
+ "host"])
;; [Exports]
+(def datum-field "_datum")
+(def meta-field "_meta")
+(def name-field "_name")
+(def hash-field "_hash")
+(def compiler-field "_compiler")
+(def imports-field "_imports")
+(def defs-field "_defs")
+(def eval-field "_eval")
+(def tags-field "_tags")
+(def module-class-name "_")
(def +name-separator+ ";")
+(def lib-dir "lib")
(defn T [& elems]
(to-array elems))
-(defn V [tag value]
+(defn V [^Long tag value]
(to-array [tag value]))
-(defn R [& kvs]
- (to-array kvs))
+;; Constructors
+(def None$ (V $None nil))
+(defn Some$ [x] (V $Some x))
+
+(def Nil$ (V $Nil nil))
+(defn Cons$ [h t] (V $Cons (T h t)))
+
+(def empty-cursor (T "" -1 -1))
(defn get$ [slot ^objects record]
(aget record slot))
@@ -63,104 +150,128 @@
record#)))
(defn fail* [message]
- (V "lux;Left" message))
+ (V $Left message))
(defn return* [state value]
- (V "lux;Right" (T state value)))
+ (V $Right (T state value)))
+
+(defn transform-pattern [pattern]
+ (cond (vector? pattern) (mapv transform-pattern pattern)
+ (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))]
+ (vec (cons (eval (first pattern))
+ (list (case (count parts)
+ 0 '_
+ 1 (first parts)
+ ;; else
+ `[~@parts])))))
+ :else pattern
+ ))
+
+(defmacro |case [value & branches]
+ (assert (= 0 (mod (count branches) 2)))
+ (let [value* (if (vector? value)
+ [`(T ~@value)]
+ [value])]
+ `(matchv ::M/objects ~value*
+ ~@(mapcat (fn [[pattern body]]
+ (list [(transform-pattern pattern)]
+ body))
+ (partition 2 branches)))))
(defmacro |let [bindings body]
(reduce (fn [inner [left right]]
- `(matchv ::M/objects [~right]
- [~left]
+ `(|case ~right
+ ~left
~inner))
body
(reverse (partition 2 bindings))))
(defmacro |list [& elems]
(reduce (fn [tail head]
- `(V "lux;Cons" (T ~head ~tail)))
- `(V "lux;Nil" nil)
+ `(V $Cons (T ~head ~tail)))
+ `Nil$
(reverse elems)))
(defmacro |table [& elems]
(reduce (fn [table [k v]]
`(|put ~k ~v ~table))
- `(|list)
+ `Nil$
(reverse (partition 2 elems))))
(defn |get [slot table]
- (matchv ::M/objects [table]
- [["lux;Nil" _]]
+ (|case table
+ ($Nil)
nil
- [["lux;Cons" [[k v] table*]]]
+ ($Cons [k v] table*)
(if (.equals ^Object k slot)
v
(|get slot table*))))
(defn |put [slot value table]
- (matchv ::M/objects [table]
- [["lux;Nil" _]]
- (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil)))
+ (|case table
+ ($Nil)
+ (V $Cons (T (T slot value) Nil$))
- [["lux;Cons" [[k v] table*]]]
+ ($Cons [k v] table*)
(if (.equals ^Object k slot)
- (V "lux;Cons" (T (T slot value) table*))
- (V "lux;Cons" (T (T k v) (|put slot value table*))))))
+ (V $Cons (T (T slot value) table*))
+ (V $Cons (T (T k v) (|put slot value table*))))
+ ))
(defn |remove [slot table]
- (matchv ::M/objects [table]
- [["lux;Nil" _]]
+ (|case table
+ ($Nil)
table
- [["lux;Cons" [[k v] table*]]]
+ ($Cons [k v] table*)
(if (.equals ^Object k slot)
table*
- (V "lux;Cons" (T (T k v) (|remove slot table*))))))
+ (V $Cons (T (T k v) (|remove slot table*))))))
(defn |update [k f table]
- (matchv ::M/objects [table]
- [["lux;Nil" _]]
+ (|case table
+ ($Nil)
table
- [["lux;Cons" [[k* v] table*]]]
+ ($Cons [k* v] table*)
(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*))))))
+ (V $Cons (T (T k* (f v)) table*))
+ (V $Cons (T (T k* v) (|update k f table*))))))
(defn |head [xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
- (assert false)
+ (|case xs
+ ($Nil)
+ (assert false (prn-str '|head))
- [["lux;Cons" [x _]]]
+ ($Cons x _)
x))
(defn |tail [xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
- (assert false)
+ (|case xs
+ ($Nil)
+ (assert false (prn-str '|tail))
- [["lux;Cons" [_ xs*]]]
+ ($Cons _ xs*)
xs*))
;; [Resources/Monads]
(defn fail [message]
(fn [_]
- (V "lux;Left" message)))
+ (V $Left message)))
(defn return [value]
(fn [state]
- (V "lux;Right" (T state value))))
+ (V $Right (T state value))))
(defn bind [m-value step]
(fn [state]
(let [inputs (m-value state)]
- (matchv ::M/objects [inputs]
- [["lux;Right" [?state ?datum]]]
+ (|case inputs
+ ($Right ?state ?datum)
((step ?datum) ?state)
- [["lux;Left" _]]
+ ($Left _)
inputs
))))
@@ -172,110 +283,125 @@
;; else
`(bind ~computation
(fn [val#]
- (matchv ::M/objects [val#]
- [~label]
+ (|case val#
+ ~label
~inner)))))
return
(reverse (partition 2 steps))))
;; [Resources/Combinators]
-(defn |cons [head tail]
- (V "lux;Cons" (T head tail)))
-
(defn |++ [xs ys]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
ys
- [["lux;Cons" [x xs*]]]
- (V "lux;Cons" (T x (|++ xs* ys)))))
+ ($Cons x xs*)
+ (V $Cons (T x (|++ xs* ys)))))
+
+(let [array-class (class (to-array []))]
+ (defn adt->text [adt]
+ (if (= array-class (class adt))
+ (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]")
+ (pr-str adt))))
(defn |map [f xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
xs
- [["lux;Cons" [x xs*]]]
- (V "lux;Cons" (T (f x) (|map f xs*)))))
+ ($Cons x xs*)
+ (V $Cons (T (f x) (|map f xs*)))
+
+ _
+ (assert false (prn-str '|map f (adt->text xs)))
+ ))
(defn |empty? [xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
true
- [["lux;Cons" [_ _]]]
+ ($Cons _ _)
false))
(defn |filter [p xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
xs
- [["lux;Cons" [x xs*]]]
+ ($Cons x xs*)
(if (p x)
- (V "lux;Cons" (T x (|filter p xs*)))
+ (V $Cons (T x (|filter p xs*)))
(|filter p xs*))))
(defn flat-map [f xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
xs
- [["lux;Cons" [x xs*]]]
+ ($Cons x xs*)
(|++ (f x) (flat-map f xs*))))
(defn |split-with [p xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
(T xs xs)
- [["lux;Cons" [x xs*]]]
+ ($Cons x xs*)
(if (p x)
(|let [[pre post] (|split-with p xs*)]
- (T (|cons x pre) post))
- (T (V "lux;Nil" nil) xs))))
+ (T (Cons$ x pre) post))
+ (T Nil$ xs))))
(defn |contains? [k table]
- (matchv ::M/objects [table]
- [["lux;Nil" _]]
+ (|case table
+ ($Nil)
false
- [["lux;Cons" [[k* _] table*]]]
+ ($Cons [k* _] table*)
(or (.equals ^Object k k*)
(|contains? k table*))))
+(defn |member? [x xs]
+ (|case xs
+ ($Nil)
+ false
+
+ ($Cons x* xs*)
+ (or (= x x*) (|member? x xs*))))
+
(defn fold [f init xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
init
- [["lux;Cons" [x xs*]]]
- (fold f (f init x) xs*)))
+ ($Cons x xs*)
+ (recur f (f init x) xs*)))
(defn fold% [f init xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
(return init)
- [["lux;Cons" [x xs*]]]
+ ($Cons x xs*)
(|do [init* (f init x)]
(fold% f init* xs*))))
(defn folds [f init xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
(|list init)
- [["lux;Cons" [x xs*]]]
- (|cons init (folds f (f init x) xs*))))
+ ($Cons x xs*)
+ (Cons$ init (folds f (f init x) xs*))))
(defn |length [xs]
(fold (fn [acc _] (inc acc)) 0 xs))
(let [|range* (fn |range* [from to]
(if (< from to)
- (V "lux;Cons" (T from (|range* (inc from) to)))
- (V "lux;Nil" nil)))]
+ (V $Cons (T from (|range* (inc from) to)))
+ Nil$))]
(defn |range [n]
(|range* 0 n)))
@@ -288,69 +414,69 @@
_2))
(defn zip2 [xs ys]
- (matchv ::M/objects [xs ys]
- [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
- (V "lux;Cons" (T (T x y) (zip2 xs* ys*)))
+ (|case [xs ys]
+ [($Cons x xs*) ($Cons y ys*)]
+ (V $Cons (T (T x y) (zip2 xs* ys*)))
[_ _]
- (V "lux;Nil" nil)))
+ Nil$))
(defn |keys [plist]
- (matchv ::M/objects [plist]
- [["lux;Nil" _]]
- (|list)
+ (|case plist
+ ($Nil)
+ Nil$
- [["lux;Cons" [[k v] plist*]]]
- (|cons k (|keys plist*))))
+ ($Cons [k v] plist*)
+ (Cons$ k (|keys plist*))))
(defn |vals [plist]
- (matchv ::M/objects [plist]
- [["lux;Nil" _]]
- (|list)
+ (|case plist
+ ($Nil)
+ Nil$
- [["lux;Cons" [[k v] plist*]]]
- (|cons v (|vals plist*))))
+ ($Cons [k v] plist*)
+ (Cons$ v (|vals plist*))))
(defn |interpose [sep xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
xs
- [["lux;Cons" [_ ["lux;Nil" _]]]]
+ ($Cons _ ($Nil))
xs
- [["lux;Cons" [x xs*]]]
- (V "lux;Cons" (T x (V "lux;Cons" (T sep (|interpose sep xs*)))))))
+ ($Cons x xs*)
+ (V $Cons (T x (V $Cons (T sep (|interpose sep xs*)))))))
(do-template [<name> <joiner>]
(defn <name> [f xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
(return xs)
- [["lux;Cons" [x xs*]]]
+ ($Cons x xs*)
(|do [y (f x)
ys (<name> f xs*)]
(return (<joiner> y ys)))))
- map% |cons
+ map% Cons$
flat-map% |++)
(defn list-join [xss]
- (fold |++ (V "lux;Nil" nil) xss))
+ (fold |++ Nil$ xss))
(defn |as-pairs [xs]
- (matchv ::M/objects [xs]
- [["lux;Cons" [x ["lux;Cons" [y xs*]]]]]
- (V "lux;Cons" (T (T x y) (|as-pairs xs*)))
+ (|case xs
+ ($Cons x ($Cons y xs*))
+ (V $Cons (T (T x y) (|as-pairs xs*)))
- [_]
- (V "lux;Nil" nil)))
+ _
+ Nil$))
(defn |reverse [xs]
(fold (fn [tail head]
- (|cons head tail))
- (|list)
+ (Cons$ head tail))
+ Nil$
xs))
(defn assert! [test message]
@@ -363,18 +489,18 @@
(return* state state)))
(defn try-all% [monads]
- (matchv ::M/objects [monads]
- [["lux;Nil" _]]
+ (|case monads
+ ($Nil)
(fail "There are no alternatives to try!")
- [["lux;Cons" [m monads*]]]
+ ($Cons m monads*)
(fn [state]
(let [output (m state)]
- (matchv ::M/objects [output monads*]
- [["lux;Right" _] _]
+ (|case [output monads*]
+ [($Right _) _]
output
- [_ ["lux;Nil" _]]
+ [_ ($Nil)]
output
[_ _]
@@ -385,16 +511,16 @@
(defn repeat% [monad]
(try-all% (|list (|do [head monad
tail (repeat% monad)]
- (return (|cons head tail)))
- (return (|list)))))
+ (return (Cons$ head tail)))
+ (return Nil$))))
(defn exhaust% [step]
(fn [state]
- (matchv ::M/objects [(step state)]
- [["lux;Right" [state* _]]]
+ (|case (step state)
+ ($Right state* _)
((exhaust% step) state*)
- [["lux;Left" msg]]
+ ($Left msg)
(if (.equals "[Reader Error] EOF" msg)
(return* state nil)
(fail* msg)))))
@@ -432,27 +558,27 @@
(def loader
(fn [state]
- (return* state (->> state (get$ $HOST) (get$ $LOADER)))))
+ (return* state (->> state (get$ $host) (get$ $loader)))))
(def classes
(fn [state]
- (return* state (->> state (get$ $HOST) (get$ $CLASSES)))))
+ (return* state (->> state (get$ $host) (get$ $classes)))))
(def +init-bindings+
- (R ;; "lux;counter"
+ (T ;; "lux;counter"
0
;; "lux;mappings"
(|table)))
(defn env [name]
- (R ;; "lux;closure"
- +init-bindings+
+ (T ;; "lux;name"
+ name
;; "lux;inner-closures"
0
;; "lux;locals"
+init-bindings+
- ;; "lux;name"
- name
+ ;; "lux;closure"
+ +init-bindings+
))
(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String
@@ -469,118 +595,147 @@
(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))
+ (prn 'memory-class-loader/findClass class-name (get @store class-name))
(throw e)))
(do (prn 'memory-class-loader/store class-name (keys @store))
(throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))))
+
+;; (deftype Host
+;; (& #writer (^ org.objectweb.asm.ClassWriter)
+;; #loader (^ java.net.URLClassLoader)
+;; #classes (^ clojure.lang.Atom)
+;; #catching (List Text)
+;; #module-states (List (, Text ModuleState))))
(defn host [_]
(let [store (atom {})]
- (R ;; "lux;classes"
- store
+ (T ;; "lux;writer"
+ (V $None nil)
;; "lux;loader"
(memory-class-loader store)
- ;; "lux;writer"
- (V "lux;None" nil))))
+ ;; "lux;classes"
+ store
+ ;; "lux;catching"
+ Nil$
+ ;; "lux;module-states"
+ (|table)
+ )))
(defn init-state [_]
- (R ;; "lux;envs"
- (|list)
- ;; "lux;eval?"
- false
- ;; "lux;host"
- (host nil)
+ (T ;; "lux;source"
+ (V $None nil)
+ ;; "lux;cursor"
+ (T "" -1 -1)
;; "lux;modules"
(|table)
- ;; "lux;seed"
- 0
- ;; "lux;source"
- (V "lux;None" nil)
+ ;; "lux;envs"
+ Nil$
;; "lux;types"
+init-bindings+
+ ;; "lux;expected"
+ (V $VariantT Nil$)
+ ;; "lux;seed"
+ 0
+ ;; "lux;eval?"
+ false
+ ;; "lux;host"
+ (host nil)
))
(defn save-module [body]
(fn [state]
- (matchv ::M/objects [(body state)]
- [["lux;Right" [state* output]]]
+ (|case (body state)
+ ($Right state* output)
(return* (->> state*
- (set$ $ENVS (get$ $ENVS state))
- (set$ $SOURCE (get$ $SOURCE state)))
+ (set$ $envs (get$ $envs state))
+ (set$ $source (get$ $source state)))
output)
- [["lux;Left" msg]]
+ ($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)
+ (|case (body (set$ $eval? true state))
+ ($Right state* output)
+ (return* (set$ $eval? (get$ $eval? state) state*) output)
- [["lux;Left" msg]]
+ ($Left msg)
(fail* msg))))
(def get-eval
(fn [state]
- (return* state (get$ $EVAL? state))))
+ (return* state (get$ $eval? state))))
(def get-writer
(fn [state]
- (let [writer* (->> state (get$ $HOST) (get$ $WRITER))]
- (matchv ::M/objects [writer*]
- [["lux;Some" datum]]
+ (let [writer* (->> state (get$ $host) (get$ $writer))]
+ (|case writer*
+ ($Some datum)
(return* state datum)
- [_]
+ _
(fail* "Writer hasn't been set.")))))
(def get-top-local-env
(fn [state]
- (try (let [top (|head (get$ $ENVS state))]
+ (try (let [top (|head (get$ $envs state))]
(return* state top))
(catch Throwable _
(fail* "No local environment.")))))
(def gen-id
(fn [state]
- (let [seed (get$ $SEED state)]
- (return* (set$ $SEED (inc seed) state) seed))))
+ (let [seed (get$ $seed state)]
+ (return* (set$ $seed (inc seed) state) seed))))
(defn ->seq [xs]
- (matchv ::M/objects [xs]
- [["lux;Nil" _]]
+ (|case xs
+ ($Nil)
(list)
- [["lux;Cons" [x xs*]]]
+ ($Cons x xs*)
(cons x (->seq xs*))))
(defn ->list [seq]
(if (empty? seq)
- (|list)
- (|cons (first seq) (->list (rest seq)))))
+ Nil$
+ (Cons$ (first seq) (->list (rest seq)))))
(defn |repeat [n x]
(if (> n 0)
- (|cons x (|repeat (dec n) x))
- (|list)))
+ (Cons$ x (|repeat (dec n) x))
+ Nil$))
(def get-module-name
(fn [state]
- (matchv ::M/objects [(|reverse (get$ $ENVS state))]
- [["lux;Nil"]]
+ (|case (|reverse (get$ $envs state))
+ ($Nil)
(fail* "[Analyser Error] Can't get the module-name without a module.")
- [["lux;Cons" [?global _]]]
- (return* state (get$ $NAME ?global)))))
+ ($Cons ?global _)
+ (return* state (get$ $name ?global)))))
+
+(defn find-module [name]
+ "(-> Text (Lux (Module Compiler)))"
+ (fn [state]
+ (if-let [module (|get name (get$ $modules state))]
+ (return* state module)
+ (fail* (str "Unknown module: " name)))))
+
+(def get-current-module
+ "(Lux (Module Compiler))"
+ (|do [module-name get-module-name]
+ (find-module module-name)))
(defn with-scope [name body]
(fn [state]
- (let [output (body (update$ $ENVS #(|cons (env name) %) state))]
- (matchv ::M/objects [output]
- [["lux;Right" [state* datum]]]
- (return* (update$ $ENVS |tail state*) datum)
+ (let [output (body (update$ $envs #(Cons$ (env name) %) state))]
+ (|case output
+ ($Right state* datum)
+ (return* (update$ $envs |tail state*) datum)
- [_]
+ _
output))))
(defn run-state [monad state]
@@ -588,65 +743,100 @@
(defn with-closure [body]
(|do [closure-name (|do [top get-top-local-env]
- (return (->> top (get$ $INNER-CLOSURES) str)))]
+ (return (->> top (get$ $inner-closures) str)))]
(fn [state]
(let [body* (with-scope closure-name body)]
- (run-state body* (update$ $ENVS #(|cons (update$ $INNER-CLOSURES inc (|head %))
+ (run-state body* (update$ $envs #(Cons$ (update$ $inner-closures inc (|head %))
(|tail %))
state))))))
(def get-scope-name
(fn [state]
- (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse))))
+ (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse))))
(defn with-writer [writer body]
(fn [state]
- (let [output (body (update$ $HOST #(set$ $WRITER (V "lux;Some" writer) %) state))]
- (matchv ::M/objects [output]
- [["lux;Right" [?state ?value]]]
- (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state)
+ (let [old-writer (->> state (get$ $host) (get$ $writer))
+ output (body (update$ $host #(set$ $writer (V $Some writer) %) state))]
+ (|case output
+ ($Right ?state ?value)
+ (return* (update$ $host #(set$ $writer old-writer %) ?state)
?value)
- [_]
+ _
output))))
+(defn with-expected-type [type body]
+ "(All [a] (-> Type (Lux a)))"
+ (fn [state]
+ (let [output (body (set$ $expected type state))]
+ (|case output
+ ($Right ?state ?value)
+ (return* (set$ $expected (get$ $expected state) ?state)
+ ?value)
+
+ _
+ output))))
+
+(defn with-cursor [^objects cursor body]
+ "(All [a] (-> Cursor (Lux a)))"
+ (if (= "" (aget cursor 0))
+ body
+ (fn [state]
+ (let [output (body (set$ $cursor cursor state))]
+ (|case output
+ ($Right ?state ?value)
+ (return* (set$ $cursor (get$ $cursor state) ?state)
+ ?value)
+
+ _
+ output)))))
+
+(def cursor
+ ;; (Lux Cursor)
+ (fn [state]
+ (return* state (get$ $cursor state))))
+
(defn show-ast [ast]
- (matchv ::M/objects [ast]
- [["lux;Meta" [_ ["lux;BoolS" ?value]]]]
+ (|case ast
+ [_ ($BoolS ?value)]
(pr-str ?value)
- [["lux;Meta" [_ ["lux;IntS" ?value]]]]
+ [_ ($IntS ?value)]
(pr-str ?value)
- [["lux;Meta" [_ ["lux;RealS" ?value]]]]
+ [_ ($RealS ?value)]
(pr-str ?value)
- [["lux;Meta" [_ ["lux;CharS" ?value]]]]
+ [_ ($CharS ?value)]
(pr-str ?value)
- [["lux;Meta" [_ ["lux;TextS" ?value]]]]
+ [_ ($TextS ?value)]
(str "\"" ?value "\"")
- [["lux;Meta" [_ ["lux;TagS" [?module ?tag]]]]]
+ [_ ($TagS ?module ?tag)]
(str "#" ?module ";" ?tag)
- [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]]
+ [_ ($SymbolS ?module ?name)]
(if (.equals "" ?module)
- ?ident
- (str ?module ";" ?ident))
+ ?name
+ (str ?module ";" ?name))
- [["lux;Meta" [_ ["lux;TupleS" ?elems]]]]
+ [_ ($TupleS ?elems)]
(str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]")
- [["lux;Meta" [_ ["lux;RecordS" ?elems]]]]
+ [_ ($RecordS ?elems)]
(str "{" (->> ?elems
(|map (fn [elem]
(|let [[k v] elem]
(str (show-ast k) " " (show-ast v)))))
(|interpose " ") (fold str "")) "}")
- [["lux;Meta" [_ ["lux;FormS" ?elems]]]]
+ [_ ($FormS ?elems)]
(str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")")
+
+ _
+ (assert false (prn-str 'show-ast (adt->text ast)))
))
(defn ident->text [ident]
@@ -654,70 +844,154 @@
(str ?module ";" ?name)))
(defn fold2% [f init xs ys]
- (matchv ::M/objects [xs ys]
- [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
+ (|case [xs ys]
+ [($Cons x xs*) ($Cons y ys*)]
(|do [init* (f init x y)]
(fold2% f init* xs* ys*))
- [["lux;Nil" _] ["lux;Nil" _]]
+ [($Nil) ($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*]]]
+ (|case [xs ys]
+ [($Cons x xs*) ($Cons y ys*)]
(|do [z (f x y)
zs (map2% f xs* ys*)]
- (return (|cons z zs)))
+ (return (Cons$ z zs)))
- [["lux;Nil" _] ["lux;Nil" _]]
- (return (V "lux;Nil" nil))
+ [($Nil) ($Nil)]
+ (return 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*))
+ (|case [xs ys]
+ [($Cons x xs*) ($Cons y ys*)]
+ (Cons$ (f x y) (map2 f xs* ys*))
[_ _]
- (V "lux;Nil" nil)))
+ Nil$))
(defn fold2 [f init xs ys]
- (matchv ::M/objects [xs ys]
- [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]]
+ (|case [xs ys]
+ [($Cons x xs*) ($Cons y ys*)]
(and init
(fold2 f (f init x y) xs* ys*))
- [["lux;Nil" _] ["lux;Nil" _]]
+ [($Nil) ($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*)))
+ "(All [a] (-> Int (List a) (List (, Int a))))"
+ (|case xs
+ ($Cons x xs*)
+ (V $Cons (T (T idx x)
+ (enumerate* (inc idx) xs*)))
- [["lux;Nil" _]]
+ ($Nil)
xs
))
(defn enumerate [xs]
+ "(All [a] (-> (List a) (List (, Int a))))"
(enumerate* 0 xs))
(def modules
"(Lux (List Text))"
(fn [state]
- (return* state (|keys (get$ $MODULES state)))))
+ (return* state (|keys (get$ $modules state)))))
(defn when% [test body]
"(-> Bool (Lux (,)) (Lux (,)))"
(if test
body
(return nil)))
+
+(defn |at [idx xs]
+ "(All [a] (-> Int (List a) (Maybe a)))"
+ ;; (prn '|at idx (aget idx 0))
+ (|case xs
+ ($Cons x xs*)
+ (cond (< idx 0)
+ (V $None nil)
+
+ (= idx 0)
+ (V $Some x)
+
+ :else ;; > 1
+ (|at (dec idx) xs*))
+
+ ($Nil)
+ (V $None nil)
+ ))
+
+(defn normalize [ident]
+ "(-> Ident (Lux Ident))"
+ (|case ident
+ ["" name] (|do [module get-module-name]
+ (return (T module name)))
+ _ (return ident)))
+
+(defn ident= [x y]
+ (|let [[xmodule xname] x
+ [ymodule yname] y]
+ (and (= xmodule ymodule)
+ (= xname yname))))
+
+(defn |list-put [idx val xs]
+ (|case xs
+ ($Nil)
+ (V $None nil)
+
+ ($Cons x xs*)
+ (if (= idx 0)
+ (V $Some (V $Cons (T val xs*)))
+ (|case (|list-put (dec idx) val xs*)
+ ($None) (V $None nil)
+ ($Some xs**) (V $Some (V $Cons (T x xs**))))
+ )))
+
+(do-template [<flagger> <asker> <tag>]
+ (do (defn <flagger> [module]
+ "(-> Text (Lux (,)))"
+ (fn [state]
+ (let [state* (update$ $host (fn [host]
+ (update$ $module-states
+ (fn [module-states]
+ (|put module (V <tag> nil) module-states))
+ host))
+ state)]
+ (V $Right (T state* nil)))))
+ (defn <asker> [module]
+ "(-> Text (Lux Bool))"
+ (fn [state]
+ (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))]
+ (V $Right (T state (|case module-state
+ (<tag>) true
+ _ false)))
+ (V $Right (T state false)))
+ )))
+
+ flag-active-module active-module? $Active
+ flag-compiled-module compiled-module? $Compiled
+ flag-cached-module cached-module? $Cached
+ )
+
+(do-template [<name> <default> <op>]
+ (defn <name> [p xs]
+ (|case xs
+ ($Nil)
+ <default>
+
+ ($Cons x xs*)
+ (<op> (p x) (|every? p xs*))))
+
+ |every? true and
+ |any? false or)
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 3449900e0..3052ead09 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -1,19 +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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler
(:refer-clojure :exclude [compile])
(:require (clojure [string :as string]
[set :as set]
[template :refer [do-template]])
- [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|let |do return* return fail fail*]]
+ (lux [base :as & :refer [|let |do return* return fail fail* |case]]
[type :as &type]
[reader :as &reader]
[lexer :as &lexer]
@@ -29,334 +26,435 @@
[host :as &&host]
[case :as &&case]
[lambda :as &&lambda]
- [package :as &&package]))
+ [module :as &&module]
+ [io :as &&io])
+ [lux.packager.program :as &packager-program])
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
MethodVisitor)))
;; [Utils/Compilers]
+(def ^:private !source->last-line (atom nil))
+
(defn ^:private compile-expression [syntax]
- (matchv ::M/objects [syntax]
- [[?form ?type]]
- (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)
+ (|let [[[?type [_file-name _line _column]] ?form] syntax]
+ (|do [^MethodVisitor *writer* &/get-writer
+ :let [debug-label (new Label)
+ _ (when (not= _line (get @!source->last-line _file-name))
+ (doto *writer*
+ (.visitLabel debug-label)
+ (.visitLineNumber (int _line) debug-label))
+ (swap! !source->last-line assoc _file-name _line))]]
+ (|case ?form
+ (&a/$bool ?value)
+ (&&lux/compile-bool compile-expression ?value)
+
+ (&a/$int ?value)
+ (&&lux/compile-int compile-expression ?value)
+
+ (&a/$real ?value)
+ (&&lux/compile-real compile-expression ?value)
+
+ (&a/$char ?value)
+ (&&lux/compile-char compile-expression ?value)
+
+ (&a/$text ?value)
+ (&&lux/compile-text compile-expression ?value)
+
+ (&a/$tuple ?elems)
+ (&&lux/compile-tuple compile-expression ?elems)
+
+ (&a/$var (&/$Local ?idx))
+ (&&lux/compile-local compile-expression ?idx)
+
+ (&a/$captured ?scope ?captured-id ?source)
+ (&&lux/compile-captured compile-expression ?scope ?captured-id ?source)
+
+ (&a/$var (&/$Global ?owner-class ?name))
+ (&&lux/compile-global compile-expression ?owner-class ?name)
+
+ (&a/$apply ?fn ?args)
+ (&&lux/compile-apply compile-expression ?fn ?args)
+
+ (&a/$variant ?tag ?members)
+ (&&lux/compile-variant compile-expression ?tag ?members)
+
+ (&a/$case ?value ?match)
+ (&&case/compile-case compile-expression ?value ?match)
+
+ (&a/$lambda ?scope ?env ?body)
+ (&&lambda/compile-lambda compile-expression ?scope ?env ?body)
+
+ (&a/$ann ?value-ex ?type-ex)
+ (&&lux/compile-ann compile-expression ?value-ex ?type-ex)
+
+ ;; Characters
+ (&a/$jvm-ceq ?x ?y)
+ (&&host/compile-jvm-ceq compile-expression ?x ?y)
+
+ (&a/$jvm-clt ?x ?y)
+ (&&host/compile-jvm-clt compile-expression ?x ?y)
+
+ (&a/$jvm-cgt ?x ?y)
+ (&&host/compile-jvm-cgt compile-expression ?x ?y)
+
+ ;; Integer arithmetic
+ (&a/$jvm-iadd ?x ?y)
+ (&&host/compile-jvm-iadd compile-expression ?x ?y)
+
+ (&a/$jvm-isub ?x ?y)
+ (&&host/compile-jvm-isub compile-expression ?x ?y)
+
+ (&a/$jvm-imul ?x ?y)
+ (&&host/compile-jvm-imul compile-expression ?x ?y)
+
+ (&a/$jvm-idiv ?x ?y)
+ (&&host/compile-jvm-idiv compile-expression ?x ?y)
+
+ (&a/$jvm-irem ?x ?y)
+ (&&host/compile-jvm-irem compile-expression ?x ?y)
+
+ (&a/$jvm-ieq ?x ?y)
+ (&&host/compile-jvm-ieq compile-expression ?x ?y)
+
+ (&a/$jvm-ilt ?x ?y)
+ (&&host/compile-jvm-ilt compile-expression ?x ?y)
+
+ (&a/$jvm-igt ?x ?y)
+ (&&host/compile-jvm-igt compile-expression ?x ?y)
+
+ ;; Long arithmetic
+ (&a/$jvm-ladd ?x ?y)
+ (&&host/compile-jvm-ladd compile-expression ?x ?y)
+
+ (&a/$jvm-lsub ?x ?y)
+ (&&host/compile-jvm-lsub compile-expression ?x ?y)
+
+ (&a/$jvm-lmul ?x ?y)
+ (&&host/compile-jvm-lmul compile-expression ?x ?y)
+
+ (&a/$jvm-ldiv ?x ?y)
+ (&&host/compile-jvm-ldiv compile-expression ?x ?y)
+
+ (&a/$jvm-lrem ?x ?y)
+ (&&host/compile-jvm-lrem compile-expression ?x ?y)
+
+ (&a/$jvm-leq ?x ?y)
+ (&&host/compile-jvm-leq compile-expression ?x ?y)
+
+ (&a/$jvm-llt ?x ?y)
+ (&&host/compile-jvm-llt compile-expression ?x ?y)
+
+ (&a/$jvm-lgt ?x ?y)
+ (&&host/compile-jvm-lgt compile-expression ?x ?y)
+
+ ;; Float arithmetic
+ (&a/$jvm-fadd ?x ?y)
+ (&&host/compile-jvm-fadd compile-expression ?x ?y)
+
+ (&a/$jvm-fsub ?x ?y)
+ (&&host/compile-jvm-fsub compile-expression ?x ?y)
+
+ (&a/$jvm-fmul ?x ?y)
+ (&&host/compile-jvm-fmul compile-expression ?x ?y)
+
+ (&a/$jvm-fdiv ?x ?y)
+ (&&host/compile-jvm-fdiv compile-expression ?x ?y)
+
+ (&a/$jvm-frem ?x ?y)
+ (&&host/compile-jvm-frem compile-expression ?x ?y)
+
+ (&a/$jvm-feq ?x ?y)
+ (&&host/compile-jvm-feq compile-expression ?x ?y)
+
+ (&a/$jvm-flt ?x ?y)
+ (&&host/compile-jvm-flt compile-expression ?x ?y)
+
+ (&a/$jvm-fgt ?x ?y)
+ (&&host/compile-jvm-fgt compile-expression ?x ?y)
+
+ ;; Double arithmetic
+ (&a/$jvm-dadd ?x ?y)
+ (&&host/compile-jvm-dadd compile-expression ?x ?y)
+
+ (&a/$jvm-dsub ?x ?y)
+ (&&host/compile-jvm-dsub compile-expression ?x ?y)
+
+ (&a/$jvm-dmul ?x ?y)
+ (&&host/compile-jvm-dmul compile-expression ?x ?y)
+
+ (&a/$jvm-ddiv ?x ?y)
+ (&&host/compile-jvm-ddiv compile-expression ?x ?y)
+
+ (&a/$jvm-drem ?x ?y)
+ (&&host/compile-jvm-drem compile-expression ?x ?y)
+
+ (&a/$jvm-deq ?x ?y)
+ (&&host/compile-jvm-deq compile-expression ?x ?y)
+
+ (&a/$jvm-dlt ?x ?y)
+ (&&host/compile-jvm-dlt compile-expression ?x ?y)
+
+ (&a/$jvm-dgt ?x ?y)
+ (&&host/compile-jvm-dgt compile-expression ?x ?y)
+
+ (&a/$jvm-null _)
+ (&&host/compile-jvm-null compile-expression)
+
+ (&a/$jvm-null? ?object)
+ (&&host/compile-jvm-null? compile-expression ?object)
+
+ (&a/$jvm-new ?class ?classes ?args)
+ (&&host/compile-jvm-new compile-expression ?class ?classes ?args)
+
+ (&a/$jvm-getstatic ?class ?field ?output-type)
+ (&&host/compile-jvm-getstatic compile-expression ?class ?field ?output-type)
+
+ (&a/$jvm-getfield ?class ?field ?object ?output-type)
+ (&&host/compile-jvm-getfield compile-expression ?class ?field ?object ?output-type)
+
+ (&a/$jvm-putstatic ?class ?field ?value ?output-type)
+ (&&host/compile-jvm-putstatic compile-expression ?class ?field ?value)
+
+ (&a/$jvm-putfield ?class ?field ?value ?object ?output-type)
+ (&&host/compile-jvm-putfield compile-expression ?class ?field ?object ?value)
+
+ (&a/$jvm-invokestatic ?class ?method ?classes ?args ?output-type)
+ (&&host/compile-jvm-invokestatic compile-expression ?class ?method ?classes ?args ?output-type)
+
+ (&a/$jvm-invokevirtual ?class ?method ?classes ?object ?args ?output-type)
+ (&&host/compile-jvm-invokevirtual compile-expression ?class ?method ?classes ?object ?args ?output-type)
+
+ (&a/$jvm-invokeinterface ?class ?method ?classes ?object ?args ?output-type)
+ (&&host/compile-jvm-invokeinterface compile-expression ?class ?method ?classes ?object ?args ?output-type)
+
+ (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args ?output-type)
+ (&&host/compile-jvm-invokespecial compile-expression ?class ?method ?classes ?object ?args ?output-type)
+
+ (&a/$jvm-znewarray ?length)
+ (&&host/compile-jvm-znewarray compile-expression ?length)
+
+ (&a/$jvm-zastore ?array ?idx ?elem)
+ (&&host/compile-jvm-zastore compile-expression ?array ?idx ?elem)
+
+ (&a/$jvm-zaload ?array ?idx)
+ (&&host/compile-jvm-zaload compile-expression ?array ?idx)
+
+ (&a/$jvm-bnewarray ?length)
+ (&&host/compile-jvm-bnewarray compile-expression ?length)
+
+ (&a/$jvm-bastore ?array ?idx ?elem)
+ (&&host/compile-jvm-bastore compile-expression ?array ?idx ?elem)
+
+ (&a/$jvm-baload ?array ?idx)
+ (&&host/compile-jvm-baload compile-expression ?array ?idx)
+
+ (&a/$jvm-snewarray ?length)
+ (&&host/compile-jvm-snewarray compile-expression ?length)
+
+ (&a/$jvm-sastore ?array ?idx ?elem)
+ (&&host/compile-jvm-sastore compile-expression ?array ?idx ?elem)
+
+ (&a/$jvm-saload ?array ?idx)
+ (&&host/compile-jvm-saload compile-expression ?array ?idx)
+
+ (&a/$jvm-inewarray ?length)
+ (&&host/compile-jvm-inewarray compile-expression ?length)
+
+ (&a/$jvm-iastore ?array ?idx ?elem)
+ (&&host/compile-jvm-iastore compile-expression ?array ?idx ?elem)
+
+ (&a/$jvm-iaload ?array ?idx)
+ (&&host/compile-jvm-iaload compile-expression ?array ?idx)
+
+ (&a/$jvm-lnewarray ?length)
+ (&&host/compile-jvm-lnewarray compile-expression ?length)
- [["jvm-aastore" [?array ?idx ?elem]]]
- (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem)
+ (&a/$jvm-lastore ?array ?idx ?elem)
+ (&&host/compile-jvm-lastore compile-expression ?array ?idx ?elem)
- [["jvm-aaload" [?array ?idx]]]
- (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx)
+ (&a/$jvm-laload ?array ?idx)
+ (&&host/compile-jvm-laload compile-expression ?array ?idx)
- [["jvm-try" [?body ?catches ?finally]]]
- (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally)
+ (&a/$jvm-fnewarray ?length)
+ (&&host/compile-jvm-fnewarray compile-expression ?length)
- [["jvm-throw" ?ex]]
- (&&host/compile-jvm-throw compile-expression ?type ?ex)
+ (&a/$jvm-fastore ?array ?idx ?elem)
+ (&&host/compile-jvm-fastore compile-expression ?array ?idx ?elem)
- [["jvm-monitorenter" ?monitor]]
- (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor)
+ (&a/$jvm-faload ?array ?idx)
+ (&&host/compile-jvm-faload compile-expression ?array ?idx)
- [["jvm-monitorexit" ?monitor]]
- (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor)
+ (&a/$jvm-dnewarray ?length)
+ (&&host/compile-jvm-dnewarray compile-expression ?length)
- [["jvm-d2f" ?value]]
- (&&host/compile-jvm-d2f compile-expression ?type ?value)
+ (&a/$jvm-dastore ?array ?idx ?elem)
+ (&&host/compile-jvm-dastore compile-expression ?array ?idx ?elem)
- [["jvm-d2i" ?value]]
- (&&host/compile-jvm-d2i compile-expression ?type ?value)
+ (&a/$jvm-daload ?array ?idx)
+ (&&host/compile-jvm-daload compile-expression ?array ?idx)
- [["jvm-d2l" ?value]]
- (&&host/compile-jvm-d2l compile-expression ?type ?value)
-
- [["jvm-f2d" ?value]]
- (&&host/compile-jvm-f2d compile-expression ?type ?value)
+ (&a/$jvm-cnewarray ?length)
+ (&&host/compile-jvm-cnewarray compile-expression ?length)
- [["jvm-f2i" ?value]]
- (&&host/compile-jvm-f2i compile-expression ?type ?value)
+ (&a/$jvm-castore ?array ?idx ?elem)
+ (&&host/compile-jvm-castore compile-expression ?array ?idx ?elem)
- [["jvm-f2l" ?value]]
- (&&host/compile-jvm-f2l compile-expression ?type ?value)
-
- [["jvm-i2b" ?value]]
- (&&host/compile-jvm-i2b compile-expression ?type ?value)
+ (&a/$jvm-caload ?array ?idx)
+ (&&host/compile-jvm-caload compile-expression ?array ?idx)
- [["jvm-i2c" ?value]]
- (&&host/compile-jvm-i2c compile-expression ?type ?value)
+ (&a/$jvm-anewarray ?class ?length)
+ (&&host/compile-jvm-anewarray compile-expression ?class ?length)
- [["jvm-i2d" ?value]]
- (&&host/compile-jvm-i2d compile-expression ?type ?value)
+ (&a/$jvm-aastore ?array ?idx ?elem)
+ (&&host/compile-jvm-aastore compile-expression ?array ?idx ?elem)
- [["jvm-i2f" ?value]]
- (&&host/compile-jvm-i2f compile-expression ?type ?value)
+ (&a/$jvm-aaload ?array ?idx)
+ (&&host/compile-jvm-aaload compile-expression ?array ?idx)
- [["jvm-i2l" ?value]]
- (&&host/compile-jvm-i2l compile-expression ?type ?value)
+ (&a/$jvm-arraylength ?array)
+ (&&host/compile-jvm-arraylength compile-expression ?array)
- [["jvm-i2s" ?value]]
- (&&host/compile-jvm-i2s compile-expression ?type ?value)
+ (&a/$jvm-try ?body ?catches ?finally)
+ (&&host/compile-jvm-try compile-expression ?body ?catches ?finally)
- [["jvm-l2d" ?value]]
- (&&host/compile-jvm-l2d compile-expression ?type ?value)
+ (&a/$jvm-throw ?ex)
+ (&&host/compile-jvm-throw compile-expression ?ex)
- [["jvm-l2f" ?value]]
- (&&host/compile-jvm-l2f compile-expression ?type ?value)
+ (&a/$jvm-monitorenter ?monitor)
+ (&&host/compile-jvm-monitorenter compile-expression ?monitor)
- [["jvm-l2i" ?value]]
- (&&host/compile-jvm-l2i compile-expression ?type ?value)
+ (&a/$jvm-monitorexit ?monitor)
+ (&&host/compile-jvm-monitorexit compile-expression ?monitor)
- [["jvm-iand" [?x ?y]]]
- (&&host/compile-jvm-iand compile-expression ?type ?x ?y)
+ (&a/$jvm-d2f ?value)
+ (&&host/compile-jvm-d2f compile-expression ?value)
- [["jvm-ior" [?x ?y]]]
- (&&host/compile-jvm-ior compile-expression ?type ?x ?y)
+ (&a/$jvm-d2i ?value)
+ (&&host/compile-jvm-d2i compile-expression ?value)
- [["jvm-land" [?x ?y]]]
- (&&host/compile-jvm-land compile-expression ?type ?x ?y)
+ (&a/$jvm-d2l ?value)
+ (&&host/compile-jvm-d2l compile-expression ?value)
+
+ (&a/$jvm-f2d ?value)
+ (&&host/compile-jvm-f2d compile-expression ?value)
- [["jvm-lor" [?x ?y]]]
- (&&host/compile-jvm-lor compile-expression ?type ?x ?y)
+ (&a/$jvm-f2i ?value)
+ (&&host/compile-jvm-f2i compile-expression ?value)
- [["jvm-lxor" [?x ?y]]]
- (&&host/compile-jvm-lxor compile-expression ?type ?x ?y)
+ (&a/$jvm-f2l ?value)
+ (&&host/compile-jvm-f2l compile-expression ?value)
+
+ (&a/$jvm-i2b ?value)
+ (&&host/compile-jvm-i2b compile-expression ?value)
- [["jvm-lshl" [?x ?y]]]
- (&&host/compile-jvm-lshl compile-expression ?type ?x ?y)
+ (&a/$jvm-i2c ?value)
+ (&&host/compile-jvm-i2c compile-expression ?value)
- [["jvm-lshr" [?x ?y]]]
- (&&host/compile-jvm-lshr compile-expression ?type ?x ?y)
+ (&a/$jvm-i2d ?value)
+ (&&host/compile-jvm-i2d compile-expression ?value)
- [["jvm-lushr" [?x ?y]]]
- (&&host/compile-jvm-lushr compile-expression ?type ?x ?y)
+ (&a/$jvm-i2f ?value)
+ (&&host/compile-jvm-i2f compile-expression ?value)
- [["jvm-instanceof" [?class ?object]]]
- (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object)
- )
+ (&a/$jvm-i2l ?value)
+ (&&host/compile-jvm-i2l compile-expression ?value)
+
+ (&a/$jvm-i2s ?value)
+ (&&host/compile-jvm-i2s compile-expression ?value)
+
+ (&a/$jvm-l2d ?value)
+ (&&host/compile-jvm-l2d compile-expression ?value)
+
+ (&a/$jvm-l2f ?value)
+ (&&host/compile-jvm-l2f compile-expression ?value)
+
+ (&a/$jvm-l2i ?value)
+ (&&host/compile-jvm-l2i compile-expression ?value)
+
+ (&a/$jvm-iand ?x ?y)
+ (&&host/compile-jvm-iand compile-expression ?x ?y)
+
+ (&a/$jvm-ior ?x ?y)
+ (&&host/compile-jvm-ior compile-expression ?x ?y)
+
+ (&a/$jvm-ixor ?x ?y)
+ (&&host/compile-jvm-ixor compile-expression ?x ?y)
+
+ (&a/$jvm-ishl ?x ?y)
+ (&&host/compile-jvm-ishl compile-expression ?x ?y)
+
+ (&a/$jvm-ishr ?x ?y)
+ (&&host/compile-jvm-ishr compile-expression ?x ?y)
+
+ (&a/$jvm-iushr ?x ?y)
+ (&&host/compile-jvm-iushr compile-expression ?x ?y)
+
+ (&a/$jvm-land ?x ?y)
+ (&&host/compile-jvm-land compile-expression ?x ?y)
+
+ (&a/$jvm-lor ?x ?y)
+ (&&host/compile-jvm-lor compile-expression ?x ?y)
+
+ (&a/$jvm-lxor ?x ?y)
+ (&&host/compile-jvm-lxor compile-expression ?x ?y)
+
+ (&a/$jvm-lshl ?x ?y)
+ (&&host/compile-jvm-lshl compile-expression ?x ?y)
+
+ (&a/$jvm-lshr ?x ?y)
+ (&&host/compile-jvm-lshr compile-expression ?x ?y)
+
+ (&a/$jvm-lushr ?x ?y)
+ (&&host/compile-jvm-lushr compile-expression ?x ?y)
+
+ (&a/$jvm-instanceof ?class ?object)
+ (&&host/compile-jvm-instanceof compile-expression ?class ?object)
+
+ _
+ (assert false (prn-str 'compile-expression (&/adt->text syntax)))
+ ))
))
-(defn ^:private compile-statement [syntax]
- (matchv ::M/objects [syntax]
- [["def" [?name ?body ?def-data]]]
- (&&lux/compile-def compile-expression ?name ?body ?def-data)
+(defn ^:private compile-token [syntax]
+ (|case syntax
+ (&a/$def ?name ?body)
+ (&&lux/compile-def compile-expression ?name ?body)
- [["declare-macro" [?module ?name]]]
+ (&a/$declare-macro ?module ?name)
(&&lux/compile-declare-macro compile-expression ?module ?name)
- [["jvm-program" ?body]]
+ (&a/$jvm-program ?body)
(&&host/compile-jvm-program compile-expression ?body)
- [["jvm-interface" [?name ?supers ?methods]]]
- (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods)
+ (&a/$jvm-interface ?name ?supers ?anns ?methods)
+ (&&host/compile-jvm-interface compile-expression ?name ?supers ?anns ?methods)
- [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]]
- (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods)))
+ (&a/$jvm-class ?name ?super-class ?interfaces ?anns ?fields ?methods ??env)
+ (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?anns ?fields ?methods ??env)
+
+ _
+ (compile-expression syntax)))
(defn ^:private eval! [expr]
(&/with-eval
(|do [module &/get-module-name
id &/gen-id
+ [file-name _ _] &/cursor
: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))))]
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil)
+ (doto (.visitEnd)))
+ (.visitSource file-name nil))]
_ (&/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*
- (.visitFieldInsn Opcodes/PUTSTATIC class-name "_eval" "Ljava/lang/Object;")
+ (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;")
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))]]
@@ -365,73 +463,88 @@
.visitEnd))]
_ (&&/save-class! (str id) bytecode)
loader &/loader]
- (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id))
- (.getField "_eval")
+ (-> (.loadClass ^ClassLoader loader (str (&host/->class-name module) "." id))
+ (.getField &/eval-field)
(.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)))))))
- )))
+ (let [file-name (str name ".lux")]
+ (|do [file-content (&&io/read-file file-name)
+ :let [file-hash (hash file-content)]]
+ (if (&&cache/cached? name)
+ (&&cache/load name file-hash compile-module)
+ (let [compiler-step (&optimizer/optimize eval! compile-module compile-token)]
+ (|do [module-exists? (&a-module/exists? name)]
+ (if module-exists?
+ (fail "[Compiler Error] Can't redefine a module!")
+ (|do [_ (&&cache/delete name)
+ _ (&a-module/enter-module name)
+ _ (&/flag-active-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-field "I" nil file-hash)
+ .visitEnd)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version)
+ .visitEnd)
+ (.visitSource file-name nil))]]
+ (fn [state]
+ (|case ((&/with-writer =class
+ (&/exhaust% compiler-step))
+ (&/set$ &/$source (&reader/from name file-content) state))
+ (&/$Right ?state _)
+ (&/run-state (|do [defs &a-module/defs
+ imports &a-module/imports
+ tag-groups &&module/tag-groups
+ :let [_ (doto =class
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/defs-field "Ljava/lang/String;" nil
+ (->> defs
+ (&/|map (fn [_def]
+ (|let [[?exported ?name ?ann] _def]
+ (str (if ?exported &&/exported-true &&/exported-false)
+ &&/exported-separator
+ ?name
+ &&/exported-separator
+ ?ann))))
+ (&/|interpose &&/def-separator)
+ (&/fold str "")))
+ .visitEnd)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/imports-field "Ljava/lang/String;" nil
+ (->> imports (&/|interpose &&/import-separator) (&/fold str "")))
+ .visitEnd)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/tags-field "Ljava/lang/String;" nil
+ (->> tag-groups
+ (&/|map (fn [group]
+ (|let [[type tags] group]
+ (->> tags (&/|interpose &&/tag-separator) (&/fold str "")
+ (str type &&/type-separator)))))
+ (&/|interpose &&/tag-group-separator)
+ (&/fold str "")))
+ .visitEnd)
+ (.visitEnd))
+ ]
+ _ (&/flag-compiled-module name)]
+ (&&/save-class! &/module-class-name (.toByteArray =class)))
+ ?state)
+
+ (&/$Left ?message)
+ (fail* ?message)))))))
+ ))
+ ))
(defn ^:private init! []
+ (reset! !source->last-line {})
(.mkdirs (java.io.File. &&/output-dir)))
;; [Resources]
(defn compile-program [program-module]
(init!)
- (matchv ::M/objects [((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))]
- [["lux;Right" [?state _]]]
+ (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))
+ (&/$Right ?state _)
(do (println "Compilation complete!")
(&&cache/clean ?state)
- (&&package/package program-module))
+ (&packager-program/package program-module))
- [["lux;Left" ?message]]
+ (&/$Left ?message)
(assert false ?message)))
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 28339c162..7825bef94 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -1,10 +1,7 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler.base
(:require (clojure [template :refer [do-template]]
@@ -27,30 +24,43 @@
(java.lang.reflect Field)))
;; [Constants]
-(def ^String version "0.2")
+(def ^String version "0.3")
(def ^String input-dir "source")
-(def ^String output-dir "target/jvm")
-(def ^String output-package (str output-dir "/program.jar"))
+(def ^String output-dir "target/jvm/")
+(def ^String output-package (str output-dir "program.jar"))
(def ^String function-class "lux/Function")
+;; Formats
(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;")
+(def exported-true "1")
+(def exported-false "0")
+(def exported-separator " ")
+(def def-separator "\t")
+(def import-separator "\t")
+(def tag-separator " ")
+(def type-separator "\t")
+(def tag-group-separator "\n")
+
;; [Utils]
-(defn ^:private write-file [^String file ^bytes data]
- (with-open [stream (BufferedOutputStream. (FileOutputStream. file))]
- (.write stream data)))
+(defn ^:private write-file [^String file-name ^bytes data]
+ (let [;; file-name (.toLowerCase file-name)
+ ]
+ (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name))
+ (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))]
+ (.write stream data)))))
(defn ^:private write-output [module name data]
(let [module* (&host/->module-class module)
- module-dir (str output-dir "/" 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]
+(defn ^Class load-class! [^ClassLoader loader name]
;; (prn 'load-class! name)
(.loadClass loader name))
@@ -59,33 +69,28 @@
module &/get-module-name
loader &/loader
!classes &/classes
- :let [real-name (str (&host/->module-class module) "." name)
+ :let [real-name (str (&host/->class-name module) "." name)
_ (swap! !classes assoc real-name bytecode)
_ (when (not eval?)
(write-output module name bytecode))
_ (load-class! loader real-name)]]
(return nil)))
-(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
- ;; )
- )
+(do-template [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>]
+ (do (defn <wrap-name> [^MethodVisitor writer]
+ (doto writer
+ (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host/->type-signature <class>)))))
+ (defn <unwrap-name> [^MethodVisitor writer]
+ (doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST <class>)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <unwrap-method> (str "()" <prim>)))))
- 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
+ wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1
+ wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1
+ wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1
+ wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1
+ wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2
+ wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1
+ wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2
+ wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1
)
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
index c0d978146..a35225acf 100644
--- a/src/lux/compiler/cache.clj
+++ b/src/lux/compiler/cache.clj
@@ -1,23 +1,21 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(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
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail*]]
+ (lux [base :as & :refer [|do return* return fail fail* |case |let]]
[type :as &type]
[host :as &host])
(lux.analyser [base :as &a]
[module :as &a-module])
- (lux.compiler [base :as &&]))
+ (lux.compiler [base :as &&]
+ [io :as &&io]))
(:import (java.io File
BufferedOutputStream
FileOutputStream)
@@ -25,6 +23,7 @@
;; [Utils]
(defn ^:private read-file [^File file]
+ "(-> File (Array Byte))"
(with-open [reader (io/input-stream file)]
(let [length (.length file)
buffer (byte-array length)]
@@ -32,29 +31,29 @@
buffer)))
(defn ^:private clean-file [^File file]
- (if (.isDirectory file)
- (do (doseq [f (seq (.listFiles file))]
- (clean-file f))
- (.delete file))
- (.delete file)))
+ "(-> File (,))"
+ (doseq [^File f (seq (.listFiles file))
+ :when (not (.isDirectory f))]
+ (.delete f)))
(defn ^:private get-field [^String field-name ^Class class]
+ "(-> Text Class Object)"
(-> class ^Field (.getField field-name) (.get nil)))
;; [Resources]
(defn cached? [module]
"(-> Text Bool)"
- (.exists (new File (str &&/output-dir "/" (&host/->module-class module) "/_.class"))))
+ (.exists (new File (str &&/output-dir (&host/->module-class module) "/" &/module-class-name ".class"))))
(defn delete [module]
"(-> Text (Lux (,)))"
(fn [state]
- (do (clean-file (new File (str &&/output-dir "/" (&host/->module-class module))))
+ (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)
+ (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)]
@@ -65,6 +64,7 @@
nil))
(defn load [module module-hash compile-module]
+ "(-> Text Int (-> Text (Lux (,))) (Lux Bool))"
(|do [loader &/loader
!classes &/classes
already-loaded? (&a-module/exists? module)
@@ -72,67 +72,78 @@
: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)))))
+ (if already-loaded?
+ (return true)
+ (if (cached? module)
+ (let [module* (&host/->class-name 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-field module-meta))
+ (= &&/version (get-field &/compiler-field module-meta)))
+ (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator)))]
+ (|do [loads (&/map% (fn [_import]
+ (|do [content (&&io/read-file (str _import ".lux"))
+ _ (load _import (hash content) compile-module)]
+ (&/cached-module? _import)))
+ (if (= [""] imports)
+ &/Nil$
+ (&/->list imports)))]
+ (if (->> loads &/->seq (every? true?))
+ (do (doseq [^File file (seq (.listFiles (File. module-path)))
+ :when (not (.isDirectory file))
+ :let [file-name (.getName file)]
+ :when (not= "_.class" file-name)]
+ (let [real-name (second (re-find #"^(.*)\.class$" file-name))
+ bytecode (read-file file)]
+ (swap! !classes assoc (str module* "." real-name) bytecode)))
+ (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator)))
+ tag-groups (let [all-tags (get-field &/tags-field module-meta)]
+ (if (= "" all-tags)
+ &/Nil$
+ (-> all-tags
+ (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))
+ (->> (map (fn [_group]
+ (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))]
+ (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator)))))))))
+ &/->list)))]
+ (|do [_ (&a-module/enter-module module)
+ _ (&/flag-cached-module module)
+ _ (&a-module/set-imports imports)
+ _ (&/map% (fn [_def]
+ (let [[_exported? _name _ann] (string/split _def #" ")]
+ (|do [_ (case _ann
+ "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
+ def-value (get-field &/datum-field def-class)]
+ (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type))
+ "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
+ def-value (get-field &/datum-field def-class)]
+ (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)]
+ (&a-module/declare-macro module _name)))
+ "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
+ def-meta (get-field &/meta-field def-class)]
+ (|case def-meta
+ (&/$ValueD def-type _)
+ (&a-module/define module _name def-meta def-type)))
+ ;; else
+ (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)]
+ (|do [__type (&a-module/def-type __module __name)]
+ (&a-module/def-alias module _name __module __name __type))))]
+ (if (= &&/exported-true _exported?)
+ (&a-module/export module _name)
+ (return nil)))
+ ))
+ (if (= [""] defs)
+ &/Nil$
+ (&/->list defs)))
+ _ (&/map% (fn [group]
+ (|let [[_type _tags] group]
+ (|do [=type (&a-module/type-def module _type)]
+ (&a-module/declare-tags module _tags =type))))
+ tag-groups)]
+ (return true))))
+ redo-cache)))
+ redo-cache)
+ )
+ redo-cache))))
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index fc0cce31f..64237f3db 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -1,22 +1,20 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler.case
(:require (clojure [set :as set]
[template :refer [do-template]])
- [clojure.core.match :as M :refer [match matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let]]
+ (lux [base :as & :refer [|do return* return fail fail* |let |case]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
[analyser :as &analyser]
[host :as &host])
+ [lux.analyser.case :as &a-case]
[lux.compiler.base :as &&])
(:import (org.objectweb.asm Opcodes
Label
@@ -26,13 +24,13 @@
;; [Utils]
(let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))]
(defn ^:private compile-match [^MethodVisitor writer ?match $target $else]
- (matchv ::M/objects [?match]
- [["StoreTestAC" ?idx]]
+ (|case ?match
+ (&a-case/$StoreTestAC ?idx)
(doto writer
(.visitVarInsn Opcodes/ASTORE ?idx)
(.visitJumpInsn Opcodes/GOTO $target))
- [["BoolTestAC" ?value]]
+ (&a-case/$BoolTestAC ?value)
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean")
(.visitInsn Opcodes/DUP)
@@ -42,29 +40,29 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["IntTestAC" ?value]]
+ (&a-case/$IntTestAC ?value)
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long")
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J")
- (.visitLdcInsn ?value)
+ (.visitLdcInsn (long ?value))
(.visitInsn Opcodes/LCMP)
(.visitJumpInsn Opcodes/IFNE $else)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["RealTestAC" ?value]]
+ (&a-case/$RealTestAC ?value)
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double")
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D")
- (.visitLdcInsn ?value)
+ (.visitLdcInsn (double ?value))
(.visitInsn Opcodes/DCMPL)
(.visitJumpInsn Opcodes/IFNE $else)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["CharTestAC" ?value]]
+ (&a-case/$CharTestAC ?value)
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character")
(.visitInsn Opcodes/DUP)
@@ -74,7 +72,7 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["TextTestAC" ?value]]
+ (&a-case/$TextTestAC ?value)
(doto writer
(.visitInsn Opcodes/DUP)
(.visitLdcInsn ?value)
@@ -83,7 +81,7 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["TupleTestAC" ?members]]
+ (&a-case/$TupleTestAC ?members)
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(-> (doto (.visitInsn Opcodes/DUP)
@@ -101,36 +99,14 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- [["RecordTestAC" ?slots]]
- (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (-> (doto (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int idx))
- (.visitInsn Opcodes/AALOAD)
- (compile-match test $next $sub-else)
- (.visitLabel $sub-else)
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $else)
- (.visitLabel $next))
- (->> (|let [[idx [_ test]] idx+member
- $next (new Label)
- $sub-else (new Label)])
- (doseq [idx+member (->> ?slots
- &/->seq
- (sort compare-kv)
- &/->list
- &/enumerate
- &/->seq)])))
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $target))
-
- [["VariantTestAC" [?tag ?test]]]
+ (&a-case/$VariantTestAC ?tag ?count ?test)
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 0))
(.visitInsn Opcodes/AALOAD)
(.visitLdcInsn ?tag)
+ (&&/wrap-long)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
(.visitJumpInsn Opcodes/IFEQ $else)
(.visitInsn Opcodes/DUP)
@@ -185,7 +161,7 @@
))
;; [Resources]
-(defn compile-case [compile *type* ?value ?matches]
+(defn compile-case [compile ?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 346b66fd2..c364091ba 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -1,30 +1,29 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler.host
(:require (clojure [string :as string]
[set :as set]
[template :refer [do-template]])
- [clojure.core.match :as M :refer [match matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let]]
+ (lux [base :as & :refer [|do return* return fail fail* |let |case]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
[analyser :as &analyser]
[host :as &host])
+ [lux.type.host :as &host-type]
[lux.analyser.base :as &a]
[lux.compiler.base :as &&]
:reload)
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
- MethodVisitor)))
+ MethodVisitor
+ AnnotationVisitor)))
;; [Utils]
(let [class+method+sig {"boolean" [(&host/->class "java.lang.Boolean") "booleanValue" "()Z"]
@@ -51,41 +50,47 @@
double-class "java.lang.Double"
char-class "java.lang.Character"]
(defn prepare-return! [^MethodVisitor *writer* *type*]
- (matchv ::M/objects [*type*]
- [["lux;TupleT" ["lux;Nil" _]]]
+ (|case *type*
+ (&/$TupleT (&/$Nil))
(.visitInsn *writer* Opcodes/ACONST_NULL)
- [["lux;DataT" "boolean"]]
+ (&/$DataT "boolean" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class)))
- [["lux;DataT" "byte"]]
+ (&/$DataT "byte" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class)))
- [["lux;DataT" "short"]]
+ (&/$DataT "short" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class)))
- [["lux;DataT" "int"]]
+ (&/$DataT "int" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class)))
- [["lux;DataT" "long"]]
+ (&/$DataT "long" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class)))
- [["lux;DataT" "float"]]
+ (&/$DataT "float" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class)))
- [["lux;DataT" "double"]]
+ (&/$DataT "double" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class)))
- [["lux;DataT" "char"]]
+ (&/$DataT "char" (&/$Nil))
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class)))
- [["lux;DataT" _]]
- nil)
+ (&/$DataT _ _)
+ nil
+
+ (&/$NamedT ?name ?type)
+ (prepare-return! *writer* ?type)
+
+ _
+ (assert false (str 'prepare-return! " " (&type/show-type *type*))))
*writer*))
;; [Resources]
(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>]
- (defn <name> [compile *type* ?x ?y]
+ (defn <name> [compile ?x ?y]
(|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
^MethodVisitor *writer* &/get-writer
_ (compile ?x)
@@ -127,14 +132,14 @@
)
(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>]
- (defn <name> [compile *type* ?x ?y]
+ (defn <name> [compile ?x ?y]
(|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
+ _ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
- _ (compile ?y)
+ _ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
@@ -159,14 +164,14 @@
)
(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>]
- (defn <name> [compile *type* ?x ?y]
+ (defn <name> [compile ?x ?y]
(|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
+ _ (compile ?y)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
- _ (compile ?y)
+ _ (compile ?x)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
@@ -191,31 +196,32 @@
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 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"
+ compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D"
+ compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D"
+ compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()D"
)
-(defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args]
+(defn compile-jvm-invokestatic [compile ?class ?method ?classes ?args ?output-type]
(|do [^MethodVisitor *writer* &/get-writer
- :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
+ :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-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 (&type/as-obj ?class)) ?method method-sig)
- (prepare-return! *type*))]]
+ (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&host-type/as-obj ?class)) ?method method-sig)
+ (prepare-return! ?output-type))]]
(return nil)))
(do-template [<name> <op>]
- (defn <name> [compile *type* ?class ?method ?classes ?object ?args]
- (|do [:let [?class* (&host/->class (&type/as-obj ?class))]
+ (defn <name> [compile ?class ?method ?classes ?object ?args ?output-type]
+ (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))]
^MethodVisitor *writer* &/get-writer
- :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
+ :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-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)]]
@@ -223,38 +229,20 @@
?classes ?args)
:let [_ (doto *writer*
(.visitMethodInsn <op> ?class* ?method method-sig)
- (prepare-return! *type*))]]
+ (prepare-return! ?output-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*]
+(defn compile-jvm-null [compile]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
(return nil)))
-(defn compile-jvm-null? [compile *type* ?object]
+(defn compile-jvm-null? [compile ?object]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?object)
:let [$then (new Label)
@@ -268,7 +256,7 @@
(.visitLabel $end))]]
(return nil)))
-(defn compile-jvm-new [compile *type* ?class ?classes ?args]
+(defn compile-jvm-new [compile ?class ?classes ?args]
(|do [^MethodVisitor *writer* &/get-writer
:let [init-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")V")
class* (&host/->class ?class)
@@ -284,79 +272,129 @@
(.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
(return nil)))
-(defn compile-jvm-new-array [compile *type* ?class ?length]
+(do-template [<prim-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>]
+ (do (defn <new-name> [compile ?length]
+ (|do [^MethodVisitor *writer* &/get-writer
+ _ (compile ?length)
+ :let [_ (.visitInsn *writer* Opcodes/L2I)]
+ :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]]
+ (return nil)))
+
+ (defn <load-name> [compile ?array ?idx]
+ (|do [^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (doto *writer*
+ (.visitInsn <load-op>)
+ <wrapper>)]]
+ (return nil)))
+
+ (defn <store-name> [compile ?array ?idx ?elem]
+ (|do [^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")]
+ :let [_ (.visitInsn *writer* Opcodes/DUP)]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ _ (compile ?elem)
+ :let [_ (doto *writer*
+ <unwrapper>
+ (.visitInsn <store-op>))]]
+ (return nil)))
+ )
+
+ Opcodes/T_BOOLEAN compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean
+ Opcodes/T_BYTE compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte
+ Opcodes/T_SHORT compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short
+ Opcodes/T_INT compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int
+ Opcodes/T_LONG compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long
+ Opcodes/T_FLOAT compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float
+ Opcodes/T_DOUBLE compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double
+ Opcodes/T_CHAR compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char
+ )
+
+(defn compile-jvm-anewarray [compile ?class ?length]
(|do [^MethodVisitor *writer* &/get-writer
+ _ (compile ?length)
+ :let [_ (.visitInsn *writer* Opcodes/L2I)]
+ :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]]
+ (return nil)))
+
+(defn compile-jvm-aaload [compile ?array ?idx]
+ (|do [^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")]
+ _ (compile ?idx)
:let [_ (doto *writer*
- (.visitLdcInsn (int ?length))
- (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]]
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (.visitInsn *writer* Opcodes/AALOAD)]]
(return nil)))
-(defn compile-jvm-aastore [compile *type* ?array ?idx ?elem]
+(defn compile-jvm-aastore [compile ?array ?idx ?elem]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")]
+ :let [_ (.visitInsn *writer* Opcodes/DUP)]
+ _ (compile ?idx)
:let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int ?idx)))]
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
_ (compile ?elem)
:let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
(return nil)))
-(defn compile-jvm-aaload [compile *type* ?array ?idx]
+(defn compile-jvm-arraylength [compile ?array]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")]
:let [_ (doto *writer*
- (.visitLdcInsn (int ?idx))
- (.visitInsn Opcodes/AALOAD))]]
+ (.visitInsn Opcodes/ARRAYLENGTH)
+ (.visitInsn Opcodes/I2L)
+ &&/wrap-long)]]
(return nil)))
-(defn compile-jvm-getstatic [compile *type* ?class ?field]
+(defn compile-jvm-getstatic [compile ?class ?field ?output-type]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
- (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))
- (prepare-return! *type*))]]
+ (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type))
+ (prepare-return! ?output-type))]]
(return nil)))
-(defn compile-jvm-getfield [compile *type* ?class ?field ?object]
- (|do [:let [class* (&host/->class (&type/as-obj ?class))]
+(defn compile-jvm-getfield [compile ?class ?field ?object ?output-type]
+ (|do [:let [class* (&host/->class (&host-type/as-obj ?class))]
^MethodVisitor *writer* &/get-writer
_ (compile ?object)
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST class*)
- (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig *type*))
- (prepare-return! *type*))]]
+ (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig ?output-type))
+ (prepare-return! ?output-type))]]
(return nil)))
-(defn compile-jvm-putstatic [compile *type* ?class ?field ?value]
+(defn compile-jvm-putstatic [compile ?class ?field ?value ?output-type]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?value)
- :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type))]
+ :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
(return nil)))
-(defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value]
- (|do [:let [class* (&host/->class (&type/as-obj ?class))]
+(defn compile-jvm-putfield [compile ?class ?field ?object ?value ?output-type]
+ (|do [:let [class* (&host/->class (&host-type/as-obj ?class))]
^MethodVisitor *writer* &/get-writer
_ (compile ?object)
+ :let [_ (.visitInsn *writer* Opcodes/DUP)]
_ (compile ?value)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)]
- :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig *type*))]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig ?output-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]
+(defn compile-jvm-instanceof [compile class object]
(|do [:let [class* (&host/->class class)]
^MethodVisitor *writer* &/get-writer
_ (compile object)
@@ -365,69 +403,147 @@
(&&/wrap-boolean))]]
(return nil)))
-(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]
+(defn ^:private compile-annotation [writer ann]
+ (doto ^AnnotationVisitor (.visitAnnotation writer (&host/->class (:name ann)) true)
+ (-> (.visit param-name param-value)
+ (->> (|let [[param-name param-value] param])
+ (doseq [param (&/->seq (:params ann))])))
+ (.visitEnd))
+ nil)
+
+(defn ^:private compile-field [^ClassWriter writer field]
+ (let [=field (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field)
+ (&host/->type-signature (:type field)) nil nil)]
+ (&/|map (partial compile-annotation =field) (:anns field))
+ (.visitEnd =field)
+ nil))
+
+(defn ^:private compile-method-return [^MethodVisitor writer output]
+ (case output
+ "void" (.visitInsn writer Opcodes/RETURN)
+ "boolean" (doto writer
+ &&/unwrap-boolean
+ (.visitInsn Opcodes/IRETURN))
+ "byte" (doto writer
+ &&/unwrap-byte
+ (.visitInsn Opcodes/IRETURN))
+ "short" (doto writer
+ &&/unwrap-short
+ (.visitInsn Opcodes/IRETURN))
+ "int" (doto writer
+ &&/unwrap-int
+ (.visitInsn Opcodes/IRETURN))
+ "long" (doto writer
+ &&/unwrap-long
+ (.visitInsn Opcodes/LRETURN))
+ "float" (doto writer
+ &&/unwrap-float
+ (.visitInsn Opcodes/FRETURN))
+ "double" (doto writer
+ &&/unwrap-double
+ (.visitInsn Opcodes/DRETURN))
+ "char" (doto writer
+ &&/unwrap-char
+ (.visitInsn Opcodes/IRETURN))
+ ;; else
+ (.visitInsn writer Opcodes/ARETURN)))
+
+(defn ^:private compile-method [compile ^ClassWriter class-writer method]
+ (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")"
+ (&host/->type-signature (:output method)))]
+ (&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method))
+ (:name method)
+ signature
+ nil
+ (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (&/|map (partial compile-annotation =method) (:anns method))
+ _ (.visitCode =method)]
+ _ (compile (:body method))
+ :let [_ (doto =method
+ (compile-method-return (:output method))
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))))
+
+(defn ^:private compile-method-decl [^ClassWriter class-writer method]
+ (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")"
+ (&host/->type-signature (:output method)))]
+ (let [=method (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))]
+ (&/|map (partial compile-annotation =method) (:anns method))
+ nil)))
+
+(let [clo-field-sig (&host/->type-signature "java.lang.Object")
+ <init>-return "V"]
+ (defn ^:private anon-class-<init>-signature [env]
+ (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")"
+ <init>-return))
+
+ (defn ^:private add-anon-class-<init> [^ClassWriter class-writer class-name env]
+ (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "<init>" (anon-class-<init>-signature env) nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
+ (-> (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)])
+ (|case ?name+?captured
+ [?name [_ (&a/$captured _ ?captured-id ?source)]])
+ (doseq [?name+?captured (&/->seq env)])))
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ )
+
+(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env]
+ (|do [module &/get-module-name
+ [file-name _ _] &/cursor
+ :let [full-name (str module "/" ?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* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))
+ (.visitSource file-name nil))
+ _ (&/|map (partial compile-annotation =class) ?anns)
+ _ (&/|map (partial compile-field =class)
+ ?fields)]
+ _ (&/map% (partial compile-method compile =class) ?methods)
+ :let [_ (when env
+ (add-anon-class-<init> =class full-name env))]]
+ (&&/save-class! ?name (.toByteArray (doto =class .visitEnd)))))
+
+(defn compile-jvm-interface [compile ?name ?supers ?anns ?methods]
+ (|do [module &/get-module-name
+ [file-name _ _] &/cursor]
(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)
+ (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))
+ (.visitSource file-name nil))
+ _ (&/|map (partial compile-annotation =interface) ?anns)
+ _ (do (&/|map (partial compile-method-decl =interface) ?methods)
(.visitEnd =interface))]
(&&/save-class! ?name (.toByteArray =interface)))))
-(defn compile-jvm-try [compile *type* ?body ?catches ?finally]
+(defn compile-jvm-try [compile ?body ?catches ?finally]
(|do [^MethodVisitor *writer* &/get-writer
:let [$from (new Label)
$to (new Label)
$end (new Label)
$catch-finally (new Label)
- 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)))
+ compile-finally (|case ?finally
+ (&/$Some ?finally*) (|do [_ (return nil)
+ _ (compile ?finally*)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $end))]]
+ (return nil))
+ (&/$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)]
- ]
+ _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries)]
(doto *writer*
(.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class))
(.visitTryCatchBlock $handler-start $handler-end $catch-finally nil)))
@@ -445,28 +561,27 @@
compile-finally))
?catches
catch-boundaries)
- ;; :let [_ (prn 'handlers (&/->seq handlers))]
:let [_ (.visitLabel *writer* $catch-finally)]
- _ (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)))
+ _ (|case ?finally
+ (&/$Some ?finally*) (|do [_ (compile ?finally*)
+ :let [_ (.visitInsn *writer* Opcodes/POP)]
+ :let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
+ (return nil))
+ (&/$None) (|do [_ (return nil)
+ :let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
+ (return nil)))
:let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]
:let [_ (.visitLabel *writer* $end)]]
(return nil)))
-(defn compile-jvm-throw [compile *type* ?ex]
+(defn compile-jvm-throw [compile ?ex]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?ex)
:let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
(return nil)))
(do-template [<name> <op>]
- (defn <name> [compile *type* ?monitor]
+ (defn <name> [compile ?monitor]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?monitor)
:let [_ (doto *writer*
@@ -479,7 +594,7 @@
)
(do-template [<name> <op> <from-class> <from-method> <from-sig> <to-class> <to-sig>]
- (defn <name> [compile *type* ?value]
+ (defn <name> [compile ?value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW (&host/->class <to-class>))
@@ -513,7 +628,7 @@
)
(do-template [<name> <op> <from1-method> <from1-sig> <from1-class> <from2-method> <from2-sig> <from2-class> <to-class> <to-sig>]
- (defn <name> [compile *type* ?x ?y]
+ (defn <name> [compile ?x ?y]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW (&host/->class <to-class>))
@@ -533,11 +648,14 @@
compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
+ compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
+ compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
+ compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
+ compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V"
compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V"
compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V"
-
compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V"
compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V"
compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V"
@@ -545,23 +663,20 @@
(defn compile-jvm-program [compile ?body]
(|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 [^MethodVisitor main-writer &/get-writer
- :let [;; _ (prn "#1" module-name *writer*)
- $loop (new Label)
- ;; _ (prn "#2")
+ :let [$loop (new Label)
$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
+ (.visitLdcInsn &/$Nil) ;; VVIT
+ (&&/wrap-long)
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
@@ -606,7 +721,8 @@
(.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; I2V
(.visitInsn Opcodes/DUP) ;; I2VV
(.visitLdcInsn (int 0)) ;; I2VVI
- (.visitLdcInsn "lux;Cons") ;; I2VVIT
+ (.visitLdcInsn &/$Cons) ;; I2VVIT
+ (&&/wrap-long)
(.visitInsn Opcodes/AASTORE) ;; I2V
(.visitInsn Opcodes/DUP_X1) ;; IV2V
(.visitInsn Opcodes/SWAP) ;; IVV2
@@ -621,20 +737,14 @@
(.visitInsn Opcodes/POP) ;; V
(.visitVarInsn Opcodes/ASTORE (int 0)) ;;
)
- ;; _ (prn "#4")
]
_ (compile ?body)
- :let [;; _ (prn "#5")
- _ (doto main-writer
+ :let [_ (doto main-writer
(.visitInsn Opcodes/ACONST_NULL)
- (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))
- ;; _ (prn "#6")
- ]
+ (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))]
:let [_ (doto main-writer
(.visitInsn Opcodes/POP)
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
- (.visitEnd))
- ;; _ (prn "#7")
- ]]
+ (.visitEnd))]]
(return nil)))))
diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj
new file mode 100644
index 000000000..bc6fa854d
--- /dev/null
+++ b/src/lux/compiler/io.clj
@@ -0,0 +1,29 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns lux.compiler.io
+ (:require (lux [base :as & :refer [|let |do return* return fail fail*]])
+ (lux.compiler [base :as &&])
+ [lux.lib.loader :as &lib]))
+
+;; [Utils]
+(def ^:private !libs (atom nil))
+
+(defn ^:private libs-imported? []
+ (not (nil? @!libs)))
+
+(defn ^:private init-libs! []
+ (reset! !libs (&lib/load)))
+
+;; [Resources]
+(defn read-file [^String file-name]
+ (let [file (new java.io.File (str &&/input-dir "/" file-name))]
+ (if (.exists file)
+ (return (slurp file))
+ (do (when (not (libs-imported?))
+ (init-libs!))
+ (if-let [code (get @!libs file-name)]
+ (return code)
+ (fail (str "[I/O Error] File doesn't exist: " file-name)))))))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index ccd12e68a..cb8ad0037 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -1,18 +1,15 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler.lambda
(:require (clojure [string :as string]
[set :as set]
[template :refer [do-template]])
- [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail*]]
+ (lux [base :as & :refer [|do return* return fail fail* |case]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
@@ -46,8 +43,8 @@
(.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
(.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
(->> (let [captured-name (str &&/closure-prefix ?captured-id)])
- (matchv ::M/objects [?name+?captured]
- [[?name [["captured" [_ ?captured-id ?source]] _]]])
+ (|case ?name+?captured
+ [?name [_ (&a/$captured _ ?captured-id ?source)]])
(doseq [?name+?captured (&/->seq env)])))
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
@@ -63,19 +60,20 @@
(.visitMaxs 0 0)
(.visitEnd)))
-(defn ^:private add-lambda-impl [class compile impl-signature impl-body]
- (&/with-writer (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil)
- (.visitCode))
- (|do [^MethodVisitor *writer* &/get-writer
- :let [$start (new Label)
- $end (new Label)]
- ret (compile impl-body)
- :let [_ (doto *writer*
- (.visitLabel $end)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return ret))))
+(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)]
+ (defn ^:private add-lambda-impl [class compile impl-signature impl-body]
+ (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" impl-signature nil nil)
+ (.visitCode))
+ (|do [^MethodVisitor *writer* &/get-writer
+ :let [$start (new Label)
+ $end (new Label)]
+ ret (compile impl-body)
+ :let [_ (doto *writer*
+ (.visitLabel $end)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return ret)))))
(defn ^:private instance-closure [compile lambda-class closed-over init-signature]
(|do [^MethodVisitor *writer* &/get-writer
@@ -83,31 +81,34 @@
(.visitTypeInsn Opcodes/NEW lambda-class)
(.visitInsn Opcodes/DUP))]
_ (&/map% (fn [?name+?captured]
- (matchv ::M/objects [?name+?captured]
- [[?name [["captured" [_ _ ?source]] _]]]
+ (|case ?name+?captured
+ [?name [_ (&a/$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 &/->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)
- 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)])))
- (add-lambda-apply class-name ?env)
- (add-lambda-<init> class-name ?env)
- )]
- _ (add-lambda-impl =class compile lambda-impl-signature ?body)
- :let [_ (.visitEnd =class)]
- _ (&&/save-class! name (.toByteArray =class))]
- (instance-closure compile class-name ?env (lambda-<init>-signature ?env))))
+(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)]
+ (defn compile-lambda [compile ?scope ?env ?body]
+ (|do [[file-name _ _] &/cursor
+ :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 lambda-flags
+ class-name nil "java/lang/Object" (into-array [&&/function-class]))
+ (-> (doto (.visitField datum-flags captured-name clo-field-sig nil nil)
+ (.visitEnd))
+ (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
+ (|case ?name+?captured
+ [?name [_ (&a/$captured _ ?captured-id ?source)]])
+ (doseq [?name+?captured (&/->seq ?env)])))
+ (.visitSource file-name nil)
+ (add-lambda-apply class-name ?env)
+ (add-lambda-<init> class-name ?env)
+ )]
+ _ (add-lambda-impl =class compile lambda-impl-signature ?body)
+ :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 b1023689e..01e4ffd5b 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -1,18 +1,15 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler.lux
(:require (clojure [string :as string]
[set :as set]
[template :refer [do-template]])
- [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let]]
+ (lux [base :as & :refer [|do return* return fail fail* |let |case]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
@@ -29,13 +26,13 @@
MethodVisitor)))
;; [Exports]
-(defn compile-bool [compile *type* ?value]
+(defn compile-bool [compile ?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>]
- (defn <name> [compile *type* value]
+ (defn <name> [compile value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW <class>)
@@ -49,12 +46,12 @@
compile-char "java/lang/Character" "(C)V" char
)
-(defn compile-text [compile *type* ?value]
+(defn compile-text [compile ?value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitLdcInsn *writer* ?value)]]
(return nil)))
-(defn compile-tuple [compile *type* ?elems]
+(defn compile-tuple [compile ?elems]
(|do [^MethodVisitor *writer* &/get-writer
:let [num-elems (&/|length ?elems)
_ (doto *writer*
@@ -70,28 +67,7 @@
(&/|range num-elems) ?elems)]
(return nil)))
-(defn compile-record [compile *type* ?elems]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [elems* (->> ?elems
- &/->seq
- (sort #(compare (&/|first %1) (&/|first %2)))
- &/->list)
- num-elems (&/|length elems*)
- _ (doto *writer*
- (.visitLdcInsn (int num-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]
+(defn compile-variant [compile ?tag ?value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitLdcInsn (int 2))
@@ -99,6 +75,7 @@
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 0))
(.visitLdcInsn ?tag)
+ (&&/wrap-long)
(.visitInsn Opcodes/AASTORE)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1)))]
@@ -106,12 +83,12 @@
:let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
(return nil)))
-(defn compile-local [compile *type* ?idx]
+(defn compile-local [compile ?idx]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]]
(return nil)))
-(defn compile-captured [compile *type* ?scope ?captured-id ?source]
+(defn compile-captured [compile ?scope ?captured-id ?source]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitVarInsn Opcodes/ALOAD 0)
@@ -121,12 +98,12 @@
"Ljava/lang/Object;"))]]
(return nil)))
-(defn compile-global [compile *type* ?owner-class ?name]
+(defn compile-global [compile ?owner-class ?name]
(|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) "_datum" "Ljava/lang/Object;")]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) &/datum-field "Ljava/lang/Object;")]]
(return nil)))
-(defn compile-apply [compile *type* ?fn ?args]
+(defn compile-apply [compile ?fn ?args]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?fn)
_ (&/map% (fn [?arg]
@@ -136,80 +113,106 @@
?args)]
(return nil)))
-(defn ^:private compile-def-type [compile ?body ?def-data]
+(defn ^:private compile-def-type [compile current-class ?body def-type]
(|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
- )]
+ (|case def-type
+ "type"
+ (|do [: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 &/$TypeD) ;; VVIT
+ (&&/wrap-long)
+ (.visitInsn Opcodes/AASTORE) ;; V
+ (.visitInsn Opcodes/DUP) ;; VV
+ (.visitLdcInsn (int 1)) ;; VVI
+ (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;")
+ (.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)
+ "value"
+ (|let [?def-type (|case ?body
+ [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr)]
+ ?type-expr
- [[?def-value ?def-type]]
- (&/T ?body (&&type/->analysis ?def-type)))]
+ [[?def-type ?def-cursor] ?def-value]
+ (&&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
+ (.visitLdcInsn &/$ValueD) ;; VVIT
+ (&&/wrap-long)
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
)]
+ :let [_ (doto **writer**
+ (.visitLdcInsn (int 2)) ;; S
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V
+ (.visitInsn Opcodes/DUP) ;; VV
+ (.visitLdcInsn (int 0)) ;; VVI
+ )]
_ (compile ?def-type)
+ :let [_ (.visitInsn **writer** Opcodes/AASTORE)]
+ :let [_ (doto **writer**
+ (.visitInsn Opcodes/DUP) ;; VV
+ (.visitLdcInsn (int 1)) ;; VVI
+ (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;")
+ (.visitInsn Opcodes/AASTORE))]
: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 [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 [&&/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))))]
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor **writer** &/get-writer
- :let [_ (.visitCode **writer**)]
- _ (compile ?body)
- :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**
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))
- :let [_ (.visitEnd *writer*)]
- _ (&&/save-class! def-name (.toByteArray =class))]
- (return nil)))
-
-(defn compile-ann [compile *type* ?value-ex ?type-ex]
+(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)]
+ (defn compile-def [compile ?name ?body]
+ (|do [:let [=value-type (&a/expr-type* ?body)
+ def-type (cond (&type/type= &type/Type =value-type)
+ "type"
+
+ :else
+ "value")]
+ ^ClassWriter *writer* &/get-writer
+ module-name &/get-module-name
+ [file-name _ _] &/cursor
+ :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 class-flags
+ current-class nil "java/lang/Object" (into-array [&&/function-class]))
+ (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/datum-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/meta-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (.visitSource file-name nil))]
+ _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
+ (|do [^MethodVisitor **writer** &/get-writer
+ :let [_ (.visitCode **writer**)]
+ _ (compile ?body)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)]
+ _ (compile-def-type compile current-class ?body def-type)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)]
+ :let [_ (doto **writer**
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))
+ :let [_ (.visitEnd *writer*)]
+ _ (&&/save-class! def-name (.toByteArray =class))
+ class-loader &/loader
+ :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))]
+ _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)]
+ (return nil))))
+
+(defn compile-ann [compile ?value-ex ?type-ex]
(compile ?value-ex))
(defn compile-declare-macro [compile module name]
diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj
new file mode 100644
index 000000000..b4b041049
--- /dev/null
+++ b/src/lux/compiler/module.clj
@@ -0,0 +1,25 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns lux.compiler.module
+ (:require (clojure [string :as string]
+ [set :as set]
+ [template :refer [do-template]])
+ clojure.core.match
+ clojure.core.match.array
+ (lux [base :as & :refer [|let |do return* return fail fail* |case]]
+ [type :as &type])
+ [lux.analyser.module :as &module]))
+
+;; [Exports]
+(def tag-groups
+ "(Lux (List (, Text (List Text))))"
+ (|do [module &/get-current-module]
+ (return (&/|map (fn [pair]
+ (|case pair
+ [name [tags _]]
+ (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags))))
+ (&/get$ &module/$types module)))
+ ))
diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj
deleted file mode 100644
index 40639e85a..000000000
--- a/src/lux/compiler/package.clj
+++ /dev/null
@@ -1,61 +0,0 @@
-;; 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
index a92911444..c1615f9b6 100644
--- a/src/lux/compiler/type.clj
+++ b/src/lux/compiler/type.clj
@@ -1,97 +1,86 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler.type
- (:require [clojure.core.match :as M :refer [matchv]]
+ (:require clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let]]
- [type :as &type])))
+ (lux [base :as & :refer [|do return* return fail fail* |let |case]]
+ [type :as &type])
+ [lux.analyser.base :as &a]))
;; [Utils]
(defn ^:private variant$ [tag body]
"(-> Text Analysis Analysis)"
- (&/T (&/V "variant" (&/T tag body))
- &type/$Void))
+ (&a/|meta &type/$Void &/empty-cursor
+ (&/V &a/$variant (&/T tag body))
+ ))
(defn ^:private tuple$ [members]
"(-> (List Analysis) Analysis)"
- (&/T (&/V "tuple" members)
- &type/$Void))
+ (&a/|meta &type/$Void &/empty-cursor
+ (&/V &a/$tuple members)
+ ))
+
+(defn ^:private int$ [value]
+ "(-> Int Analysis)"
+ (&a/|meta &type/$Void &/empty-cursor
+ (&/V &a/$int value)
+ ))
(defn ^:private text$ [text]
"(-> Text Analysis)"
- (&/T (&/V "text" text)
- &type/$Void))
+ (&a/|meta &type/$Void &/empty-cursor
+ (&/V &a/$text text)
+ ))
(def ^:private $Nil
"Analysis"
- (variant$ "lux;Nil" (tuple$ (&/|list))))
+ (variant$ &/$Nil (tuple$ &/Nil$)))
(defn ^:private Cons$ [head tail]
"(-> Analysis Analysis Analysis)"
- (variant$ "lux;Cons" (tuple$ (&/|list head tail))))
+ (variant$ &/$Cons (tuple$ (&/|list head tail))))
+
+(defn ^:private List$ [elems]
+ (&/fold (fn [tail head]
+ (Cons$ head tail))
+ $Nil
+ (&/|reverse elems)))
;; [Exports]
(defn ->analysis [type]
"(-> Type Analysis)"
- (matchv ::M/objects [type]
- [["lux;DataT" ?class]]
- (variant$ "lux;DataT" (text$ ?class))
+ (|case type
+ (&/$DataT class params)
+ (variant$ &/$DataT (tuple$ (&/|list (text$ class)
+ (List$ (&/|map ->analysis params)))))
- [["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))))
+ (&/$TupleT members)
+ (variant$ &/$TupleT (List$ (&/|map ->analysis members)))
+
+ (&/$VariantT members)
+ (variant$ &/$VariantT (List$ (&/|map ->analysis members)))
+
+ (&/$LambdaT input output)
+ (variant$ &/$LambdaT (tuple$ (&/|list (->analysis input) (->analysis output))))
+
+ (&/$UnivQ env body)
+ (variant$ &/$UnivQ
+ (tuple$ (&/|list (List$ (&/|map ->analysis env))
+ (->analysis body))))
+
+ (&/$BoundT idx)
+ (variant$ &/$BoundT (int$ idx))
+
+ (&/$AppT fun arg)
+ (variant$ &/$AppT (tuple$ (&/|list (->analysis fun) (->analysis arg))))
+
+ (&/$NamedT [module name] type*)
+ (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ module) (text$ name)))
+ (->analysis type*))))
+
+ _
+ (assert false (prn '->analysis (&type/show-type type) (&/adt->text type)))
))
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 906e3c714..916f94419 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -1,47 +1,40 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.host
(:require (clojure [string :as string]
[template :refer [do-template]])
- [clojure.core.match :as M :refer [match matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |let]]
- [type :as &type]))
- (:import (java.lang.reflect Field Method Modifier)))
+ (lux [base :as & :refer [|do return* return fail fail* |let |case]]
+ [type :as &type])
+ [lux.type.host :as &host-type])
+ (:import (java.lang.reflect Field Method Constructor Modifier Type)
+ java.util.regex.Pattern
+ (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor)))
;; [Constants]
(def prefix "lux.")
(def function-class (str prefix "Function"))
-(def module-separator "_")
-
-;; [Utils]
-(defn ^:private class->type [^Class class]
- (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$"
- (str (if-let [pkg (.getPackage class)]
- (str (.getName pkg) ".")
- "")
- (.getSimpleName class)))]
- (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]
- (class->type (.getReturnType method)))
+(def module-separator "/")
+(def class-name-separator ".")
+(def class-separator "/")
;; [Resources]
-(defn ^String ->class [class]
- (string/replace class #"\." "/"))
-
-(defn ^String ->module-class [module-name]
- (string/replace module-name #"/" module-separator))
+(do-template [<name> <old-sep> <new-sep>]
+ (let [regex (-> <old-sep> Pattern/quote re-pattern)]
+ (defn <name> [old]
+ (string/replace old regex <new-sep>)))
+
+ ^String ->class class-name-separator class-separator
+ ^String ->class-name module-separator class-name-separator
+ ^String ->module-class module-separator class-separator
+ )
(def ->package ->module-class)
@@ -64,27 +57,55 @@
(str "L" class* ";")))
))
-(defn ->java-sig [^objects type]
- (matchv ::M/objects [type]
- [["lux;DataT" ?name]]
- (->type-signature ?name)
+(defn unfold-array [type]
+ "(-> Type (, Int Type))"
+ (|case type
+ (&/$DataT "#Array" (&/$Cons param (&/$Nil)))
+ (|let [[count inner] (unfold-array param)]
+ (&/T (inc count) inner))
- [["lux;LambdaT" [_ _]]]
+ _
+ (&/T 0 type)))
+
+(defn ->java-sig [^objects type]
+ "(-> Type Text)"
+ (|case type
+ (&/$DataT ?name params)
+ (cond (= &host-type/array-data-tag ?name) (|let [[level base] (unfold-array type)
+ base-sig (|case base
+ (&/$DataT base-class _)
+ (->class base-class)
+
+ _
+ (->java-sig base))]
+ (str (->> (&/|repeat level "[") (&/fold str ""))
+ "L" base-sig ";"))
+ (= &host-type/null-data-tag ?name) (->type-signature "java.lang.Object")
+ :else (->type-signature ?name))
+
+ (&/$LambdaT _ _)
(->type-signature function-class)
- [["lux;TupleT" ["lux;Nil" _]]]
+ (&/$TupleT (&/$Nil))
"V"
+
+ (&/$NamedT ?name ?type)
+ (->java-sig ?type)
+
+ _
+ (assert false (str '->java-sig " " (&type/show-type type)))
))
(do-template [<name> <static?>]
(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))))
+ (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)]
+ (if-let [^Type gtype (first (for [^Field =field (.getDeclaredFields target-class)
+ :when (and (.equals ^Object field (.getName =field))
+ (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))]
+ (.getGenericType =field)))]
+ (|let [gvars (->> target-class .getTypeParameters seq &/->list)]
+ (return (&/T gvars gtype)))
+ (fail (str "[Host Error] Field does not exist: " target "." field)))))
lookup-static-field true
lookup-field false
@@ -92,21 +113,137 @@
(do-template [<name> <static?>]
(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))))
+ (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)]
+ (if-let [^Method method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader))
+ :when (and (.equals ^Object method-name (.getName =method))
+ (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method)))
+ (let [param-types (&/->list (seq (.getParameterTypes =method)))]
+ (and (= (&/|length args) (&/|length param-types))
+ (&/fold2 #(and %1 (.equals ^Object %2 %3))
+ true
+ args
+ (&/|map #(.getName ^Class %) param-types)))))]
+ =method))]
+ (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list)
+ gvars (->> method .getTypeParameters seq &/->list)
+ gargs (->> method .getGenericParameterTypes seq &/->list)]
+ (return (&/T (.getGenericReturnType method)
+ (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))
+ parent-gvars
+ gvars
+ gargs)))
+ (fail (str "[Host Error] Method does not exist: " target "." method-name)))))
lookup-static-method true
lookup-virtual-method false
)
+(defn lookup-constructor [class-loader target args]
+ ;; (prn 'lookup-constructor class-loader target (&host-type/as-obj target))
+ (let [target-class (Class/forName (&host-type/as-obj target) true class-loader)]
+ (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class)
+ :when (let [param-types (&/->list (seq (.getParameterTypes =method)))]
+ (and (= (&/|length args) (&/|length param-types))
+ (&/fold2 #(and %1 (.equals ^Object %2 %3))
+ true
+ args
+ (&/|map #(.getName ^Class %) param-types))))]
+ =method))]
+ (|let [gvars (->> target-class .getTypeParameters seq &/->list)
+ gargs (->> ctor .getGenericParameterTypes seq &/->list)
+ exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))]
+ (return (&/T exs gvars gargs)))
+ (fail (str "[Host Error] Constructor does not exist: " target)))))
+
+(defn abstract-methods [class-loader class]
+ (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj class) true class-loader))
+ :when (Modifier/isAbstract (.getModifiers =method))]
+ (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method)))))))))
+
(defn location [scope]
(->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str "")))
+
+(defn 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)))
+
+(let [object-real-class (->class "java.lang.Object")]
+ (defn ^:private dummy-return [^MethodVisitor writer name output]
+ (case output
+ "void" (if (= "<init>" name)
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL object-real-class "<init>" "()V")
+ (.visitInsn Opcodes/RETURN))
+ (.visitInsn writer Opcodes/RETURN))
+ "boolean" (doto writer
+ (.visitLdcInsn false)
+ (.visitInsn Opcodes/IRETURN))
+ "byte" (doto writer
+ (.visitLdcInsn (byte 0))
+ (.visitInsn Opcodes/IRETURN))
+ "short" (doto writer
+ (.visitLdcInsn (short 0))
+ (.visitInsn Opcodes/IRETURN))
+ "int" (doto writer
+ (.visitLdcInsn (int 0))
+ (.visitInsn Opcodes/IRETURN))
+ "long" (doto writer
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LRETURN))
+ "float" (doto writer
+ (.visitLdcInsn (float 0.0))
+ (.visitInsn Opcodes/FRETURN))
+ "double" (doto writer
+ (.visitLdcInsn (double 0.0))
+ (.visitInsn Opcodes/DRETURN))
+ "char" (doto writer
+ (.visitLdcInsn (char 0))
+ (.visitInsn Opcodes/IRETURN))
+ ;; else
+ (doto writer
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitInsn Opcodes/ARETURN)))))
+
+(defn use-dummy-class [name super-class interfaces fields methods]
+ (|do [module &/get-module-name
+ :let [full-name (str module "/" name)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+ full-name nil (->class super-class) (->> interfaces (&/|map ->class) &/->seq (into-array String))))
+ _ (&/|map (fn [field]
+ (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field)
+ (->type-signature (:type field)) nil nil)
+ (.visitEnd)))
+ fields)
+ _ (&/|map (fn [method]
+ (|let [signature (str "(" (&/fold str "" (&/|map ->type-signature (:inputs method))) ")"
+ (->type-signature (:output method)))]
+ (doto (.visitMethod =class (modifiers->int (:modifiers method))
+ (:name method)
+ signature
+ nil
+ (->> (:exceptions method) (&/|map ->class) &/->seq (into-array java.lang.String)))
+ .visitCode
+ (dummy-return (:name method) (:output method))
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+ methods)
+ bytecode (.toByteArray (doto =class .visitEnd))]
+ ^ClassLoader loader &/loader
+ !classes &/classes
+ :let [real-name (str (->class-name module) "." name)
+ _ (swap! !classes assoc real-name bytecode)
+ _ (.loadClass loader real-name)]]
+ (return nil)))
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index bb6e54cb4..651f9ecce 100644
--- a/src/lux/lexer.clj
+++ b/src/lux/lexer.clj
@@ -1,17 +1,33 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.lexer
(:require [clojure.template :refer [do-template]]
- (lux [base :as & :refer [|do return* return fail fail*]]
+ (lux [base :as & :refer [deftags |do return* return fail fail*]]
[reader :as &reader])
[lux.analyser.module :as &module]))
+;; [Tags]
+(deftags
+ ["White_Space"
+ "Comment"
+ "Bool"
+ "Int"
+ "Real"
+ "Char"
+ "Text"
+ "Symbol"
+ "Tag"
+ "Open_Paren"
+ "Close_Paren"
+ "Open_Bracket"
+ "Close_Bracket"
+ "Open_Brace"
+ "Close_Brace"]
+ )
+
;; [Utils]
(defn ^:private escape-char [escaped]
(cond (.equals ^Object escaped "\\t") (return "\t")
@@ -39,31 +55,23 @@
;; [Lexers]
(def ^:private lex-white-space
(|do [[meta white-space] (&reader/read-regex #"^(\s+)")]
- (return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space))))))
+ (return (&/T meta (&/V $White_Space white-space)))))
(def ^:private lex-single-line-comment
(|do [_ (&reader/read-text "##")
[meta comment] (&reader/read-regex #"^(.*)$")]
- (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment))))))
+ (return (&/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)^(?!#\()(.*?(?=\)#))")
- ;; :let [_ (prn 'immediate comment)]
- _ (&reader/read-text ")#")]
+ [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex+ #"(?is)^(?!#\()((?!\)#).)*")]
(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))]
- ]
+ (|do [[meta pre] (&reader/read-regex+ #"(?is)^((?!#\().)*")
+ [_ ($Comment inner)] (lex-multi-line-comment nil)
+ [_ post] (&reader/read-regex+ #"(?is)^((?!\)#).)*")]
(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))))))
+ (return (&/T meta (&/V $Comment comment)))))
(def ^:private lex-comment
(&/try-all% (&/|list lex-single-line-comment
@@ -72,11 +80,11 @@
(do-template [<name> <tag> <regex>]
(def <name>
(|do [[meta token] (&reader/read-regex <regex>)]
- (return (&/V "lux;Meta" (&/T meta (&/V <tag> token))))))
+ (return (&/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\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)"
+ ^:private lex-bool $Bool #"^(true|false)"
+ ^: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
@@ -86,13 +94,13 @@
(|do [[_ char] (&reader/read-regex #"^(.)")]
(return char))))
_ (&reader/read-text "\"")]
- (return (&/V "lux;Meta" (&/T meta (&/V "Char" token))))))
+ (return (&/T meta (&/V $Char token)))))
(def ^:private lex-text
(|do [[meta _] (&reader/read-text "\"")
token (lex-text-body nil)
_ (&reader/read-text "\"")]
- (return (&/V "lux;Meta" (&/T meta (&/V "Text" token))))))
+ (return (&/T meta (&/V $Text token)))))
(def ^:private lex-ident
(&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)]
@@ -101,10 +109,8 @@
? (&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)))))))
+ (|do [unaliased (&module/dealias token)]
+ (return (&/T meta (&/T unaliased local-token))))))
(return (&/T meta (&/T "" token)))
)))
(|do [[meta _] (&reader/read-text ";;")
@@ -118,24 +124,24 @@
(def ^:private lex-symbol
(|do [[meta ident] lex-ident]
- (return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident))))))
+ (return (&/T meta (&/V $Symbol ident)))))
(def ^:private lex-tag
(|do [[meta _] (&reader/read-text "#")
[_ ident] lex-ident]
- (return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident))))))
+ (return (&/T meta (&/V $Tag ident)))))
(do-template [<name> <text> <tag>]
(def <name>
(|do [[meta _] (&reader/read-text <text>)]
- (return (&/V "lux;Meta" (&/T meta (&/V <tag> nil))))))
-
- ^:private lex-open-paren "(" "Open_Paren"
- ^:private lex-close-paren ")" "Close_Paren"
- ^:private lex-open-bracket "[" "Open_Bracket"
- ^:private lex-close-bracket "]" "Close_Bracket"
- ^:private lex-open-brace "{" "Open_Brace"
- ^:private lex-close-brace "}" "Close_Brace"
+ (return (&/T meta (&/V <tag> nil)))))
+
+ ^:private lex-open-paren "(" $Open_Paren
+ ^:private lex-close-paren ")" $Close_Paren
+ ^:private lex-open-bracket "[" $Open_Bracket
+ ^:private lex-close-bracket "]" $Close_Bracket
+ ^:private lex-open-brace "{" $Open_Brace
+ ^:private lex-close-brace "}" $Close_Brace
)
(def ^:private lex-delimiter
diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj
new file mode 100644
index 000000000..13810238a
--- /dev/null
+++ b/src/lux/lib/loader.clj
@@ -0,0 +1,60 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns lux.lib.loader
+ (:refer-clojure :exclude [load])
+ (:require (lux [base :as & :refer [|let |do return fail return* fail* |case]]))
+ (:import (java.io InputStream
+ File
+ FileInputStream
+ ByteArrayInputStream
+ ByteArrayOutputStream)
+ java.util.zip.GZIPInputStream
+ (org.apache.commons.compress.archivers.tar TarArchiveEntry
+ TarArchiveInputStream)))
+
+;; [Utils]
+(defn ^:private fetch-libs []
+ (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader)
+ (.getURLs)
+ seq
+ (map #(.getFile ^java.net.URL %))
+ (filter #(.endsWith ^String % ".tar.gz"))
+ (map #(new File ^String %))))
+
+(let [init-capacity (* 100 1024)
+ buffer-size 1024]
+ (defn ^:private ^"[B" read-stream [^InputStream is]
+ (let [buffer (byte-array buffer-size)]
+ (with-open [os (new ByteArrayOutputStream init-capacity)]
+ (loop [bytes-read (.read is buffer 0 buffer-size)]
+ (when (not= -1 bytes-read)
+ (do (.write os buffer 0 bytes-read)
+ (recur (.read is buffer 0 buffer-size)))))
+ (.toByteArray os)))))
+
+(defn ^:private unpackage [^File lib-file]
+ (let [is (->> lib-file
+ (new FileInputStream)
+ (new GZIPInputStream)
+ (new TarArchiveInputStream))]
+ (loop [lib-data {}
+ entry (.getNextTarEntry is)]
+ (if entry
+ (recur (assoc lib-data (.getName entry) (new String (read-stream is)))
+ (.getNextTarEntry is))
+ lib-data))))
+
+;; [Exports]
+(def lib-ext ".tar.gz")
+
+(defn load []
+ (->> (fetch-libs)
+ (map unpackage)
+ (reduce merge {})))
+
+(comment
+ (->> &/lib-dir load keys)
+ )
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index 5056a09e0..1325a2e7d 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -1,10 +1,7 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.optimizer
(:require [lux.analyser :as &analyser]))
@@ -22,5 +19,5 @@
;; Local var aliasing.
;; [Exports]
-(defn optimize [eval! compile-module]
- (&analyser/analyse eval! compile-module))
+(defn optimize [eval! compile-module compile-token]
+ (&analyser/analyse eval! compile-module compile-token))
diff --git a/src/lux/packager/lib.clj b/src/lux/packager/lib.clj
new file mode 100644
index 000000000..af48e31eb
--- /dev/null
+++ b/src/lux/packager/lib.clj
@@ -0,0 +1,41 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns lux.packager.lib
+ (:require [lux.lib.loader :as &lib])
+ (:import (java.io File
+ FileOutputStream)
+ java.util.zip.GZIPOutputStream
+ (org.apache.commons.compress.archivers.tar TarArchiveEntry
+ TarArchiveOutputStream)
+ ))
+
+;; [Utils]
+(defn ^:private read-file ^objects [^File file]
+ (with-open [is (java.io.FileInputStream. file)]
+ (let [data (byte-array (.length file))]
+ (.read is data)
+ data)))
+
+(defn ^:private add-to-tar! [prefix ^File file ^TarArchiveOutputStream os]
+ "(-> Text File TarArchiveOutputStream Unit)"
+ (let [file-name (str prefix "/" (.getName file))]
+ (if (.isDirectory file)
+ (doseq [file (seq (.listFiles file))]
+ (add-to-tar! file-name file os))
+ (let [data (read-file file)]
+ (doto os
+ (.putArchiveEntry (doto (new TarArchiveEntry file-name)
+ (.setSize (.length file))))
+ (.write data 0 (alength data))
+ (.closeArchiveEntry))))))
+
+;; [Exports]
+(defn package [output-lib-name ^File source-dir]
+ "(-> Text File Unit)"
+ (with-open [out (->> (str output-lib-name &lib/lib-ext) (new FileOutputStream) (new GZIPOutputStream) (new TarArchiveOutputStream))]
+ (doseq [file (seq (.listFiles source-dir))]
+ (add-to-tar! "" file out))
+ ))
diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj
new file mode 100644
index 000000000..83927ba0d
--- /dev/null
+++ b/src/lux/packager/program.clj
@@ -0,0 +1,99 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns lux.packager.program
+ (: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 InputStream
+ File
+ FileInputStream
+ FileOutputStream
+ BufferedInputStream
+ ByteArrayOutputStream)
+ (java.util.jar Manifest
+ Attributes$Name
+ JarEntry
+ JarInputStream
+ 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)
+ ))
+ ))
+
+(let [output-dir-size (.length &&/output-dir)]
+ (defn ^:private write-module! [^File file ^JarOutputStream out]
+ "(-> File JarOutputStream Unit)"
+ (let [module-name (.substring (.getPath file) output-dir-size)
+ inner-files (.listFiles file)
+ inner-modules (filter #(.isDirectory ^File %) inner-files)
+ inner-classes (filter #(not (.isDirectory ^File %)) inner-files)]
+ (doseq [$class inner-classes]
+ (write-class! module-name $class out))
+ (doseq [$module inner-modules]
+ (write-module! $module out)))))
+
+(defn ^:private fetch-available-jars []
+ (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader)
+ (.getURLs)
+ (map #(.getFile ^java.net.URL %))
+ (filter #(.endsWith ^String % ".jar"))))
+
+(let [init-capacity (* 100 1024)
+ buffer-size 1024]
+ (defn ^:private ^"[B" read-stream [^InputStream is]
+ (let [buffer (byte-array buffer-size)]
+ (with-open [os (new ByteArrayOutputStream init-capacity)]
+ (loop [bytes-read (.read is buffer 0 buffer-size)]
+ (when (not= -1 bytes-read)
+ (do (.write os buffer 0 bytes-read)
+ (recur (.read is buffer 0 buffer-size)))))
+ (.toByteArray os)))))
+
+(defn ^:private add-jar! [^File jar-file ^JarOutputStream out]
+ (with-open [is (->> jar-file (new FileInputStream) (new JarInputStream))]
+ (loop [^JarEntry entry (.getNextJarEntry is)]
+ (when entry
+ (when (and (not (.isDirectory entry))
+ (not (.startsWith (.getName entry) "META-INF/")))
+ (let [entry-data (read-stream is)]
+ (doto out
+ (.putNextEntry entry)
+ (.write entry-data 0 (alength entry-data))
+ (.flush)
+ (.closeEntry))))
+ (recur (.getNextJarEntry is))))))
+
+;; [Resources]
+(defn package [module]
+ "(-> Text (,))"
+ (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))]
+ (doseq [$group (.listFiles (new File &&/output-dir))]
+ (write-module! $group out))
+ (doseq [^String jar-file (fetch-available-jars)]
+ (add-jar! (new File jar-file) out))
+ ))
diff --git a/src/lux/parser.clj b/src/lux/parser.clj
index 966c322bf..516b6a947 100644
--- a/src/lux/parser.clj
+++ b/src/lux/parser.clj
@@ -1,16 +1,13 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.parser
(:require [clojure.template :refer [do-template]]
- [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return fail]]
+ (lux [base :as & :refer [deftags |do return fail |case]]
[lexer :as &lexer])))
;; [Utils]
@@ -18,75 +15,74 @@
(defn <name> [parse]
(|do [elems (&/repeat% parse)
token &lexer/lex]
- (matchv ::M/objects [token]
- [["lux;Meta" [meta [<close-token> _]]]]
- (return (&/V <tag> (&/fold &/|++ (&/|list) elems)))
+ (|case token
+ [meta [<close-token> _]]
+ (return (&/V <tag> (&/fold &/|++ &/Nil$ elems)))
- [_]
+ _
(fail (str "[Parser Error] Unbalanced " <description> ".")))))
- ^:private parse-form "Close_Paren" "parantheses" "lux;FormS"
- ^:private parse-tuple "Close_Bracket" "brackets" "lux;TupleS"
+ ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS
+ ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS
)
(defn ^:private parse-record [parse]
(|do [elems* (&/repeat% parse)
token &lexer/lex
- :let [elems (&/fold &/|++ (&/|list) elems*)]]
- (matchv ::M/objects [token]
- [["lux;Meta" [meta ["Close_Brace" _]]]]
+ :let [elems (&/fold &/|++ &/Nil$ elems*)]]
+ (|case token
+ [meta (&lexer/$Close_Brace _)]
(if (even? (&/|length elems))
- (return (&/V "lux;RecordS" (&/|as-pairs elems)))
+ (return (&/V &/$RecordS (&/|as-pairs elems)))
(fail (str "[Parser Error] Records must have an even number of elements.")))
- [_]
+ _
(fail (str "[Parser Error] Unbalanced braces.")))))
;; [Interface]
(def parse
- (|do [token &lexer/lex]
- (matchv ::M/objects [token]
- [["lux;Meta" [meta token*]]]
- (matchv ::M/objects [token*]
- [["White_Space" _]]
- (return (&/|list))
+ (|do [token &lexer/lex
+ :let [[meta token*] token]]
+ (|case token*
+ (&lexer/$White_Space _)
+ (return &/Nil$)
- [["Comment" _]]
- (return (&/|list))
-
- [["Bool" ?value]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value))))))
+ (&lexer/$Comment _)
+ (return &/Nil$)
+
+ (&lexer/$Bool ?value)
+ (return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))
- [["Int" ?value]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value))))))
+ (&lexer/$Int ?value)
+ (return (&/|list (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))
- [["Real" ?value]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value))))))
+ (&lexer/$Real ?value)
+ (return (&/|list (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))
- [["Char" ^String ?value]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0))))))
+ (&lexer/$Char ^String ?value)
+ (return (&/|list (&/T meta (&/V &/$CharS (.charAt ?value 0)))))
- [["Text" ?value]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value)))))
+ (&lexer/$Text ?value)
+ (return (&/|list (&/T meta (&/V &/$TextS ?value))))
- [["Symbol" ?ident]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident)))))
+ (&lexer/$Symbol ?ident)
+ (return (&/|list (&/T meta (&/V &/$SymbolS ?ident))))
- [["Tag" ?ident]]
- (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident)))))
+ (&lexer/$Tag ?ident)
+ (return (&/|list (&/T meta (&/V &/$TagS ?ident))))
- [["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)))))
+ (&lexer/$Open_Paren _)
+ (|do [syntax (parse-form parse)]
+ (return (&/|list (&/T meta syntax))))
+
+ (&lexer/$Open_Bracket _)
+ (|do [syntax (parse-tuple parse)]
+ (return (&/|list (&/T meta syntax))))
- [["Open_Brace" _]]
- (|do [syntax (parse-record parse)]
- (return (&/|list (&/V "lux;Meta" (&/T meta syntax)))))
+ (&lexer/$Open_Brace _)
+ (|do [syntax (parse-record parse)]
+ (return (&/|list (&/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 9fd9b14ea..751df7e6d 100644
--- a/src/lux/reader.clj
+++ b/src/lux/reader.clj
@@ -1,51 +1,53 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.reader
(:require [clojure.string :as string]
- [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match
clojure.core.match.array
- [lux.base :as & :refer [|do return* return fail fail* |let]]))
+ [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]]))
+
+;; [Tags]
+(deftags
+ ["No"
+ "Done"
+ "Yes"])
;; [Utils]
(defn ^:private with-line [body]
(fn [state]
- (matchv ::M/objects [(&/get$ &/$SOURCE state)]
- [["lux;Nil" _]]
+ (|case (&/get$ &/$source state)
+ (&/$Nil)
(fail* "[Reader Error] EOF")
- [["lux;Cons" [[[file-name line-num column-num] line]
- more]]]
- (matchv ::M/objects [(body file-name line-num column-num line)]
- [["No" msg]]
+ (&/$Cons [[file-name line-num column-num] line]
+ more)
+ (|case (body file-name line-num column-num line)
+ ($No msg)
(fail* msg)
- [["Done" output]]
- (return* (&/set$ &/$SOURCE more state)
+ ($Done output)
+ (return* (&/set$ &/$source more state)
output)
- [["Yes" [output line*]]]
- (return* (&/set$ &/$SOURCE (&/|cons line* more) state)
+ ($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)
+ (|case (body (&/get$ &/$source state))
+ (&/$Right reader* match)
+ (return* (&/set$ &/$source reader* state)
match)
- [["lux;Left" msg]]
+ (&/$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))
@@ -53,13 +55,6 @@
(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))
@@ -69,78 +64,76 @@
(.group matcher 1)
(.group matcher 2)))))
+;; [Exports]
(defn read-regex [regex]
(with-line
(fn [file-name line-num column-num ^String 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)
+ (if-let [^String match (re-find! regex column-num line)]
+ (let [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))))))
+ (&/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]
- ;; (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)
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))))))
+ (&/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))]
+ (|case reader*
+ (&/$Nil)
+ (&/V &/$Left "[Reader Error] EOF")
+
+ (&/$Cons [[file-name line-num column-num] ^String line]
+ reader**)
+ (if-let [^String match (re-find! regex column-num line)]
(let [match-length (.length match)
- column-num* (+ column-num match-length)]
+ column-num* (+ column-num match-length)
+ prefix* (if (= 0 column-num)
+ (str prefix "\n" match)
+ (str prefix match))]
(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))))))))
+ (recur prefix* reader**)
+ (&/V &/$Right (&/T (&/Cons$ (&/T (&/T file-name line-num column-num*) line)
+ reader**)
+ (&/T (&/T file-name line-num column-num) prefix*)))))
+ (&/V &/$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 [file-name line-num column-num text line])
(if (.startsWith line text column-num)
(let [match-length (.length text)
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))))))
-
-(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-num line] line+line-num]
- (&/T (&/T file-name (inc line-num) 0)
- line)))
- (&/|filter (fn [line+line-num]
- (|let [[line-num line] line+line-num]
- (not= "" line)))
- (&/enumerate lines)))))
+ (&/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 [^String name ^String source-code]
+ (->> source-code
+ (string/split-lines)
+ (&/->list)
+ (&/enumerate)
+ (&/|filter (fn [line+line-num]
+ (|let [[line-num line] line+line-num]
+ (not= "" line))))
+ (&/|map (fn [line+line-num]
+ (|let [[line-num line] line+line-num]
+ (&/T (&/T name (inc line-num) 0)
+ line))))))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index f5b8d3f25..6ae542b68 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -1,240 +1,184 @@
-;; 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.
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.type
(:refer-clojure :exclude [deref apply merge bound?])
- (:require [clojure.core.match :as M :refer [match matchv]]
+ (:require clojure.core.match
clojure.core.match.array
- [lux.base :as & :refer [|do return* return fail fail* assert! |let]]))
+ (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]])
+ [lux.type.host :as &&host]))
(declare show-type)
-;; [Util]
-(def Bool (&/V "lux;DataT" "java.lang.Boolean"))
-(def Int (&/V "lux;DataT" "java.lang.Long"))
-(def Real (&/V "lux;DataT" "java.lang.Double"))
-(def Char (&/V "lux;DataT" "java.lang.Character"))
-(def Text (&/V "lux;DataT" "java.lang.String"))
-(def Unit (&/V "lux;TupleT" (&/|list)))
-(def $Void (&/V "lux;VariantT" (&/|list)))
+;; [Utils]
+(defn |list? [xs]
+ (|case xs
+ (&/$Nil)
+ true
+
+ (&/$Cons x xs*)
+ (|list? xs*)
+
+ _
+ false))
+
+(def empty-env &/Nil$)
+(defn Data$ [name params]
+ (&/V &/$DataT (&/T name params)))
+(defn Bound$ [idx]
+ (&/V &/$BoundT idx))
+(defn Var$ [id]
+ (&/V &/$VarT id))
+(defn Lambda$ [in out]
+ (&/V &/$LambdaT (&/T in out)))
+(defn App$ [fun arg]
+ (&/V &/$AppT (&/T fun arg)))
+(defn Tuple$ [members]
+ (&/V &/$TupleT members))
+(defn Variant$ [members]
+ (&/V &/$VariantT members))
+(defn Univ$ [env body]
+ (&/V &/$UnivQ (&/T env body)))
+(defn Named$ [name type]
+ (&/V &/$NamedT (&/T name type)))
+
+
+(def Bool (Named$ (&/T "lux" "Bool") (Data$ "java.lang.Boolean" &/Nil$)))
+(def Int (Named$ (&/T "lux" "Int") (Data$ "java.lang.Long" &/Nil$)))
+(def Real (Named$ (&/T "lux" "Real") (Data$ "java.lang.Double" &/Nil$)))
+(def Char (Named$ (&/T "lux" "Char") (Data$ "java.lang.Character" &/Nil$)))
+(def Text (Named$ (&/T "lux" "Text") (Data$ "java.lang.String" &/Nil$)))
+(def Unit (Named$ (&/T "lux" "Unit") (Tuple$ &/Nil$)))
+(def $Void (Named$ (&/T "lux" "Void") (Variant$ &/Nil$)))
+(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text))))
(def IO
- (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "IO" "a"
- (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a"))))))
+ (Named$ (&/T "lux/data" "IO")
+ (Univ$ empty-env
+ (Lambda$ Unit (Bound$ 1)))))
(def List
- (&/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" "lux;List")
- (&/V "lux;BoundT" "a")))))))))))
+ (Named$ (&/T "lux" "List")
+ (Univ$ empty-env
+ (Variant$ (&/|list
+ ;; lux;Nil
+ Unit
+ ;; lux;Cons
+ (Tuple$ (&/|list (Bound$ 1)
+ (App$ (Bound$ 0)
+ (Bound$ 1))))
+ )))))
(def Maybe
- (&/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")))))))
+ (Named$ (&/T "lux" "Maybe")
+ (Univ$ empty-env
+ (Variant$ (&/|list
+ ;; lux;None
+ Unit
+ ;; lux;Some
+ (Bound$ 1)
+ )))))
(def Type
- (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;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)
- (&/T "lux;RecordT" TypeEnv)
- (&/T "lux;LambdaT" TypePair)
- (&/T "lux;BoundT" Text)
- (&/T "lux;VarT" Int)
- (&/T "lux;AllT" (&/V "lux;TupleT" (&/|list (&/V "lux;AppT" (&/T Maybe TypeEnv)) Text Text Type)))
- (&/T "lux;AppT" TypePair)
- (&/T "lux;ExT" Int)
- ))))
- $Void))))
-
-(defn fAll [name arg body]
- (&/V "lux;AllT" (&/T (&/V "lux;None" nil) name arg body)))
-
-(def Bindings
- (fAll "lux;Bindings" "k"
- (fAll "" "v"
- (&/V "lux;RecordT" (&/|list (&/T "lux;counter" Int)
- (&/T "lux;mappings" (&/V "lux;AppT" (&/T List
- (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "k")
- (&/V "lux;BoundT" "v")))))))))))
-
-(def Env
- (let [bindings (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings (&/V "lux;BoundT" "k")))
- (&/V "lux;BoundT" "v")))]
- (fAll "lux;Env" "k"
- (fAll "" "v"
- (&/V "lux;RecordT"
- (&/|list (&/T "lux;name" Text)
- (&/T "lux;inner-closures" Int)
- (&/T "lux;locals" bindings)
- (&/T "lux;closure" bindings)
- ))))))
-
-(def Cursor
- (&/V "lux;TupleT" (&/|list Text Int Int)))
-
-(def Meta
- (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")))))))))
-
-(def Ident (&/V "lux;TupleT" (&/|list Text Text)))
-
-(def Syntax*
- (let [Syntax* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w")
- (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Syntax'")
- (&/V "lux;BoundT" "w")))))
- Syntax*List (&/V "lux;AppT" (&/T List 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
- (let [w (&/V "lux;AppT" (&/T Meta Cursor))]
- (&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T Syntax* w))))))
-
-(def ^:private SyntaxList (&/V "lux;AppT" (&/T List Syntax)))
-
-(def Either
- (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 "lux;StateE" "s"
- (fAll "" "a"
- (&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s")
- (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text))
- (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "s")
- (&/V "lux;BoundT" "a"))))))))))
-
-(def Reader
- (&/V "lux;AppT" (&/T List
- (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Meta Cursor))
- Text)))))
-
-(def HostState
- (&/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;classes" (&/V "lux;DataT" "clojure.lang.Atom")))))
-
-(def DefData*
- (fAll "lux;DefData'" ""
- (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Unit)
- (&/T "lux;ValueD" Type)
- (&/T "lux;MacroD" (&/V "lux;BoundT" ""))
- (&/T "lux;AliasD" Ident)))))
-
-(def LuxVar
- (&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int)
- (&/T "lux;Global" Ident))))
-
-(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" Reader)
- (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT"
- (&/|list Text
- (&/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;eval?" Bool))))
- $Void)))
-
-(def Macro
- (&/V "lux;LambdaT" (&/T SyntaxList
- (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler))
- SyntaxList)))))
+ (Named$ (&/T "lux" "Type")
+ (let [Type (App$ (Bound$ 0) (Bound$ 1))
+ TypeList (App$ List Type)
+ TypePair (Tuple$ (&/|list Type Type))]
+ (App$ (Univ$ empty-env
+ (Variant$ (&/|list
+ ;; DataT
+ (Tuple$ (&/|list Text TypeList))
+ ;; VariantT
+ TypeList
+ ;; TupleT
+ TypeList
+ ;; LambdaT
+ TypePair
+ ;; BoundT
+ Int
+ ;; VarT
+ Int
+ ;; ExT
+ Int
+ ;; UnivQ
+ (Tuple$ (&/|list TypeList Type))
+ ;; ExQ
+ (Tuple$ (&/|list TypeList Type))
+ ;; AppT
+ TypePair
+ ;; NamedT
+ (Tuple$ (&/|list Ident Type))
+ )))
+ $Void))))
+
+(def Macro)
+
+(defn set-macro-type! [type]
+ (def Macro type)
+ nil)
(defn bound? [id]
(fn [state]
- (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
- (matchv ::M/objects [type]
- [["lux;Some" type*]]
+ (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
+ (|case type
+ (&/$Some type*)
(return* state true)
- [["lux;None" _]]
+ (&/$None)
(return* state false))
(fail* (str "[Type Error] <bound?> Unknown type-var: " id)))))
(defn deref [id]
(fn [state]
- (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
- (matchv ::M/objects [type*]
- [["lux;Some" type]]
+ (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
+ (|case type*
+ (&/$Some type)
(return* state type)
- [["lux;None" _]]
+ (&/$None)
(fail* (str "[Type Error] Unbound type-var: " id)))
(fail* (str "[Type Error] <deref> Unknown type-var: " id)))))
+(defn deref+ [type]
+ (|case type
+ (&/$VarT id)
+ (deref id)
+
+ _
+ (fail (str "[Type Error] Type is not a variable: " (show-type type)))
+ ))
+
(defn set-var [id type]
(fn [state]
- (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
- (matchv ::M/objects [tvar]
- [["lux;Some" bound]]
+ (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
+ (|case tvar
+ (&/$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))
+ (&/$None)
+ (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %)
+ ts))
state)
nil))
- (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length))))))
+ (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))))))
;; [Exports]
;; Type vars
(def ^:private create-var
(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))))
+ (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))]
+ (return* (&/update$ &/$type-vars #(->> %
+ (&/update$ &/$counter inc)
+ (&/update$ &/$mappings (fn [ms] (&/|put id &/None$ ms))))
state)
id))))
(def existential
+ ;; (Lux Type)
(|do [seed &/gen-id]
- (return (&/V "lux;ExT" seed))))
+ (return (&/V &/$ExT seed))))
(declare clean*)
(defn ^:private delete-var [id]
@@ -248,249 +192,190 @@
(|let [[?id ?type] binding]
(if (.equals ^Object id ?id)
(return binding)
- (matchv ::M/objects [?type]
- [["lux;None" _]]
+ (|case ?type
+ (&/$None)
(return binding)
- [["lux;Some" ?type*]]
- (matchv ::M/objects [?type*]
- [["lux;VarT" ?id*]]
+ (&/$Some ?type*)
+ (|case ?type*
+ (&/$VarT ?id*)
(if (.equals ^Object id ?id*)
- (return (&/T ?id (&/V "lux;None" nil)))
+ (return (&/T ?id &/None$))
(return binding))
- [_]
+ _
(|do [?type** (clean* id ?type*)]
- (return (&/T ?id (&/V "lux;Some" ?type**)))))
+ (return (&/T ?id (&/V &/$Some ?type**)))))
))))
- (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))]
+ (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))]
(fn [state]
- (return* (&/update$ &/$TYPES #(->> %
- (&/update$ &/$COUNTER dec)
- (&/set$ &/$MAPPINGS (&/|remove id mappings*)))
+ (return* (&/update$ &/$type-vars #(&/set$ &/$mappings (&/|remove id mappings*) %)
state)
nil)))
state))))
(defn with-var [k]
(|do [id create-var
- output (k (&/V "lux;VarT" id))
+ output (k (Var$ id))
_ (delete-var id)]
(return output)))
-(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 clean* [?tid type]
- (matchv ::M/objects [type]
- [["lux;VarT" ?id]]
+ (|case type
+ (&/$VarT ?id)
(if (.equals ^Object ?tid ?id)
(deref ?id)
(return type))
- [["lux;LambdaT" [?arg ?return]]]
+ (&/$LambdaT ?arg ?return)
(|do [=arg (clean* ?tid ?arg)
=return (clean* ?tid ?return)]
- (return (&/V "lux;LambdaT" (&/T =arg =return))))
+ (return (Lambda$ =arg =return)))
- [["lux;AppT" [?lambda ?param]]]
+ (&/$AppT ?lambda ?param)
(|do [=lambda (clean* ?tid ?lambda)
=param (clean* ?tid ?param)]
- (return (&/V "lux;AppT" (&/T =lambda =param))))
+ (return (App$ =lambda =param)))
- [["lux;TupleT" ?members]]
+ (&/$TupleT ?members)
(|do [=members (&/map% (partial clean* ?tid) ?members)]
- (return (&/V "lux;TupleT" =members)))
+ (return (Tuple$ =members)))
- [["lux;VariantT" ?members]]
- (|do [=members (&/map% (fn [[k v]]
- (|do [=v (clean* ?tid v)]
- (return (&/T k =v))))
- ?members)]
- (return (&/V "lux;VariantT" =members)))
-
- [["lux;RecordT" ?members]]
- (|do [=members (&/map% (fn [[k v]]
- (|do [=v (clean* ?tid v)]
- (return (&/T k =v))))
- ?members)]
- (return (&/V "lux;RecordT" =members)))
-
- [["lux;AllT" [?env ?name ?arg ?body]]]
- (|do [=env (matchv ::M/objects [?env]
- [["lux;None" _]]
- (return ?env)
-
- [["lux;Some" ?env*]]
- (|do [clean-env (&/map% (fn [[k v]]
- (|do [=v (clean* ?tid v)]
- (return (&/T k =v))))
- ?env*)]
- (return (&/V "lux;Some" clean-env))))
+ (&/$VariantT ?members)
+ (|do [=members (&/map% (partial clean* ?tid) ?members)]
+ (return (Variant$ =members)))
+
+ (&/$UnivQ ?env ?body)
+ (|do [=env (&/map% (partial clean* ?tid) ?env)
body* (clean* ?tid ?body)]
- (return (&/V "lux;AllT" (&/T =env ?name ?arg body*))))
+ (return (Univ$ =env body*)))
- [_]
+ _
(return type)
))
(defn clean [tvar type]
- (matchv ::M/objects [tvar]
- [["lux;VarT" ?id]]
+ (|case tvar
+ (&/$VarT ?id)
(clean* ?id type)
- [_]
+ _
(fail (str "[Type Error] Not type-var: " (show-type tvar)))))
(defn ^:private unravel-fun [type]
- (matchv ::M/objects [type]
- [["lux;LambdaT" [?in ?out]]]
+ (|case type
+ (&/$LambdaT ?in ?out)
(|let [[??out ?args] (unravel-fun ?out)]
- (&/T ??out (&/|cons ?in ?args)))
+ (&/T ??out (&/Cons$ ?in ?args)))
- [_]
- (&/T type (&/|list))))
+ _
+ (&/T type &/Nil$)))
(defn ^:private unravel-app [fun-type]
- (matchv ::M/objects [fun-type]
- [["lux;AppT" [?left ?right]]]
+ (|case fun-type
+ (&/$AppT ?left ?right)
(|let [[?fun-type ?args] (unravel-app ?left)]
(&/T ?fun-type (&/|++ ?args (&/|list ?right))))
- [_]
- (&/T fun-type (&/|list))))
+ _
+ (&/T fun-type &/Nil$)))
(defn show-type [^objects type]
- (matchv ::M/objects [type]
- [["lux;DataT" name]]
- (str "(^ " name ")")
+ (|case type
+ (&/$DataT name params)
+ (|case params
+ (&/$Nil)
+ (str "(^ " name ")")
+
+ _
+ (str "(^ " name " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
- [["lux;TupleT" elems]]
+ (&/$TupleT elems)
(if (&/|empty? elems)
"(,)"
(str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
- [["lux;VariantT" cases]]
+ (&/$VariantT cases)
(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) ")"))))
+ (&/|map show-type)
(&/|interpose " ")
(&/fold str "")) ")"))
-
- [["lux;RecordT" fields]]
- (str "(& " (->> fields
- (&/|map (fn [kv]
- (matchv ::M/objects [kv]
- [[k v]]
- (str "#" k " " (show-type v)))))
- (&/|interpose " ")
- (&/fold str "")) ")")
-
- [["lux;LambdaT" [input output]]]
+ (&/$LambdaT input output)
(|let [[?out ?ins] (unravel-fun type)]
(str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")"))
- [["lux;VarT" id]]
+ (&/$VarT id)
(str "⌈" id "⌋")
- [["lux;ExT" ?id]]
+ (&/$ExT ?id)
(str "⟨" ?id "⟩")
- [["lux;BoundT" name]]
- name
+ (&/$BoundT idx)
+ (str idx)
- [["lux;AppT" [_ _]]]
+ (&/$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]]]
- (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)
- ))
+ (&/$UnivQ ?env ?body)
+ (str "(All " (show-type ?body) ")")
+
+ (&/$NamedT ?name ?type)
+ (&/ident->text ?name)
+
+ _
+ (assert false (prn-str 'show-type (&/adt->text type)))))
(defn type= [x y]
(or (clojure.lang.Util/identical x y)
- (let [output (matchv ::M/objects [x y]
- [["lux;DataT" xname] ["lux;DataT" yname]]
- (.equals ^Object xname yname)
+ (let [output (|case [x y]
+ [(&/$NamedT [?xmodule ?xname] ?xtype) (&/$NamedT [?ymodule ?yname] ?ytype)]
+ (and (= ?xmodule ?ymodule)
+ (= ?xname ?yname))
+
+ [(&/$DataT xname xparams) (&/$DataT yname yparams)]
+ (and (.equals ^Object xname yname)
+ (= (&/|length xparams) (&/|length yparams))
+ (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams))
- [["lux;TupleT" xelems] ["lux;TupleT" yelems]]
- (&/fold2 (fn [old x y]
- (and old (type= x y)))
+ [(&/$TupleT xelems) (&/$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))))
+ [(&/$VariantT xcases) (&/$VariantT ycases)]
+ (&/fold2 (fn [old x y] (and old (type= x y)))
true
xcases ycases)
- [["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
- xslots yslots)
-
- [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]]
+ [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)]
(and (type= xinput yinput)
(type= xoutput youtput))
- [["lux;VarT" xid] ["lux;VarT" yid]]
+ [(&/$VarT xid) (&/$VarT yid)]
(.equals ^Object xid yid)
- [["lux;BoundT" xname] ["lux;BoundT" yname]]
- (.equals ^Object xname yname)
+ [(&/$BoundT xidx) (&/$BoundT yidx)]
+ (= xidx yidx)
- [["lux;ExT" xid] ["lux;ExT" yid]]
+ [(&/$ExT xid) (&/$ExT yid)]
(.equals ^Object xid yid)
- [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]]
+ [(&/$AppT xlambda xparam) (&/$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
-
- ;; [["lux;Some" xenv*] ["lux;Some" yenv*]]
- ;; (&/fold (fn [old bname]
- ;; (and old
- ;; (type= (&/|get bname xenv*) (&/|get bname yenv*))))
- ;; (= (&/|length xenv*) (&/|length yenv*))
- ;; (&/|keys xenv*))
-
- ;; [_ _]
- ;; false)
- (type= xbody ybody)
- )
+ [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)]
+ (type= xbody ybody)
+
+ [(&/$NamedT ?xname ?xtype) _]
+ (type= ?xtype y)
+ [_ (&/$NamedT ?yname ?ytype)]
+ (type= x ?ytype)
+
[_ _]
false
)]
@@ -498,19 +383,19 @@
(defn ^:private fp-get [k fixpoints]
(|let [[e a] k]
- (matchv ::M/objects [fixpoints]
- [["lux;Nil" _]]
- (&/V "lux;None" nil)
+ (|case fixpoints
+ (&/$Nil)
+ &/None$
- [["lux;Cons" [[[e* a*] v*] fixpoints*]]]
+ (&/$Cons [[e* a*] v*] fixpoints*)
(if (and (type= e e*)
(type= a a*))
- (&/V "lux;Some" v*)
+ (&/V &/$Some v*)
(fp-get k fixpoints*))
)))
(defn ^:private fp-put [k v fixpoints]
- (&/|cons (&/T k v) fixpoints))
+ (&/Cons$ (&/T k v) fixpoints))
(defn ^:private check-error [expected actual]
(str "[Type Checker]\nExpected: " (show-type expected)
@@ -518,227 +403,157 @@
"\n"))
(defn beta-reduce [env type]
- (matchv ::M/objects [type]
- [["lux;VariantT" ?cases]]
- (&/V "lux;VariantT" (&/|map (fn [kv]
- (|let [[k v] kv]
- (&/T k (beta-reduce env v))))
- ?cases))
-
- [["lux;RecordT" ?fields]]
- (&/V "lux;RecordT" (&/|map (fn [kv]
- (|let [[k v] kv]
- (&/T k (beta-reduce env v))))
- ?fields))
-
- [["lux;TupleT" ?members]]
- (&/V "lux;TupleT" (&/|map (partial beta-reduce env) ?members))
-
- [["lux;AppT" [?type-fn ?type-arg]]]
- (&/V "lux;AppT" (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)))
-
- [["lux;AllT" [?local-env ?local-name ?local-arg ?local-def]]]
- (matchv ::M/objects [?local-env]
- [["lux;None" _]]
- (&/V "lux;AllT" (&/T (&/V "lux;Some" env) ?local-name ?local-arg ?local-def))
-
- [["lux;Some" _]]
+ (|case type
+ (&/$VariantT ?members)
+ (Variant$ (&/|map (partial beta-reduce env) ?members))
+
+ (&/$TupleT ?members)
+ (Tuple$ (&/|map (partial beta-reduce env) ?members))
+
+ (&/$AppT ?type-fn ?type-arg)
+ (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))
+
+ (&/$UnivQ ?local-env ?local-def)
+ (|case ?local-env
+ (&/$Nil)
+ (Univ$ env ?local-def)
+
+ _
type)
- [["lux;LambdaT" [?input ?output]]]
- (&/V "lux;LambdaT" (&/T (beta-reduce env ?input) (beta-reduce env ?output)))
+ (&/$LambdaT ?input ?output)
+ (Lambda$ (beta-reduce env ?input) (beta-reduce env ?output))
- [["lux;BoundT" ?name]]
- (if-let [bound (&/|get ?name env)]
+ (&/$BoundT ?idx)
+ (|case (&/|at ?idx env)
+ (&/$Some bound)
(beta-reduce env bound)
- type)
- [_]
+ _
+ (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env)))))
+
+ _
type
))
-(defn slot-type [record slot]
- (fn [state]
- (matchv ::M/objects [(&/|get slot record)]
- [["lux;Left" msg]]
- (fail* msg)
-
- [["lux;Right" type]]
- (return* state type))))
-
(defn apply-type [type-fn param]
- (matchv ::M/objects [type-fn]
- [["lux;AllT" [local-env local-name local-arg local-def]]]
- (let [local-env* (matchv ::M/objects [local-env]
- [["lux;None" _]]
- (&/|table)
-
- [["lux;Some" local-env*]]
- local-env*)]
- (return (beta-reduce (->> local-env*
- (&/|put local-name type-fn)
- (&/|put local-arg param))
- local-def)))
-
- [["lux;AppT" [F A]]]
+ (|case type-fn
+ (&/$UnivQ local-env local-def)
+ (return (beta-reduce (->> local-env
+ (&/Cons$ param)
+ (&/Cons$ type-fn))
+ local-def))
+
+ (&/$AppT F A)
(|do [type-fn* (apply-type F A)]
(apply-type type-fn* param))
+
+ (&/$NamedT ?name ?type)
+ (apply-type ?type param)
+
+ (&/$ExT id)
+ (return (App$ type-fn param))
- [_]
- (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]
+ _
+ (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n"))))
+
+(def ^:private init-fixpoints &/Nil$)
+
+(defn ^:private check* [class-loader fixpoints invariant?? expected actual]
(if (clojure.lang.Util/identical expected actual)
(return (&/T fixpoints nil))
- (matchv ::M/objects [expected actual]
- [["lux;VarT" ?eid] ["lux;VarT" ?aid]]
+ (|case [expected actual]
+ [(&/$VarT ?eid) (&/$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))
+ (|case ((deref ?eid) state)
+ (&/$Right state* ebound)
+ (return* state* (&/V &/$Some ebound))
- [["lux;Left" _]]
- (return* state (&/V "lux;None" nil))))
+ (&/$Left _)
+ (return* state &/None$)))
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" _]]
+ (|case ((deref ?aid) state)
+ (&/$Right state* abound)
+ (return* state* (&/V &/$Some abound))
+
+ (&/$Left _)
+ (return* state &/None$)))]
+ (|case [ebound abound]
+ [(&/$None _) (&/$None _)]
(|do [_ (set-var ?eid actual)]
(return (&/T fixpoints nil)))
- [["lux;Some" etype] ["lux;None" _]]
- (check* class-loader fixpoints etype actual)
+ [(&/$Some etype) (&/$None _)]
+ (check* class-loader fixpoints invariant?? etype actual)
- [["lux;None" _] ["lux;Some" atype]]
- (check* class-loader fixpoints expected atype)
+ [(&/$None _) (&/$Some atype)]
+ (check* class-loader fixpoints invariant?? expected atype)
- [["lux;Some" etype] ["lux;Some" atype]]
- (check* class-loader fixpoints etype atype))))
+ [(&/$Some etype) (&/$Some atype)]
+ (check* class-loader fixpoints invariant?? etype atype))))
- [["lux;VarT" ?id] _]
+ [(&/$VarT ?id) _]
(fn [state]
- (matchv ::M/objects [((set-var ?id actual) state)]
- [["lux;Right" [state* _]]]
+ (|case ((set-var ?id actual) state)
+ (&/$Right state* _)
(return* state* (&/T fixpoints nil))
- [["lux;Left" _]]
+ (&/$Left _)
((|do [bound (deref ?id)]
- (check* class-loader fixpoints bound actual))
+ (check* class-loader fixpoints invariant?? bound actual))
state)))
- [_ ["lux;VarT" ?id]]
+ [_ (&/$VarT ?id)]
(fn [state]
- (matchv ::M/objects [((set-var ?id expected) state)]
- [["lux;Right" [state* _]]]
+ (|case ((set-var ?id expected) state)
+ (&/$Right state* _)
(return* state* (&/T fixpoints nil))
- [["lux;Left" _]]
+ (&/$Left _)
((|do [bound (deref ?id)]
- (check* class-loader fixpoints expected bound))
+ (check* class-loader fixpoints invariant?? 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)
+ [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)]
+ (if (= eid aid)
+ (check* class-loader fixpoints invariant?? eA aA)
+ (fail (check-error expected actual)))
- [["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]]]
+ [(&/$AppT (&/$VarT ?id) A1) (&/$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]]]
+ (|case ((|do [F1 (deref ?id)]
+ (check* class-loader fixpoints invariant?? (App$ F1 A1) actual))
+ state)
+ (&/$Right state* output)
(return* state* output)
- [["lux;Left" _]]
- ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2)
+ (&/$Left _)
+ ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2)
e* (apply-type F2 A1)
a* (apply-type F2 A2)
- [fixpoints** _] (check* class-loader fixpoints* e* a*)]
+ [fixpoints** _] (check* class-loader fixpoints* invariant?? 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]]]
+ [(&/$AppT F1 A1) (&/$AppT (&/$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]]]
+ (|case ((|do [F2 (deref ?id)]
+ (check* class-loader fixpoints invariant?? expected (App$ F2 A2)))
+ state)
+ (&/$Right state* output)
(return* state* output)
- [["lux;Left" _]]
- ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id))
+ (&/$Left _)
+ ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id))
e* (apply-type F1 A1)
a* (apply-type F1 A2)
- [fixpoints** _] (check* class-loader fixpoints* e* a*)]
+ [fixpoints** _] (check* class-loader fixpoints* invariant?? 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]] _]
+
+ [(&/$AppT F A) _]
(let [fp-pair (&/T expected actual)
_ (when (> (&/|length fixpoints) 40)
(println 'FIXPOINTS (->> (&/|keys fixpoints)
@@ -748,132 +563,164 @@
(show-type a)))))
(&/|interpose "\n\n")
(&/fold str "")))
- (assert false))]
- (matchv ::M/objects [(fp-get fp-pair fixpoints)]
- [["lux;Some" ?]]
+ (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))]
+ (|case (fp-get fp-pair fixpoints)
+ (&/$Some ?)
(if ?
(return (&/T fixpoints nil))
(fail (check-error expected actual)))
- [["lux;None" _]]
+ (&/$None)
(|do [expected* (apply-type F A)]
- (check* class-loader (fp-put fp-pair true fixpoints) expected* actual))))
+ (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual))))
- [_ ["lux;AppT" [F A]]]
+ [_ (&/$AppT F A)]
(|do [actual* (apply-type F A)]
- (check* class-loader fixpoints expected actual*))
+ (check* class-loader fixpoints invariant?? expected actual*))
- [["lux;AllT" _] _]
+ [(&/$UnivQ _) _]
+ (|do [$arg existential
+ expected* (apply-type expected $arg)]
+ (check* class-loader fixpoints invariant?? expected* actual))
+
+ [_ (&/$UnivQ _)]
(with-var
(fn [$arg]
- (|do [expected* (apply-type expected $arg)]
- (check* class-loader fixpoints expected* actual))))
+ (|do [actual* (apply-type actual $arg)]
+ (check* class-loader fixpoints invariant?? expected actual*))))
- [_ ["lux;AllT" _]]
+ [(&/$ExQ e!env e!def) _]
(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]]
+ (|let [expected* (beta-reduce (->> e!env
+ (&/Cons$ $arg)
+ (&/Cons$ expected))
+ e!def)]
+ (check* class-loader fixpoints invariant?? expected* actual))))
+
+ [_ (&/$ExQ a!env a!def)]
+ (|do [$arg existential]
+ (|let [actual* (beta-reduce (->> a!env
+ (&/Cons$ $arg)
+ (&/Cons$ expected))
+ a!def)]
+ (check* class-loader fixpoints invariant?? expected actual*)))
+
+ [(&/$DataT e!data) (&/$DataT a!data)]
+ (&&host/check-host-types (partial check* class-loader fixpoints true)
+ check-error
+ fixpoints
+ existential
+ class-loader
+ invariant??
+ e!data
+ a!data)
+
+ [(&/$LambdaT eI eO) (&/$LambdaT aI aO)]
+ (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)]
+ (check* class-loader fixpoints* invariant?? eO aO))
+
+ [(&/$TupleT e!members) (&/$TupleT a!members)]
(|do [fixpoints* (&/fold2% (fn [fp e a]
- (|do [[fp* _] (check* class-loader fp e a)]
+ (|do [[fp* _] (check* class-loader fp invariant?? e a)]
(return fp*)))
fixpoints
e!members a!members)]
(return (&/T fixpoints* nil)))
- [["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)))
+ [_ (&/$VariantT (&/$Nil))]
+ (return (&/T fixpoints nil))
- [["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)))))
+ [(&/$VariantT e!cases) (&/$VariantT a!cases)]
+ (|do [fixpoints* (&/fold2% (fn [fp e a]
+ (|do [[fp* _] (check* class-loader fp invariant?? e a)]
+ (return fp*)))
fixpoints
- e!slots a!slots)]
+ e!cases a!cases)]
(return (&/T fixpoints* nil)))
- [["lux;ExT" e!id] ["lux;ExT" a!id]]
+ [(&/$ExT e!id) (&/$ExT a!id)]
(if (.equals ^Object e!id a!id)
(return (&/T fixpoints nil))
(fail (check-error expected actual)))
+ [(&/$NamedT ?ename ?etype) _]
+ (check* class-loader fixpoints invariant?? ?etype actual)
+
+ [_ (&/$NamedT ?aname ?atype)]
+ (check* class-loader fixpoints invariant?? expected ?atype)
+
[_ _]
(fail (check-error expected actual))
)))
(defn check [expected actual]
(|do [class-loader &/loader
- _ (check* class-loader init-fixpoints expected actual)]
+ _ (check* class-loader init-fixpoints false expected actual)]
(return nil)))
-(defn apply-lambda [func param]
- (matchv ::M/objects [func]
- [["lux;LambdaT" [input output]]]
- (|do [_ (check* init-fixpoints input param)]
- (return output))
-
- [["lux;AllT" _]]
- (with-var
- (fn [$var]
- (|do [func* (apply-type func $var)
- =return (apply-lambda func* param)]
- (clean $var =return))))
-
- [_]
- (fail (str "[Type System] Not a function type:\n" (show-type func) "\n"))
- ))
-
(defn actual-type [type]
- (matchv ::M/objects [type]
- [["lux;AppT" [?all ?param]]]
+ "(-> Type (Lux Type))"
+ (|case type
+ (&/$AppT ?all ?param)
(|do [type* (apply-type ?all ?param)]
(actual-type type*))
- [["lux;VarT" ?id]]
- (deref ?id)
+ (&/$VarT id)
+ (|do [=type (deref id)]
+ (actual-type =type))
+
+ (&/$NamedT ?name ?type)
+ (actual-type ?type)
- [_]
+ _
(return type)
))
-(defn variant-case [case type]
- (matchv ::M/objects [type]
- [["lux;VariantT" ?cases]]
- (if-let [case-type (&/|get case ?cases)]
+(defn variant-case [tag type]
+ (|case type
+ (&/$NamedT ?name ?type)
+ (variant-case tag ?type)
+
+ (&/$VariantT ?cases)
+ (|case (&/|at tag ?cases)
+ (&/$Some case-type)
(return case-type)
- (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type))))
- [_]
+ (&/$None)
+ (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type))))
+
+ _
(fail (str "[Type Error] Type is not a variant: " (show-type type)))))
+
+(defn type-name [type]
+ "(-> Type (Lux Ident))"
+ (|case type
+ (&/$NamedT name _)
+ (return name)
+
+ _
+ (fail (str "[Type Error] Type is not named: " (show-type type)))
+ ))
+
+(defn unknown? [type]
+ "(-> Type (Lux Bool))"
+ (|case type
+ (&/$VarT id)
+ (|do [? (bound? id)]
+ (return (not ?)))
+
+ _
+ (return false)))
+
+(defn resolve-type [type]
+ "(-> Type (Lux Type))"
+ (|case type
+ (&/$VarT id)
+ (|do [? (bound? id)]
+ (if ?
+ (deref id)
+ (return type)))
+
+ _
+ (return type)))
diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj
new file mode 100644
index 000000000..d4627b273
--- /dev/null
+++ b/src/lux/type/host.clj
@@ -0,0 +1,220 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+;; If a copy of the MPL was not distributed with this file,
+;; You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(ns lux.type.host
+ (:require clojure.core.match
+ clojure.core.match.array
+ (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]))
+ (:import (java.lang.reflect GenericArrayType
+ ParameterizedType
+ TypeVariable
+ WildcardType)))
+
+;; [Exports]
+(def array-data-tag "#Array")
+(def null-data-tag "#Null")
+
+;; [Utils]
+(defn ^:private trace-lineage* [^Class super-class ^Class sub-class]
+ "(-> Class Class (List Class))"
+ ;; Either they're both interfaces, of they're both classes
+ (cond (.isInterface sub-class)
+ (let [interface<=interface? #(if (or (= super-class %)
+ (.isAssignableFrom super-class %))
+ %
+ nil)]
+ (loop [sub-class sub-class
+ stack (&/|list)]
+ (let [super-interface (some interface<=interface?
+ (.getInterfaces sub-class))]
+ (if (= super-class super-interface)
+ (&/Cons$ super-interface stack)
+ (let [super* (.getSuperclass sub-class)]
+ (recur super* (&/Cons$ super* stack)))))))
+
+ (.isInterface super-class)
+ (let [class<=interface? #(if (= super-class %) % nil)]
+ (loop [sub-class sub-class
+ stack (&/|list)]
+ (if-let [super-interface (some class<=interface? (.getInterfaces sub-class))]
+ (&/Cons$ super-interface stack)
+ (let [super* (.getSuperclass sub-class)]
+ (recur super* (&/Cons$ super* stack))))))
+
+ :else
+ (loop [sub-class sub-class
+ stack (&/|list)]
+ (let [super* (.getSuperclass sub-class)]
+ (if (= super* super-class)
+ (&/Cons$ super* stack)
+ (recur super* (&/Cons$ super* stack)))))))
+
+(defn ^:private trace-lineage [^Class sub-class ^Class super-class]
+ "(-> Class Class (List Class))"
+ (if (= sub-class super-class)
+ (&/|list)
+ (&/|reverse (trace-lineage* super-class sub-class))))
+
+(let [matcher (fn [m ^TypeVariable jt lt] (&/Cons$ (&/T (.getName jt) lt) m))]
+ (defn ^:private match-params [sub-type-params params]
+ (assert (and (= (&/|length sub-type-params) (&/|length params))
+ (&/|every? (partial instance? TypeVariable) sub-type-params)))
+ (&/fold2 matcher (&/|table) sub-type-params params)))
+
+;; [Exports]
+(let [class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))"
+ Unit (&/V &/$TupleT (&/|list))]
+ (defn class->type [^Class class]
+ "(-> Class Type)"
+ (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))]
+ (let [base (or arr-base simple-base)]
+ (if (.equals "void" base)
+ Unit
+ (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner))))
+ (&/V &/$DataT (&/T base &/Nil$))
+ (range (count (or arr-brackets "")))))
+ ))))
+
+(defn instance-param [existential matchings refl-type]
+ "(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))"
+ (cond (instance? Class refl-type)
+ (return (class->type refl-type))
+
+ (instance? GenericArrayType refl-type)
+ (let [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))]
+ (return (&/V &/$DataT (&/T array-data-tag (&/|list inner-type)))))
+
+ (instance? ParameterizedType refl-type)
+ (|do [:let [refl-type* ^ParameterizedType refl-type]
+ params* (->> refl-type*
+ .getActualTypeArguments
+ seq &/->list
+ (&/map% (partial instance-param existential matchings)))]
+ (return (&/V &/$DataT (&/T (->> refl-type* ^Class (.getRawType) .getName)
+ params*))))
+
+ (instance? TypeVariable refl-type)
+ (let [gvar (.getName ^TypeVariable refl-type)]
+ (if-let [m-type (&/|get gvar matchings)]
+ (return m-type)
+ (fail (str "[Type Error] Unknown generic type variable: " gvar))))
+
+ (instance? WildcardType refl-type)
+ (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)]
+ (instance-param existential matchings bound)
+ existential)))
+
+;; [Utils]
+(defn ^:private translate-params [existential super-type-params sub-type-params params]
+ "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))"
+ (|let [matchings (match-params sub-type-params params)]
+ (&/map% (partial instance-param existential matchings) super-type-params)))
+
+(defn ^:private raise* [existential sub+params ^Class super]
+ "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))"
+ (|let [[^Class sub params] sub+params]
+ (if (.isInterface super)
+ (|do [:let [super-params (->> sub
+ .getGenericInterfaces
+ (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %)))
+ (if (instance? Class %)
+ (&/|list)
+ (->> ^ParameterizedType % .getActualTypeArguments seq &/->list))
+ nil)))]
+ params* (translate-params existential
+ super-params
+ (->> sub .getTypeParameters seq &/->list)
+ params)]
+ (return (&/T super params*)))
+ (let [super* (.getGenericSuperclass sub)]
+ (cond (instance? Class super*)
+ (return (&/T super* (&/|list)))
+
+ (instance? ParameterizedType super*)
+ (|do [params* (translate-params existential
+ (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list)
+ (->> sub .getTypeParameters seq &/->list)
+ params)]
+ (return (&/T super params*)))
+
+ :else
+ (assert false (prn-str super* (class super*) [sub super])))))))
+
+(defn ^:private raise [existential lineage class params]
+ "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))"
+ (&/fold% (partial raise* existential) (&/T class params) lineage))
+
+;; [Exports]
+(defn ->super-type [existential class-loader super-class sub-class sub-params]
+ "(-> Text Text (List Type) (Lux Type))"
+ (let [super-class+ (Class/forName super-class true class-loader)
+ sub-class+ (Class/forName sub-class true class-loader)]
+ (if (.isAssignableFrom super-class+ sub-class+)
+ (let [lineage (trace-lineage sub-class+ super-class+)]
+ (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)]
+ (return (&/V &/$DataT (&/T (.getName sub-class*) sub-params*)))))
+ (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " </= " super-class)))))
+
+(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))
+
+(let [primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}]
+ (defn primitive-type? [type-name]
+ (contains? primitive-types type-name)))
+
+(defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual]
+ (|let [[e!name e!params] expected
+ [a!name a!params] actual]
+ (cond (= "java.lang.Object" e!name)
+ (return (&/T fixpoints nil))
+
+ (= null-data-tag a!name)
+ (if (not (primitive-type? e!name))
+ (return (&/T fixpoints nil))
+ (fail (check-error (&/V &/$DataT expected) (&/V &/$DataT actual))))
+
+ (= null-data-tag e!name)
+ (if (= null-data-tag a!name)
+ (return (&/T fixpoints nil))
+ (fail (check-error (&/V &/$DataT expected) (&/V &/$DataT actual))))
+
+ (and (= array-data-tag e!name)
+ (not= array-data-tag a!name))
+ (fail (check-error (&/V &/$DataT expected) (&/V &/$DataT actual)))
+
+ :else
+ (let [e!name (as-obj e!name)
+ a!name (as-obj a!name)]
+ (cond (and (.equals ^Object e!name a!name)
+ (= (&/|length e!params) (&/|length a!params)))
+ (|do [_ (&/map2% check e!params a!params)]
+ (return (&/T fixpoints nil)))
+
+ (not invariant??)
+ (|do [actual* (->super-type existential class-loader e!name a!name a!params)]
+ (check (&/V &/$DataT expected) actual*))
+
+ :else
+ (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))))))
+
+(let [Void$ (&/V &/$VariantT (&/|list))
+ gen-type (constantly Void$)]
+ (defn dummy-gtype [class]
+ (|do [class-loader &/loader]
+ (try (|let [=class (Class/forName class true class-loader)
+ params (->> =class .getTypeParameters seq &/->list (&/|map gen-type))]
+ (return (&/V &/$DataT (&/T class params))))
+ (catch Exception e
+ (fail (str "[Type Error] Unknown type: " class)))))))