aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser/module.clj30
-rw-r--r--src/lux/base.clj48
-rw-r--r--src/lux/compiler.clj37
-rw-r--r--src/lux/compiler/base.clj10
-rw-r--r--src/lux/compiler/cache.clj39
-rw-r--r--src/lux/compiler/host.clj2
-rw-r--r--src/lux/compiler/lux.clj19
-rw-r--r--src/lux/compiler/module.clj28
8 files changed, 168 insertions, 45 deletions
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 5190e2dcf..d23953f5e 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -49,6 +49,18 @@
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] (&/set$ $imports imports m))
+ ms))
+ state)
+ nil))))
+
(defn define [module name def-data type]
;; (prn 'define module name (aget def-data 0) (&type/show-type type))
(fn [state]
@@ -89,6 +101,20 @@
(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]
@@ -179,7 +205,7 @@
((|do [_ (&type/check &type/Macro ?type)
^ClassLoader loader &/loader
:let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name)))
- (.getField "_datum")
+ (.getField &/datum-field)
(.get nil))]]
(fn [state*]
(return* (&/update$ &/$modules
@@ -293,7 +319,7 @@
(defn declare-tags [module tag-names type]
"(-> Text (List Text) Type (Lux (,)))"
- (|do [;; :let [_ (prn 'declare-tags (&/->seq tag-names) (&/adt->text type))]
+ (|do [;; :let [_ (prn 'declare-tags module (&/->seq tag-names) (&type/show-type type))]
_ (ensure-undeclared-tags module tag-names)
type-name (&type/type-name type)
:let [[_module _name] type-name]
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 84b09bcac..6247524af 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -61,7 +61,18 @@
"AppT"
"NamedT")
-;; [Fields]
+;; Vars
+(deftags "lux;"
+ "Local"
+ "Global")
+
+;; Definitions
+(deftags "lux;"
+ "ValueD"
+ "TypeD"
+ "MacroD"
+ "AliasD")
+
;; Binding
(deftags ""
"counter"
@@ -92,19 +103,18 @@
"eval?"
"host")
-;; Vars
-(deftags "lux;"
- "Local"
- "Global")
-
-;; Definitions
-(deftags "lux;"
- "ValueD"
- "TypeD"
- "MacroD"
- "AliasD")
-
;; [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+ ";")
(defn T [& elems]
@@ -686,6 +696,18 @@
($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))]
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 1814a97c0..79d2c84f8 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -30,6 +30,7 @@
[case :as &&case]
[lambda :as &&lambda]
[package :as &&package]
+ [module :as &&module]
[io :as &&io]))
(:import (org.objectweb.asm Opcodes
Label
@@ -378,14 +379,14 @@
=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)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil)
(doto (.visitEnd))))]
_ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitCode *writer*)]
_ (compile-expression expr)
:let [_ (doto *writer*
- (.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))]]
@@ -395,7 +396,7 @@
_ (&&/save-class! (str id) bytecode)
loader &/loader]
(-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id))
- (.getField "_eval")
+ (.getField &/eval-field)
(.get nil)
return))))
@@ -414,9 +415,9 @@
: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)
+ (-> (.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" "Ljava/lang/String;" nil &&/version)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version)
.visitEnd))
;; _ (prn 'compile-module name =class)
]]
@@ -427,22 +428,36 @@
(&/$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" "Ljava/lang/String;" nil
+ (-> (.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 "1" "0") " " ?name " " ?ann))))
- (&/|interpose "\t")
+ (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" "Ljava/lang/String;" nil
- (->> imports (&/|interpose "\t") (&/fold str "")))
+ (-> (.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))
;; _ (prn 'CLOSED name =class)
]]
- (&&/save-class! "_" (.toByteArray =class)))
+ (&&/save-class! &/module-class-name (.toByteArray =class)))
?state)
(&/$Left ?message)
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 03fae9fec..1e5f3a024 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -33,11 +33,21 @@
(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))]
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
index 85488553c..dc224f52e 100644
--- a/src/lux/compiler/cache.clj
+++ b/src/lux/compiler/cache.clj
@@ -12,7 +12,7 @@
[clojure.java.io :as io]
clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |case]]
+ (lux [base :as & :refer [|do return* return fail fail* |case |let]]
[type :as &type]
[host :as &host])
(lux.analyser [base :as &a]
@@ -88,9 +88,9 @@
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")
+ (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)))
;; _ (prn 'load/IMPORTS module imports)
]
(|do [loads (&/map% (fn [_import]
@@ -108,24 +108,38 @@
;; _ (prn 'load module real-name)
]
(swap! !classes assoc (str module* "." real-name) bytecode)))
- (let [defs (string/split (get-field "_defs" module-meta) #"\t")]
+ (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator)))
+ ;; _ (prn module '(get-field &/tags-field module-meta)
+ ;; (string/split (get-field &/tags-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))))
+ tag-groups (let [all-tags (get-field &/tags-field module-meta)]
+ (if (= "" all-tags)
+ (&/|list)
+ (-> all-tags
+ (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))
+ (->> (map (fn [_group]
+ ;; (prn '_group _group)
+ (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))]
+ ;; (prn '[_type _tags] [_type _tags])
+ (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator)))))))))
+ &/->list)))]
;; (prn 'load module defs)
(|do [_ (&a-module/enter-module module)
+ _ (&a-module/set-imports imports)
_ (&/map% (fn [_def]
(let [[_exported? _name _ann] (string/split _def #" ")
;; _ (prn '[_exported? _name _ann] [_exported? _name _ann])
]
(|do [_ (case _ann
"T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name)))
- def-value (get-field "_datum" def-class)]
+ 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" def-class)]
+ 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)))
;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class)
- def-meta (get-field "_meta" def-class)]
+ def-meta (get-field &/meta-field def-class)]
(|case def-meta
(&/$ValueD def-type _)
(&a-module/define module _name def-meta def-type)))
@@ -134,13 +148,18 @@
(|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?)
+ (if (= &&/exported-true _exported?)
(&a-module/export module _name)
(return nil)))
))
(if (= [""] defs)
(&/|list)
- (&/->list defs)))]
+ (&/->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)
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 0ae4ce2da..26ef73cb7 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -571,6 +571,7 @@
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 0)) ;; VVI
(.visitLdcInsn &/$Nil) ;; VVIT
+ (&&/wrap-long)
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
@@ -616,6 +617,7 @@
(.visitInsn Opcodes/DUP) ;; I2VV
(.visitLdcInsn (int 0)) ;; I2VVI
(.visitLdcInsn &/$Cons) ;; I2VVIT
+ (&&/wrap-long)
(.visitInsn Opcodes/AASTORE) ;; I2V
(.visitInsn Opcodes/DUP_X1) ;; IV2V
(.visitInsn Opcodes/SWAP) ;; IVV2
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index e2b9f0e89..83e294c1a 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -73,6 +73,7 @@
(return nil)))
(defn compile-variant [compile *type* ?tag ?value]
+ ;; (prn 'compile-variant ?tag (class ?tag))
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitLdcInsn (int 2))
@@ -105,7 +106,7 @@
(defn compile-global [compile *type* ?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]
@@ -134,7 +135,7 @@
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
- (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;")
+ (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;")
;; (.visitInsn Opcodes/ACONST_NULL) ;; VVIN
(.visitInsn Opcodes/AASTORE) ;; V
)]
@@ -173,7 +174,7 @@
:let [_ (doto **writer**
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
- (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;")
+ (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;")
(.visitInsn Opcodes/AASTORE))]
:let [_ (.visitInsn **writer** Opcodes/AASTORE)]]
(return nil)))
@@ -194,19 +195,19 @@
=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)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/name-field "Ljava/lang/String;" nil ?name)
(doto (.visitEnd)))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/datum-field datum-sig nil nil)
(doto (.visitEnd)))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_meta" datum-sig nil nil)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/meta-field 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)]
+ :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" datum-sig)]
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)]
:let [_ (doto **writer**
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
@@ -216,7 +217,7 @@
_ (&&/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") (.get nil)) =value-type)]
+ _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)]
(return nil)))
(defn compile-ann [compile *type* ?value-ex ?type-ex]
diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj
new file mode 100644
index 000000000..db73e8bb4
--- /dev/null
+++ b/src/lux/compiler/module.clj
@@ -0,0 +1,28 @@
+;; 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.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)))
+ ))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 14:30:53 +0000