diff options
| author | LuxLang | 2015-10-01 12:50:27 -0400 |
|---|---|---|
| committer | LuxLang | 2015-10-01 12:50:27 -0400 |
| commit | 3e2ce4d30fd457205b0d0268d870d47a8d1ec738 (patch) | |
| tree | 580b42a5024c8767b2f2dd78a77a9911593acb77 /src | |
| parent | e543739f21e03be7cc0192bf510f350f7065bfa5 (diff) | |
| parent | 6fcf9690f914e9b8b4f0ab767164bc97aeb12ca4 (diff) | |
Merge pull request #12 from LuxLang/v0.3
V0.3
Diffstat (limited to 'src')
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))))))) |