aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lux/analyser.clj27
-rw-r--r--src/lux/analyser/lux.clj111
-rw-r--r--src/lux/analyser/meta.clj41
-rw-r--r--src/lux/analyser/module.clj189
-rw-r--r--src/lux/base.clj24
-rw-r--r--src/lux/compiler.clj15
-rw-r--r--src/lux/compiler/base.clj2
-rw-r--r--src/lux/compiler/cache.clj45
-rw-r--r--src/lux/compiler/lux.clj208
-rw-r--r--src/lux/compiler/type.clj103
-rw-r--r--src/lux/reader.clj17
-rw-r--r--src/lux/type.clj36
12 files changed, 403 insertions, 415 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 5a0aa0b3c..71044b923 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -549,20 +549,10 @@
(&/$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% &&a-parser/parse-tag tags)]
- (&&lux/analyse-declare-tags tags* type-name))
+ (&/$Cons ?meta
+ (&/$Nil))
+ ))))
+ (&&lux/analyse-def analyse eval! compile-token ?name ?value ?meta)
(&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")]
(&/$Cons [_ (&/$TextS ?path)]
@@ -581,11 +571,6 @@
(&/$Nil)))))
(&&lux/analyse-coerce analyse eval! exo-type ?type ?value)
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")]
- (&/$Cons [_ (&/$SymbolS "" ?ident)]
- (&/$Nil))))
- (&&lux/analyse-export analyse compile-token ?ident)
-
(&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")]
(&/$Cons [_ (&/$TextS ?alias)]
(&/$Cons [_ (&/$TextS ?module)]
@@ -687,14 +672,14 @@
(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*)
+ ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type =fn ?args) state*)
_
((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state)))
_
(|do [=fn (just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn)]
- (&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args)))
+ (&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type =fn ?args)))
_
(analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index c52cd5937..09e01b6aa 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -16,7 +16,8 @@
[case :as &&case]
[env :as &&env]
[module :as &&module]
- [record :as &&record])))
+ [record :as &&record]
+ [meta :as &&meta])))
;; [Utils]
(defn ^:private count-univq [type]
@@ -223,16 +224,7 @@
)))
(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))
+ (|do [[[r-module r-name] [endo-type ?meta ?value]] (&&module/find-def module name)
_ (if (and (clojure.lang.Util/identical &type/Type endo-type)
(clojure.lang.Util/identical &type/Type exo-type))
(return nil)
@@ -258,25 +250,8 @@
(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)
+ (&/run-state (analyse-global analyse exo-type ?module* name*)
+ state)
_
(fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))
@@ -350,22 +325,24 @@
(fail (str err "\n" "[Analyser Error] Can't apply function " (&type/show-type fun-type) " to args: " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))
))
-(defn analyse-apply [analyse exo-type form-cursor =fn ?args]
+(defn ^:private do-analyse-apply [analyse exo-type =fn ?args]
+ (|do [:let [[[=fn-type =fn-cursor] =fn-form] =fn]
+ [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
+ (return (&/|list (&&/|meta =output-t =fn-cursor
+ (&/V &&/$apply (&/T =fn =args))
+ )))))
+
+(defn analyse-apply [analyse exo-type =fn ?args]
(|do [loader &/loader
: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 (fn [state] (-> macro (.apply ?args) (.apply state)))
- ;; :let [_ (when (or (= "case" (aget real-name 1))
- ;; ;; (= "invoke-static$" (aget real-name 1))
- ;; ;; (= "invoke-virtual$" (aget real-name 1))
- ;; ;; (= "new$" (aget real-name 1))
- ;; ;; (= "let%" (aget real-name 1))
- ;; ;; (= "jvm-import" (aget real-name 1))
- ;; )
+ (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)]
+ (|case (&&meta/meta-get &&meta/macro?-tag ?meta)
+ (&/$Some _)
+ (|do [macro-expansion (fn [state] (-> ?value (.apply ?args) (.apply state)))
+ ;; :let [_ (when (or (= "import" (aget real-name 1))
+ ;; (= "defsig" (aget real-name 1)))
;; (->> (&/|map &/show-ast macro-expansion)
;; (&/|interpose "\n")
;; (&/fold str "")
@@ -374,16 +351,10 @@
(&/flat-map% (partial analyse exo-type) macro-expansion))
_
- (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
- (return (&/|list (&&/|meta =output-t =fn-cursor
- (&/V &&/$apply (&/T =fn =args))
- ))))))
+ (do-analyse-apply analyse exo-type =fn ?args)))
_
- (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
- (return (&/|list (&&/|meta =output-t =fn-cursor
- (&/V &&/$apply (&/T =fn =args))
- )))))
+ (do-analyse-apply analyse exo-type =fn ?args))
))
(defn analyse-case [analyse exo-type ?value ?branches]
@@ -492,37 +463,20 @@
(|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)]
(return (&/|list output))))
-(defn analyse-def [analyse compile-token ?name ?value]
+(defn analyse-def [analyse eval! compile-token ?name ?value ?meta]
(|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))]
- (|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 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$)))
+ (&&/analyse-1+ analyse ?value))
+ =meta (&&/analyse-1 analyse &type/DefMeta ?meta)
+ ==meta (eval! =meta)
+ _ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value))
+ _ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value))
+ _ (compile-token (&/V &&/$def (&/T ?name =value ==meta)))]
+ (return &/Nil$))
+ )))
(defn analyse-import [analyse compile-module compile-token path]
(|do [module-name &/get-module-name
@@ -539,11 +493,6 @@
(return nil))]
(return &/Nil$)))))
-(defn analyse-export [analyse compile-token name]
- (|do [module-name &/get-module-name
- _ (&&module/export module-name name)]
- (return &/Nil$)))
-
(defn analyse-alias [analyse compile-token ex-alias ex-module]
(|do [module-name &/get-module-name
_ (&&module/alias module-name ex-alias ex-module)]
diff --git a/src/lux/analyser/meta.clj b/src/lux/analyser/meta.clj
new file mode 100644
index 000000000..6b9d91695
--- /dev/null
+++ b/src/lux/analyser/meta.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.analyser.meta
+ (:require (clojure [template :refer [do-template]])
+ clojure.core.match
+ clojure.core.match.array
+ (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]])))
+
+;; [Utils]
+(defn ^:private ident= [x y]
+ (|let [[px nx] x
+ [py ny] y]
+ (and (= px py)
+ (= nx ny))))
+
+(def ^:private tag-prefix "lux")
+
+;; [Values]
+(defn meta-get [ident dict]
+ "(-> Ident DefMeta (Maybe DefMetaValue))"
+ (|case dict
+ (&/$Cons [k v] dict*)
+ (if (ident= k ident)
+ (&/Some$ v)
+ (meta-get ident dict*))
+
+ (&/$Nil)
+ &/None$))
+
+(do-template [<name> <tag-name>]
+ (def <name> (&/V tag-prefix <tag-name>))
+
+ type?-tag "type?"
+ alias-tag "alias"
+ macro?-tag "macro?"
+ export?-tag "export?"
+ tags-tag "tags"
+ )
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 75a62bf95..83a641707 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -12,7 +12,8 @@
(lux [base :as & :refer [deftags |let |do return return* fail fail* |case]]
[type :as &type]
[host :as &host])
- [lux.host.generics :as &host-generics]))
+ [lux.host.generics :as &host-generics]
+ (lux.analyser [meta :as &meta])))
;; [Utils]
(deftags
@@ -60,10 +61,10 @@
state)
nil))))
-(defn define [module name ^objects def-data type]
+(defn define [module name def-type def-meta def-value]
(fn [state]
(when (and (= "Macro" name) (= "lux" module))
- (&type/set-macro-type! (aget def-data 1)))
+ (&type/set-macro-type! def-value))
(|case (&/get$ &/$envs state)
(&/$Cons ?env (&/$Nil))
(return* (->> state
@@ -72,7 +73,7 @@
(&/|update module
(fn [m]
(&/update$ $defs
- #(&/|put name (&/T false def-data) %)
+ #(&/|put name (&/T def-type def-meta def-value) %)
m))
ms))))
nil)
@@ -85,19 +86,8 @@
(fn [state]
(if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
(if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
- (|case $def
- [_ (&/$TypeD _)]
- (return* state &type/Type)
-
- [_ (&/$MacroD _)]
- (return* state &type/Macro)
-
- [_ (&/$ValueD _type _)]
- (return* state _type)
-
- [_ (&/$AliasD ?r-module ?r-name)]
- (&/run-state (def-type ?r-module ?r-name)
- state))
+ (|let [[?type ?meta ?value] $def]
+ (return* state ?type))
(fail* (str "[Analyser Error] Unknown definition: " (str module ";" name))))
(fail* (str "[Analyser Error] Unknown module: " module)))))
@@ -106,33 +96,16 @@
(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)
+ (|let [[?type ?meta ?value] $def]
+ (|case (&meta/meta-get &meta/type?-tag ?meta)
+ (&/$Some _)
+ (return* state ?value)
- _
- (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name)))))
+ _
+ (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]
- (fn [state]
- (|case (&/get$ &/$envs state)
- (&/$Cons ?env (&/$Nil))
- (return* (->> state
- (&/update$ &/$modules
- (fn [ms]
- (&/|update a-module
- (fn [m]
- (&/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]
@@ -166,109 +139,39 @@
(fn [state]
(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)
+ (|let [[?type ?meta ?value] $def]
+ (if (.equals ^Object current-module module)
+ (|case (&meta/meta-get &meta/alias-tag ?meta)
+ (&/$Some (&/$IdentM [?r-module ?r-name]))
((find-def ?r-module ?r-name)
state)
_
- (return* state (&/T (&/T module name) $$def)))
- (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))
+ (return* state (&/T (&/T module name) $def)))
+ (|case (&meta/meta-get &meta/export?-tag ?meta)
+ (&/$Some (&/$BoolM true))
+ (return* state (&/T (&/T module name) $def))
+
+ _
+ (fail* (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)
+ (|let [[?type ?meta ?value] def-data]
+ (|case (&meta/meta-get &meta/type?-tag ?meta)
+ (&/$Some _)
+ (return ?type)
- _
- (fail (str "[Analyser Error] Not a type definition: " (&/adt->text def-data)))))
+ _
+ (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))
(return false))))
-(defn declare-macro [module name]
- (fn [state]
- (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))]
- (if-let [$def (&/|get name $module)]
- (|case $def
- [exported? (&/$ValueD ?type _)]
- ((|do [_ (&type/check &type/Macro ?type)
- ^ClassLoader loader &/loader
- :let [macro (-> (.loadClass loader (str (&host-generics/->class-name module) "." (&host/def-name name)))
- (.getField &/datum-field)
- (.get nil))]]
- (fn [state*]
- (return* (&/update$ &/$modules
- (fn [$modules]
- (&/|update module
- (fn [m]
- (&/update$ $defs
- #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %)
- m))
- $modules))
- state*)
- nil)))
- state)
-
- [_ (&/$MacroD _)]
- (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name)))
-
- [_ _]
- (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]
- (|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]
- (return* (->> state
- (&/update$ &/$modules (fn [ms]
- (&/|update module (fn [m]
- (&/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
- (|do [module &/get-module-name]
- (fn [state]
- (return* state
- (&/|map (fn [kv]
- (|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]
@@ -311,7 +214,8 @@
(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))))]
+ _ (&/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]
@@ -354,3 +258,32 @@
tag-group 1 "(-> Text Text (Lux (List Ident)))"
tag-type 2 "(-> Text Text (Lux Type))"
)
+
+(def defs
+ (|do [module &/get-module-name]
+ (fn [state]
+ (return* state
+ (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs)
+ (&/|map (fn [kv]
+ (|let [[k [?def-type ?def-meta ?def-value]] kv]
+ (|case (&meta/meta-get &meta/alias-tag ?def-meta)
+ (&/$Some (&/$IdentM [?r-module ?r-name]))
+ (&/T k (str ?r-module ";" ?r-name))
+
+ _
+ (&/T k "")
+ )))))))))
+
+(do-template [<name> <type> <tag> <desc>]
+ (defn <name> [module name meta type]
+ (|case (&meta/meta-get <tag> meta)
+ (&/$Some (&/$BoolM true))
+ (&/try-all% (&/|list (&type/check <type> type)
+ (fail (str "[Analyser Error] Can't tag as lux;" <desc> "? if it's not a " <desc> ": " (str module ";" name)))))
+
+ _
+ (return nil)))
+
+ test-type &type/Type &meta/type?-tag "type"
+ test-macro &type/Macro &meta/macro?-tag "macro"
+ )
diff --git a/src/lux/base.clj b/src/lux/base.clj
index c0c72c084..ee5e728a1 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -61,13 +61,6 @@
["Local"
"Global"])
-;; Definitions
-(deftags
- ["ValueD"
- "TypeD"
- "MacroD"
- "AliasD"])
-
;; Binding
(deftags
["counter"
@@ -125,11 +118,23 @@
"VirtualMethodAnalysis"
"OverridenMethodAnalysis"])
+;; Meta-data
+(deftags
+ ["BoolM"
+ "IntM"
+ "RealM"
+ "CharM"
+ "TextM"
+ "IdentM"
+ "ListM"
+ "DictM"])
+
;; [Exports]
-(def datum-field "_datum")
-(def meta-field "_meta")
(def name-field "_name")
(def hash-field "_hash")
+(def type-field "_type")
+(def meta-field "_meta")
+(def value-field "_value")
(def compiler-field "_compiler")
(def imports-field "_imports")
(def defs-field "_defs")
@@ -137,7 +142,6 @@
(def tags-field "_tags")
(def module-class-name "_")
(def +name-separator+ ";")
-(def lib-dir "lib")
(defn T [& elems]
(to-array elems))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 9b16a2001..2a8c64c25 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -424,11 +424,8 @@
(defn ^:private compile-token [syntax]
(|case syntax
- (&o/$def ?name ?body)
- (&&lux/compile-def compile-expression ?name ?body)
-
- (&o/$declare-macro ?module ?name)
- (&&lux/compile-declare-macro compile-expression ?module ?name)
+ (&o/$def ?name ?body ?meta)
+ (&&lux/compile-def compile-expression ?name ?body ?meta)
(&o/$jvm-program ?body)
(&&host/compile-jvm-program compile-expression ?body)
@@ -509,12 +506,10 @@
(-> (.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
+ (|let [[?name ?alias] _def]
+ (str ?name
&&/exported-separator
- ?ann))))
+ ?alias))))
(&/|interpose &&/def-separator)
(&/fold str "")))
.visitEnd)
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 4358ebdac..988502a5f 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -37,8 +37,6 @@
(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")
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
index 3337b9b76..fac6b666a 100644
--- a/src/lux/compiler/cache.clj
+++ b/src/lux/compiler/cache.clj
@@ -14,7 +14,8 @@
[host :as &host])
[lux.host.generics :as &host-generics]
(lux.analyser [base :as &a]
- [module :as &a-module])
+ [module :as &a-module]
+ [meta :as &a-meta])
(lux.compiler [base :as &&]
[io :as &&io]))
(:import (java.io File
@@ -121,27 +122,24 @@
_ (&/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* "." (&host/def-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* "." (&host/def-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* "." (&host/def-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)))
+ (let [[_name _alias] (string/split _def #" ")]
+ (if (= nil _alias)
+ (let [def-class (&&/load-class! loader (str module* "." (&host/def-name _name)))
+ def-meta (get-field &/meta-field def-class)
+ def-type (|case (&a-meta/meta-get &a-meta/type?-tag def-meta)
+ (&/$Some (&/$BoolM true))
+ &type/Type
+
+ _
+ (get-field &/type-field def-class))
+ def-value (get-field &/value-field def-class)]
+ (&a-module/define module _name def-type def-meta def-value))
+ (let [[_ __module __name] (re-find #"^(.*);(.*)$" _alias)
+ def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name)))
+ def-type (get-field &/type-field def-class)
+ def-meta (&/|list (&/T &a-meta/alias-tag (&/V &/$IdentM (&/T __module __name))))
+ def-value (get-field &/value-field def-class)]
+ (&a-module/define module _name def-type def-meta def-value)))
))
(if (= [""] defs)
&/Nil$
@@ -153,6 +151,5 @@
tag-groups)]
(return true))))
redo-cache)))
- redo-cache)
- )
+ redo-cache))
redo-cache)))))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 54c103c1d..f6abed570 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -17,7 +17,8 @@
[host :as &host])
[lux.host.generics :as &host-generics]
(lux.analyser [base :as &a]
- [module :as &a-module])
+ [module :as &a-module]
+ [meta :as &a-meta])
(lux.compiler [base :as &&]
[lambda :as &&lambda]
[type :as &&type]))
@@ -104,7 +105,7 @@
(defn compile-global [compile ?owner-class ?name]
(|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/datum-field "Ljava/lang/Object;")]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]]
(return nil)))
(defn compile-apply [compile ?fn ?args]
@@ -117,111 +118,118 @@
?args)]
(return nil)))
-(defn ^:private compile-def-type [compile current-class ?body def-type]
- (|do [^MethodVisitor **writer** &/get-writer]
- (|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))
+(defn ^:private compile-def-type [compile ?body]
+ (|do [:let [?def-type (|case ?body
+ [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr ?def-value-type)]
+ ?type-expr
+
+ [[?def-type ?def-cursor] ?def-value]
+ (if (&type/type= &type/Type ?def-type)
+ (&/T (&/T ?def-type ?def-cursor)
+ (&/V &a/$tuple (&/|list)))
+ (&&type/type->analysis ?def-type)))]]
+ (compile ?def-type)))
- "value"
- (|let [?def-type (|case ?body
- [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr ?def-value-type)]
- ?type-expr
-
- [[?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 &/$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 ^:private compile-def-meta [compile ?meta]
+ (|let [analysis (&&type/defmeta->analysis ?meta)]
+ (compile analysis)))
(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 (&host/def-name ?name)
- current-class (str (&host/->module-class module-name) "/" def-name)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version 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-generics/->class-name current-class))]
- _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)]
- (return nil))))
+ (defn compile-def [compile ?name ?body ?meta]
+ (|do [module-name &/get-module-name
+ class-loader &/loader]
+ (|case (&a-meta/meta-get &a-meta/alias-tag ?meta)
+ (&/$Some (&/$IdentM [r-module r-name]))
+ (if (= 1 (&/|length ?meta))
+ (|do [:let [current-class (&host-generics/->class-name (str (&host/->module-class r-module) "/" (&host/def-name r-name)))
+ def-class (&&/load-class! class-loader current-class)
+ def-type (-> def-class (.getField &/type-field) (.get nil))
+ def-meta ?meta
+ def-value (-> def-class (.getField &/value-field) (.get nil))]
+ _ (&a-module/define module-name ?name def-type def-meta def-value)]
+ (return nil))
+ (fail (str "[Compilation Error] Aliases cannot contain meta-data: " module-name ";" ?name)))
+
+ (&/$Some _)
+ (fail "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.")
+
+ _
+ (|do [:let [=value-type (&a/expr-type* ?body)]
+ ^ClassWriter *writer* &/get-writer
+ [file-name _ _] &/cursor
+ :let [datum-sig "Ljava/lang/Object;"
+ def-name (&host/def-name ?name)
+ current-class (str (&host/->module-class module-name) "/" def-name)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version 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 &/type-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/meta-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/value-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-def-type compile ?body)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/type-field datum-sig)]
+ _ (compile-def-meta compile ?meta)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)]
+ _ (compile ?body)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)]
+ :let [_ (doto **writer**
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))
+ :let [_ (.visitEnd *writer*)]
+ _ (&&/save-class! def-name (.toByteArray =class))
+ :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))
+ [def-type is-type?] (|case (&a-meta/meta-get &a-meta/type?-tag ?meta)
+ (&/$Some (&/$BoolM true))
+ (&/T &type/Type
+ true)
+
+ _
+ (if (&type/type= &type/Type =value-type)
+ (&/T &type/Type
+ false)
+ (&/T (-> def-class (.getField &/type-field) (.get nil))
+ false)))
+ def-meta ?meta
+ def-value (-> def-class (.getField &/value-field) (.get nil))]
+ _ (&a-module/define module-name ?name def-type def-meta def-value)
+ _ (|case (&/T is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta))
+ [true (&/$Some (&/$ListM tags*))]
+ (|do [tags (&/map% (fn [tag*]
+ (|case tag*
+ (&/$TextM tag)
+ (return tag)
+
+ _
+ (fail "[Compiler Error] Incorrect format for tags.")))
+ tags*)
+ _ (&a-module/declare-tags module-name tags def-value)]
+ (return nil))
+
+ [false (&/$Some _)]
+ (fail "[Compiler Error] Can't define tags for non-type.")
+
+ [true (&/$Some _)]
+ (fail "[Compiler Error] Incorrect format for tags.")
+
+ [_ (&/$None)]
+ (return nil))
+ :let [_ (println 'DEF (str module-name ";" ?name))]]
+ (return nil))))))
(defn compile-ann [compile ?value-ex ?type-ex ?value-type]
(compile ?value-ex))
(defn compile-coerce [compile ?value-ex ?type-ex ?value-type]
(compile ?value-ex))
-
-(defn compile-declare-macro [compile module name]
- (|do [_ (&a-module/declare-macro module name)]
- (return nil)))
diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj
index c1615f9b6..5b460858c 100644
--- a/src/lux/compiler/type.clj
+++ b/src/lux/compiler/type.clj
@@ -4,7 +4,8 @@
;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler.type
- (:require clojure.core.match
+ (:require [clojure.template :refer [do-template]]
+ clojure.core.match
clojure.core.match.array
(lux [base :as & :refer [|do return* return fail fail* |let |case]]
[type :as &type])
@@ -14,26 +15,30 @@
(defn ^:private variant$ [tag body]
"(-> Text Analysis Analysis)"
(&a/|meta &type/$Void &/empty-cursor
- (&/V &a/$variant (&/T tag body))
- ))
+ (&/V &a/$variant (&/T tag body))))
(defn ^:private tuple$ [members]
"(-> (List Analysis) Analysis)"
(&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)"
- (&a/|meta &type/$Void &/empty-cursor
- (&/V &a/$text text)
- ))
+ (&/V &a/$tuple members)))
+
+(do-template [<name> <tag> <doc>]
+ (defn <name> [value]
+ <doc>
+ (&a/|meta &type/$Void &/empty-cursor
+ (&/V <tag> value)))
+
+ ^:private bool$ &a/$bool "(-> Bool Analysis)"
+ ^:private int$ &a/$int "(-> Int Analysis)"
+ ^:private real$ &a/$real "(-> Real Analysis)"
+ ^:private char$ &a/$char "(-> Char Analysis)"
+ ^:private text$ &a/$text "(-> Text Analysis)"
+ )
+
+(defn ^:private ident$ [value]
+ "(-> Ident Analysis)"
+ (|let [[p n] value]
+ (tuple$ (&/|list (text$ p) (text$ n)))))
(def ^:private $Nil
"Analysis"
@@ -50,37 +55,81 @@
(&/|reverse elems)))
;; [Exports]
-(defn ->analysis [type]
+(defn type->analysis [type]
"(-> Type Analysis)"
(|case type
(&/$DataT class params)
(variant$ &/$DataT (tuple$ (&/|list (text$ class)
- (List$ (&/|map ->analysis params)))))
+ (List$ (&/|map type->analysis params)))))
(&/$TupleT members)
- (variant$ &/$TupleT (List$ (&/|map ->analysis members)))
+ (variant$ &/$TupleT (List$ (&/|map type->analysis members)))
(&/$VariantT members)
- (variant$ &/$VariantT (List$ (&/|map ->analysis members)))
+ (variant$ &/$VariantT (List$ (&/|map type->analysis members)))
(&/$LambdaT input output)
- (variant$ &/$LambdaT (tuple$ (&/|list (->analysis input) (->analysis output))))
+ (variant$ &/$LambdaT (tuple$ (&/|list (type->analysis input) (type->analysis output))))
(&/$UnivQ env body)
(variant$ &/$UnivQ
- (tuple$ (&/|list (List$ (&/|map ->analysis env))
- (->analysis body))))
+ (tuple$ (&/|list (List$ (&/|map type->analysis env))
+ (type->analysis body))))
(&/$BoundT idx)
(variant$ &/$BoundT (int$ idx))
(&/$AppT fun arg)
- (variant$ &/$AppT (tuple$ (&/|list (->analysis fun) (->analysis arg))))
+ (variant$ &/$AppT (tuple$ (&/|list (type->analysis fun) (type->analysis arg))))
(&/$NamedT [module name] type*)
(variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ module) (text$ name)))
- (->analysis type*))))
+ (type->analysis type*))))
+
+ _
+ (assert false (prn 'type->analysis (&/adt->text type)))
+ ))
+
+(defn ^:private defmetavalue->analysis [dmv]
+ "(-> DefMetaValue Analysis)"
+ (|case dmv
+ (&/$BoolM value)
+ (variant$ &/$BoolM (bool$ value))
+
+ (&/$IntM value)
+ (variant$ &/$IntM (int$ value))
+
+ (&/$RealM value)
+ (variant$ &/$RealM (real$ value))
+
+ (&/$CharM value)
+ (variant$ &/$CharM (char$ value))
+
+ (&/$TextM value)
+ (variant$ &/$TextM (text$ value))
+
+ (&/$IdentM value)
+ (variant$ &/$IdentM (ident$ value))
+
+ (&/$ListM xs)
+ (variant$ &/$ListM (List$ (&/|map defmetavalue->analysis xs)))
+
+ (&/$DictM kvs)
+ (variant$ &/$DictM
+ (List$ (&/|map (fn [kv]
+ (|let [[k v] kv]
+ (tuple$ (&/|list (text$ k)
+ (defmetavalue->analysis v)))))
+ kvs)))
_
- (assert false (prn '->analysis (&type/show-type type) (&/adt->text type)))
+ (assert false (prn 'defmetavalue->analysis (&/adt->text dmv)))
))
+
+(defn defmeta->analysis [xs]
+ "(-> DefMeta Analysis)"
+ (List$ (&/|map (fn [kv]
+ (|let [[k v] kv]
+ (tuple$ (&/|list (ident$ k)
+ (defmetavalue->analysis v)))))
+ xs)))
diff --git a/src/lux/reader.clj b/src/lux/reader.clj
index ce25527f3..5d4a73504 100644
--- a/src/lux/reader.clj
+++ b/src/lux/reader.clj
@@ -126,11 +126,12 @@
(&/V $No (str "[Reader Error] Text failed: " text))))))
(defn from [^String name ^String source-code]
- (->> source-code
- (string/split-lines)
- (&/->list)
- (&/enumerate)
- (&/|map (fn [line+line-num]
- (|let [[line-num line] line+line-num]
- (&/T (&/T name (inc line-num) 0)
- line))))))
+ (let [lines (string/split-lines source-code)
+ indexed-lines (map (fn [line line-num]
+ (&/T (&/T name (inc line-num) 0)
+ line))
+ lines
+ (range (count lines)))]
+ (reduce (fn [tail head] (&/Cons$ head tail))
+ &/Nil$
+ (reverse indexed-lines))))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index f53e80af7..b03558d38 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -115,6 +115,34 @@
)))
$Void))))
+(def DefMetaValue
+ (Named$ (&/T "lux" "DefMetaValue")
+ (let [DefMetaValue (App$ (Bound$ 0) (Bound$ 1))]
+ (App$ (Univ$ empty-env
+ (Variant$ (&/|list
+ ;; BoolM
+ Bool
+ ;; IntM
+ Int
+ ;; RealM
+ Real
+ ;; CharM
+ Char
+ ;; TextM
+ Text
+ ;; IdentM
+ Ident
+ ;; ListM
+ (App$ List DefMetaValue)
+ ;; DictM
+ (App$ List (Tuple$ (&/|list Text DefMetaValue)))
+ )))
+ $Void))))
+
+(def DefMeta
+ (Named$ (&/T "lux" "DefMeta")
+ (App$ List (Tuple$ (&/|list Ident DefMetaValue)))))
+
(def Macro)
(defn set-macro-type! [type]
@@ -419,10 +447,10 @@
(defn ^:private check-error [expected actual]
(|do [=expected (show-type+ expected)
=actual (show-type+ actual)]
- (return (str "[Type Checker]\n"
- "Expected: " =expected "\n\n"
- "Actual: " =actual
- "\n"))))
+ (fail (str "[Type Checker]\n"
+ "Expected: " =expected "\n\n"
+ "Actual: " =actual
+ "\n"))))
(defn beta-reduce [env type]
(|case type
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 00:52:57 +0000