aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorEduardo Julian2015-02-17 18:34:38 -0400
committerEduardo Julian2015-02-17 18:34:38 -0400
commitff0bdbddd74a23c59e421403f82a20fd216faf56 (patch)
tree0bfe6d983ee1b02f6b582cf65bb8f6c7d3e7c375 /src
parenta4c15674a3ac87e635ffa92a907fab24b54d509c (diff)
Corrections to the super-refactoring: part 3
## "compiler" subsystem now (almost) compiles.
Diffstat (limited to 'src')
-rw-r--r--src/lux.clj8
-rw-r--r--src/lux/compiler.clj563
-rw-r--r--src/lux/compiler/base.clj36
-rw-r--r--src/lux/compiler/case.clj352
-rw-r--r--src/lux/compiler/host.clj164
-rw-r--r--src/lux/compiler/lambda.clj55
-rw-r--r--src/lux/compiler/lux.clj196
-rw-r--r--src/lux/host.clj40
8 files changed, 757 insertions, 657 deletions
diff --git a/src/lux.clj b/src/lux.clj
index 3c29968de..eb81b43a0 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -18,7 +18,6 @@
;; TODO: Allow setting fields.
;; TODO: monitor enter & monitor exit.
;; TODO: Remember to optimize calling global functions.
- ;; TODO: Reader macros.
;; TODO:
;; TODO:
;; TODO:
@@ -30,10 +29,3 @@
;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
;; cd output && jar cvf test2.jar * && java -cp "test2.jar" test2 && cd ..
)
-
-;; (def (workday? d)
-;; (case d
-;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday]
-;; true)
-;; (or [#Saturday #Sunday]
-;; false)))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 742455b86..bd1df6157 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -6,444 +6,209 @@
[clojure.core.match :refer [match]]
(lux [util :as &util :refer [exec return* return fail fail*
repeat-m exhaust-m try-m try-all-m map-m reduce-m
- apply-m within
+ apply-m
normalize-ident]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
[analyser :as &analyser]
[host :as &host])
+ [lux.analyser.base :as &a]
+ (lux.compiler [base :as &&]
+ [lux :as &&lux]
+ [host :as &&host]
+ [case :as &&case]
+ [lambda :as &&lambda])
:reload)
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
MethodVisitor)))
-;; [Utils/General]
-(defn ^:private write-file [file data]
- (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))]
- (.write stream data)))
-
-(defn ^:private write-class [name data]
- (write-file (str "output/" name ".class") data))
-
-(defn ^:private load-class! [loader name]
- (.loadClass loader name))
-
-(defn ^:private save-class! [name bytecode]
- (exec [loader &util/loader
- :let [_ (write-class name bytecode)
- _ (load-class! loader (string/replace name #"/" "."))]]
- (return nil)))
-
-(def ^:private +prefix+ "lux.")
-(def ^:private +variant-class+ (str +prefix+ "Variant"))
-(def ^:private +tuple-class+ (str +prefix+ "Tuple"))
-(def ^:private +function-class+ (str +prefix+ "Function"))
-(def ^:private +local-prefix+ "l")
-(def ^:private +partial-prefix+ "p")
-(def ^:private +closure-prefix+ "c")
-(def ^:private +apply-signature+ "(Ljava/lang/Object;)Ljava/lang/Object;")
-
-(def ^:private ->package ->class)
-
-(defn ^:private ->type-signature [class]
- (case class
- "void" "V"
- "boolean" "Z"
- "byte" "B"
- "short" "S"
- "int" "I"
- "long" "J"
- "float" "F"
- "double" "D"
- "char" "C"
- ;; else
- (let [class* (->class class)]
- (if (.startsWith class* "[")
- class*
- (str "L" class* ";")))
- ))
-
-(defn ^:private ->java-sig [type]
- (match type
- ::&type/Any
- (->type-signature "java.lang.Object")
-
- [::&type/Data ?name]
- (->type-signature ?name)
-
- [::&type/Array ?elem]
- (str "[" (->java-sig ?elem))
-
- [::&type/variant ?tag ?value]
- (->type-signature +variant-class+)
-
- [::&type/Lambda _ _]
- (->type-signature +function-class+)))
-
;; [Utils/Compilers]
-(let [+class+ (->class "java.lang.Boolean")
- +sig+ (->type-signature "java.lang.Boolean")]
- (defn ^:private compile-bool [compile *type* ?value]
- (exec [*writer* &util/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (->type-signature "java.lang.Boolean"))]]
- (return nil))))
-
-(do-template [<name> <class> <sig>]
- (let [+class+ (->class <class>)]
- (defn <name> [compile *type* ?value]
- (exec [*writer* &util/get-writer
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/NEW <class>)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn ?literal)
- (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]]
- (return nil))))
-
- ^:private compile-int "java.lang.Long" "(J)V"
- ^:private compile-real "java.lang.Double" "(D)V"
- ^:private compile-char "java.lang.Character" "(C)V"
- )
-
-(defn ^:private compile-text [compile *type* ?value]
- (exec [*writer* &util/get-writer
- :let [_ (.visitLdcInsn *writer* ?value)]]
- (return nil)))
-
-(defn ^:private compile-tuple [compile *type* ?elems]
- (exec [*writer* &util/get-writer
- :let [num-elems (count ?elems)
- tuple-class (->class (str +tuple-class+ num-elems))
- _ (doto *writer*
- (.visitTypeInsn Opcodes/NEW tuple-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))]
- _ (map-m (fn [idx]
- (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)]
- ret (compile (nth ?elems idx))
- :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str +partial-prefix+ idx) "Ljava/lang/Object;")]]
- (return ret)))
- (range num-elems))]
- (return nil)))
-
-(defn ^:private compile-variant [compile *type* ?tag ?members]
- (exec [*writer* &util/get-writer
- :let [variant-class* (str (->class +variant-class+) (count ?members))
- _ (doto *writer*
- (.visitTypeInsn Opcodes/NEW variant-class*)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V")
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn ?tag)
- (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (->type-signature "java.lang.String")))]
- _ (map-m (fn [[?tfield ?member]]
- (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)]
- ret (compile ?member)
- :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD variant-class* (str +partial-prefix+ ?tfield) "Ljava/lang/Object;")]]
- (return ret)))
- (map vector (range (count ?members)) ?members))]
- (return nil)))
-
-(defn ^:private compile-local [compile *type* ?idx]
- (exec [*writer* &util/get-writer
- :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]]
- (return nil)))
-
-(defn ^:private compile-captured [compile *type* ?scope ?captured-id ?source]
- (exec [*writer* &util/get-writer
- :let [_ (doto *writer*
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD
- (normalize-ident ?scope)
- (str +closure-prefix+ ?captured-id)
- "Ljava/lang/Object;"))]]
- (return nil)))
-
-(defn ^:private compile-global [compile *type* ?owner-class ?name]
- (exec [*writer* &util/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (&host/location (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]]
- (return nil)))
-
-(defn ^:private compile-call [compile *type* ?fn ?args]
- (exec [*writer* &util/get-writer
- _ (compile ?fn)
- _ (map-m (fn [arg]
- (exec [ret (compile arg)
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (->class +function-class+) "apply" +apply-signature+)]]
- (return ret)))
- ?args)]
- (return nil)))
-
-(defn ^:private compile-static-call [compile *type* ?needs-num ?fn ?args]
- (assert false (pr-str 'compile-static-call))
- (exec [*writer* &util/get-writer
- :let [_ (match (:form ?fn)
- [::&analyser/global ?owner-class ?fn-name]
- (let [arg-sig (->type-signature "java.lang.Object")
- call-class (&host/location (list ?fn-name ?owner-class))
- provides-num (count ?args)]
- (if (>= provides-num ?needs-num)
- (let [impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)]
- (doto *writer*
- (-> (do (compile arg))
- (->> (doseq [arg (take ?needs-num ?args)])))
- (.visitMethodInsn Opcodes/INVOKESTATIC call-class "impl" impl-sig)
- (-> (doto (do (compile arg))
- (.visitMethodInsn Opcodes/INVOKEINTERFACE (->class +function-class+) "apply" +apply-signature+))
- (->> (doseq [arg (drop ?needs-num ?args)])))))
- (let [counter-sig "I"
- init-signature (str "(" (apply str counter-sig (repeat (dec ?needs-num) arg-sig)) ")" "V")]
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW call-class)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int provides-num))
- (-> (do (compile arg))
- (->> (doseq [arg ?args])))
- (add-nulls (dec (- ?needs-num provides-num)))
- (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" init-signature)))
- ))
- )]]
- (return nil)))
-
-(defn ^:private compile-do [compile *type* ?exprs]
- (exec [*writer* &util/get-writer
- _ (map-m (fn [expr]
- (exec [ret (compile expr)
- :let [_ (.visitInsn *writer* Opcodes/POP)]]
- (return ret)))
- (butlast ?exprs))
- _ (compile (last ?exprs))]
- (return nil)))
-
-(defn ^:private compile-field [compile *type* ?name body]
- (exec [*writer* &util/get-writer
- module-name &analyser/module-name
- :let [outer-class (->class module-name)
- datum-sig (->type-signature "java.lang.Object")
- current-class (&host/location (list ?name outer-class))
- _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
- =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 [(->class +function-class+)]))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil)
- (doto (.visitEnd))))]
- _ (&util/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (exec [*writer* &util/get-writer
- :let [_ (.visitCode *writer*)]
- _ (compile body)
- :let [_ (doto *writer*
- (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig)
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))
- :let [_ (.visitEnd *writer*)]
- _ (save-class! current-class (.toByteArray =class))]
- (return nil)))
-
-(defn ^:private compile-def [compile *type* name value]
- (match value
- [::&analyser/Expression ?form _]
+(defn ^:private compile-expression [syntax]
+ (match syntax
+ [::&a/Expression ?form ?type]
(match ?form
- [::&analyser/lambda ?scope ?captured ?args ?body]
- (compile-lambda compile *type* ?scope ?closure ?args ?body true false)
+ [::&a/bool ?value]
+ (&&lux/compile-bool compile-expression ?type ?value)
+
+ [::&a/int ?value]
+ (&&lux/compile-int compile-expression ?type ?value)
+
+ [::&a/real ?value]
+ (&&lux/compile-real compile-expression ?type ?value)
+
+ [::&a/char ?value]
+ (&&lux/compile-char compile-expression ?type ?value)
+
+ [::&a/text ?value]
+ (&&lux/compile-text compile-expression ?type ?value)
+
+ [::&a/tuple ?elems]
+ (&&lux/compile-tuple compile-expression ?type ?elems)
+
+ [::&a/local ?idx]
+ (&&lux/compile-local compile-expression ?type ?idx)
+
+ [::&a/captured ?scope ?captured-id ?source]
+ (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source)
+
+ [::&a/global ?owner-class ?name]
+ (&&lux/compile-global compile-expression ?type ?owner-class ?name)
+
+ [::&a/call ?fn ?args]
+ (&&lux/compile-call compile-expression ?type ?fn ?args)
+
+ [::&a/static-call ?needs-num ?fn ?args]
+ (&&lux/compile-static-call compile-expression ?type ?needs-num ?fn ?args)
+
+ [::&a/variant ?tag ?members]
+ (&&lux/compile-variant compile-expression ?type ?tag ?members)
+
+ [::&a/case ?variant ?base-register ?num-registers ?branches]
+ (&&case/compile-case compile-expression ?type ?variant ?base-register ?num-registers ?branches)
+
+ [::&a/lambda ?scope ?frame ?args ?body]
+ (&&lambda/compile-lambda compile-expression ?type ?scope ?frame ?args ?body false true)
+
+ [::&a/self ?assumed-args]
+ (&&lux/compile-self-call compile-expression ?assumed-args)
+
+ ;; Integer arithmetic
+ [::&a/jvm-iadd ?x ?y]
+ (&&host/compile-jvm-iadd compile-expression ?type ?x ?y)
+
+ [::&a/jvm-isub ?x ?y]
+ (&&host/compile-jvm-isub compile-expression ?type ?x ?y)
+
+ [::&a/jvm-imul ?x ?y]
+ (&&host/compile-jvm-imul compile-expression ?type ?x ?y)
+
+ [::&a/jvm-idiv ?x ?y]
+ (&&host/compile-jvm-idiv compile-expression ?type ?x ?y)
+
+ [::&a/jvm-irem ?x ?y]
+ (&&host/compile-jvm-irem compile-expression ?type ?x ?y)
+
+ ;; Long arithmetic
+ [::&a/jvm-ladd ?x ?y]
+ (&&host/compile-jvm-ladd compile-expression ?type ?x ?y)
+
+ [::&a/jvm-lsub ?x ?y]
+ (&&host/compile-jvm-lsub compile-expression ?type ?x ?y)
+
+ [::&a/jvm-lmul ?x ?y]
+ (&&host/compile-jvm-lmul compile-expression ?type ?x ?y)
+
+ [::&a/jvm-ldiv ?x ?y]
+ (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y)
+
+ [::&a/jvm-lrem ?x ?y]
+ (&&host/compile-jvm-lrem compile-expression ?type ?x ?y)
+
+ ;; Float arithmetic
+ [::&a/jvm-fadd ?x ?y]
+ (&&host/compile-jvm-fadd compile-expression ?type ?x ?y)
+
+ [::&a/jvm-fsub ?x ?y]
+ (&&host/compile-jvm-fsub compile-expression ?type ?x ?y)
+
+ [::&a/jvm-fmul ?x ?y]
+ (&&host/compile-jvm-fmul compile-expression ?type ?x ?y)
+
+ [::&a/jvm-fdiv ?x ?y]
+ (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y)
+
+ [::&a/jvm-frem ?x ?y]
+ (&&host/compile-jvm-frem compile-expression ?type ?x ?y)
+
+ ;; Double arithmetic
+ [::&a/jvm-dadd ?x ?y]
+ (&&host/compile-jvm-dadd compile-expression ?type ?x ?y)
+
+ [::&a/jvm-dsub ?x ?y]
+ (&&host/compile-jvm-dsub compile-expression ?type ?x ?y)
+
+ [::&a/jvm-dmul ?x ?y]
+ (&&host/compile-jvm-dmul compile-expression ?type ?x ?y)
+
+ [::&a/jvm-ddiv ?x ?y]
+ (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y)
+
+ [::&a/jvm-drem ?x ?y]
+ (&&host/compile-jvm-drem compile-expression ?type ?x ?y)
+
+ [::&a/exec ?exprs]
+ (&&host/compile-exec compile-expression ?type ?exprs)
+
+ [::&a/jvm-new ?class ?classes ?args]
+ (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args)
+
+ [::&a/jvm-getstatic ?class ?field]
+ (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field)
+
+ [::&a/jvm-getfield ?class ?field ?object]
+ (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object)
+
+ [::&a/jvm-invokestatic ?class ?method ?classes ?args]
+ (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args)
+
+ [::&a/jvm-invokevirtual ?class ?method ?classes ?object ?args]
+ (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args)
+
+ [::&a/jvm-new-array ?class ?length]
+ (&&host/compile-jvm-new-array compile-expression ?type ?class ?length)
+
+ [::&a/jvm-aastore ?array ?idx ?elem]
+ (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem)
+
+ [::&a/jvm-aaload ?array ?idx]
+ (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx)
_
- (compile-field compile *type* name value))
-
- _
- (fail "Can only define expressions.")))
-
-(defn ^:private compile-self-call [compile ?assumed-args]
- (exec [*writer* &util/get-writer
- :let [_ (.visitVarInsn *writer* Opcodes/ALOAD 0)]
- _ (map-m (fn [arg]
- (exec [ret (compile arg)
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (->class +function-class+) "apply" +apply-signature+)]]
- (return ret)))
- ?assumed-args)]
- (return nil)))
-
-(defn ^:private compile-expression [syntax]
- (match (:form syntax)
- [::&analyser/bool ?value]
- (compile-bool compile-expression (:type syntax) ?value)
-
- [::&analyser/int ?value]
- (compile-int compile-expression (:type syntax) ?value)
-
- [::&analyser/real ?value]
- (compile-real compile-expression (:type syntax) ?value)
-
- [::&analyser/char ?value]
- (compile-char compile-expression (:type syntax) ?value)
-
- [::&analyser/text ?value]
- (compile-text compile-expression (:type syntax) ?value)
-
- [::&analyser/tuple ?elems]
- (compile-tuple compile-expression (:type syntax) ?elems)
-
- [::&analyser/local ?idx]
- (compile-local compile-expression (:type syntax) ?idx)
-
- [::&analyser/captured ?scope ?captured-id ?source]
- (compile-captured compile-expression (:type syntax) ?scope ?captured-id ?source)
-
- [::&analyser/global ?owner-class ?name]
- (compile-global compile-expression (:type syntax) ?owner-class ?name)
-
- [::&analyser/call ?fn ?args]
- (compile-call compile-expression (:type syntax) ?fn ?args)
-
- [::&analyser/static-call ?needs-num ?fn ?args]
- (compile-static-call compile-expression (:type syntax) ?needs-num ?fn ?args)
-
- [::&analyser/variant ?tag ?members]
- (compile-variant compile-expression (:type syntax) ?tag ?members)
-
- [::&analyser/case ?variant ?base-register ?num-registers ?branches]
- (compile-case compile-expression (:type syntax) ?variant ?base-register ?num-registers ?branches)
-
- [::&analyser/lambda ?scope ?frame ?args ?body]
- (compile-lambda compile-expression (:type syntax) ?scope ?frame ?args ?body false true)
-
- ;; Integer arithmetic
- [::&analyser/jvm-iadd ?x ?y]
- (compile-jvm-iadd compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-isub ?x ?y]
- (compile-jvm-isub compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-imul ?x ?y]
- (compile-jvm-imul compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-idiv ?x ?y]
- (compile-jvm-idiv compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-irem ?x ?y]
- (compile-jvm-irem compile-expression (:type syntax) ?x ?y)
-
- ;; Long arithmetic
- [::&analyser/jvm-ladd ?x ?y]
- (compile-jvm-ladd compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-lsub ?x ?y]
- (compile-jvm-lsub compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-lmul ?x ?y]
- (compile-jvm-lmul compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-ldiv ?x ?y]
- (compile-jvm-ldiv compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-lrem ?x ?y]
- (compile-jvm-lrem compile-expression (:type syntax) ?x ?y)
-
- ;; Float arithmetic
- [::&analyser/jvm-fadd ?x ?y]
- (compile-jvm-fadd compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-fsub ?x ?y]
- (compile-jvm-fsub compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-fmul ?x ?y]
- (compile-jvm-fmul compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-fdiv ?x ?y]
- (compile-jvm-fdiv compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-frem ?x ?y]
- (compile-jvm-frem compile-expression (:type syntax) ?x ?y)
-
- ;; Double arithmetic
- [::&analyser/jvm-dadd ?x ?y]
- (compile-jvm-dadd compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-dsub ?x ?y]
- (compile-jvm-dsub compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-dmul ?x ?y]
- (compile-jvm-dmul compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-ddiv ?x ?y]
- (compile-jvm-ddiv compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/jvm-drem ?x ?y]
- (compile-jvm-drem compile-expression (:type syntax) ?x ?y)
-
- [::&analyser/do ?exprs]
- (compile-do compile-expression (:type syntax) ?exprs)
-
- [::&analyser/jvm-new ?class ?classes ?args]
- (compile-jvm-new compile-expression (:type syntax) ?class ?classes ?args)
-
- [::&analyser/jvm-getstatic ?class ?field]
- (compile-jvm-getstatic compile-expression (:type syntax) ?class ?field)
-
- [::&analyser/jvm-getfield ?class ?field ?object]
- (compile-jvm-getfield compile-expression (:type syntax) ?class ?field ?object)
-
- [::&analyser/jvm-invokestatic ?class ?method ?classes ?args]
- (compile-jvm-invokestatic compile-expression (:type syntax) ?class ?method ?classes ?args)
-
- [::&analyser/jvm-invokevirtual ?class ?method ?classes ?object ?args]
- (compile-jvm-invokevirtual compile-expression (:type syntax) ?class ?method ?classes ?object ?args)
-
- [::&analyser/jvm-new-array ?class ?length]
- (compile-jvm-new-array compile-expression (:type syntax) ?class ?length)
-
- [::&analyser/jvm-aastore ?array ?idx ?elem]
- (compile-jvm-aastore compile-expression (:type syntax) ?array ?idx ?elem)
-
- [::&analyser/jvm-aaload ?array ?idx]
- (compile-jvm-aaload compile-expression (:type syntax) ?array ?idx)
-
- [::&analyser/self ?assumed-args]
- (compile-self-call compile-expression ?assumed-args)
-
- _
- (fail "[Compiler Error] Can't compile expressions as top-level forms.")
- ))
+ (fail "[Compiler Error] Can't compile expressions as top-level forms.")
+ )))
(defn ^:private compile-statement [syntax]
- (match (:form syntax)
- [::&analyser/def ?form ?body]
- (compile-def compile-expression (:type syntax) ?form ?body)
-
- [::&analyser/jvm-interface [?package ?name] ?members]
- (compile-jvm-interface compile-expression (:type syntax) ?package ?name ?members)
+ (match syntax
+ [::&a/Expression ?form ?type]
+ (match ?form
+ [::&a/def ?form ?body]
+ (&&lux/compile-def compile-expression ?type ?form ?body)
+
+ [::&a/jvm-interface [?package ?name] ?members]
+ (&&host/compile-jvm-interface compile-expression ?type ?package ?name ?members)
- [::&analyser/jvm-class [?package ?name] ?super-class ?members]
- (compile-jvm-class compile-expression (:type syntax) ?package ?name ?super-class ?members)
+ [::&a/jvm-class [?package ?name] ?super-class ?members]
+ (&&host/compile-jvm-class compile-expression ?type ?package ?name ?super-class ?members)
- _
- (fail "[Compiler Error] Can't compile expressions as top-level forms.")
- ))
+ _
+ (fail "[Compiler Error] Can't compile expressions as top-level forms.")
+ )))
-;; [Interface]
(let [compiler-step (exec [analysis+ &analyser/analyse]
(map-m compile-statement analysis+))]
- (defn compile-module [name]
+ (defn ^:private compile-module [name]
(exec [loader &util/loader]
(fn [state]
(if (-> state ::&util/modules (contains? name))
(fail "[Compiler Error] Can't redefine a module!")
(let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- (->class name) nil "java/lang/Object" nil))]
+ (&host/->class name) nil "java/lang/Object" nil))]
(match (&util/run-state (exhaust-m compiler-step) (assoc state
::&util/source (slurp (str "source/" name ".lux"))
::&util/current-module name
::&util/writer =class))
[::&util/ok [?state _]]
(do (.visitEnd =class)
- (&util/run-state (save-class! name (.toByteArray =class)) ?state))
+ (&util/run-state (&&/save-class! name (.toByteArray =class)) ?state))
[::&util/failure ?message]
(fail* ?message))))))))
+;; [Resources]
(defn compile-all [modules]
(.mkdir (java.io.File. "output"))
(match (&util/run-state (map-m compile-module modules) (&util/init-state))
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
new file mode 100644
index 000000000..7896902be
--- /dev/null
+++ b/src/lux/compiler/base.clj
@@ -0,0 +1,36 @@
+(ns lux.compiler.base
+ (:require [clojure.string :as string]
+ (lux [util :as &util :refer [exec return* return fail fail*
+ repeat-m exhaust-m try-m try-all-m map-m reduce-m
+ apply-m
+ normalize-ident]]))
+ (:import (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor)))
+
+;; [Resources]
+(def local-prefix "l")
+(def partial-prefix "p")
+(def closure-prefix "c")
+(def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;")
+
+(defn add-nulls [writer amount]
+ (dotimes [_ amount]
+ (.visitInsn writer Opcodes/ACONST_NULL)))
+
+(defn write-file [file data]
+ (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))]
+ (.write stream data)))
+
+(defn write-class [name data]
+ (write-file (str "output/" name ".class") data))
+
+(defn load-class! [loader name]
+ (.loadClass loader name))
+
+(defn save-class! [name bytecode]
+ (exec [loader &util/loader
+ :let [_ (write-class name bytecode)
+ _ (load-class! loader (string/replace name #"/" "."))]]
+ (return nil)))
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index 8f35ec2c0..a6a181a6d 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -1,101 +1,23 @@
-
-(let [+tag-sig+ (->type-signature "java.lang.String")
- variant-class* (->class +variant-class+)
- tuple-class* (->class +tuple-class+)
- +variant-field-sig+ (->type-signature "java.lang.Object")
- oclass (->class "java.lang.Object")
- equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
- (defn ^:private compile-decision-tree [writer mappings default-label decision-tree]
- (match decision-tree
- [::test-bool ?pairs]
- (compile-compare-bools writer mappings default-label ?pairs)
-
- [::test-int ?pairs]
- (compile-compare-ints writer mappings default-label ?pairs)
-
- [::test-real ?pairs]
- (compile-compare-reals writer mappings default-label ?pairs)
-
- [::test-char ?pairs]
- (compile-compare-chars writer mappings default-label ?pairs)
-
- [::test-text ?pairs]
- (compile-compare-texts writer mappings default-label ?pairs)
-
- [::store ?idx $body]
- (doto writer
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body)))
-
- [::test-tuple ?branches ?cases]
- (let [[_ ?subcases] (first ?cases)
- arity (-> ?subcases first (nth 2) count)
- tuple-class** (str tuple-class* arity)]
- (doto writer
- ;; object
- (.visitTypeInsn Opcodes/CHECKCAST tuple-class**) ;; tuple
- (do (doseq [subcase ?subcases
- :let [next-subcase (new Label)]]
- (match subcase
- [::subcase $body ?subseq]
- (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
- :let [sub-next-elem (new Label)]]
- (doto writer
- (.visitInsn Opcodes/DUP) ;; tuple, tuple
- (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; tuple, object
- (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; tuple
- (.visitLabel sub-next-elem)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel next-subcase)))
- )))
- (.visitInsn Opcodes/POP) ;; ->
- (.visitJumpInsn Opcodes/GOTO default-label)))
-
- [::test-variant ?branches ?cases]
- (doto writer
- ;; object
- (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant
- (.visitInsn Opcodes/DUP) ;; variant, variant
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag
- (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag
- (.visitLdcInsn ?tag) ;; variant, tag, tag, text
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B
- (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag
- (.visitInsn Opcodes/POP) ;; variant
- (do (let [arity (-> ?subcases first (nth 2) count)
- variant-class** (str variant-class* arity)]
- (.visitTypeInsn writer Opcodes/CHECKCAST variant-class**) ;; variantN
- (doseq [subcase ?subcases
- :let [next-subcase (new Label)]]
- (match subcase
- [::subcase $body ?subseq]
- (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
- :let [sub-next-elem (new Label)]]
- (doto writer
- (.visitInsn Opcodes/DUP) ;; variant, variant
- (.visitFieldInsn Opcodes/GETFIELD variant-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; variant, object
- (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; variant
- (.visitLabel sub-next-elem)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel next-subcase)))
- ))
- ))
- (.visitInsn Opcodes/POP) ;; ->
- (.visitJumpInsn Opcodes/GOTO default-label)
- ;; variant, tag ->
- (.visitLabel tag-else-label))
- (->> (doseq [[?tag ?subcases] ?cases
- :let [tag-else-label (new Label)]])))
- ;; variant, tag ->
- (.visitInsn Opcodes/POP) ;; variant ->
- (.visitInsn Opcodes/POP) ;; ->
- (.visitJumpInsn Opcodes/GOTO default-label)))
- ))
-
+(ns lux.compiler.case
+ (:require (clojure [set :as set]
+ [template :refer [do-template]])
+ [clojure.core.match :refer [match]]
+ (lux [util :as &util :refer [exec return* return fail fail*
+ repeat-m exhaust-m try-m try-all-m map-m reduce-m
+ apply-m
+ normalize-ident]]
+ [type :as &type]
+ [lexer :as &lexer]
+ [parser :as &parser]
+ [analyser :as &analyser]
+ [host :as &host])
+ [lux.compiler.base :as &&])
+ (:import (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor)))
+
+;; [Utils]
(defn ^:private map-branches [idx mappings patterns]
(reduce (fn [[idx mappings patterns*] [test body]]
[(inc idx)
@@ -177,7 +99,7 @@
(doseq [[?token $body] ?patterns
:let [$else (new Label)]]
(doto writer
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class <wrapper-class>) <value-method> <method-sig>)
(.visitLdcInsn ?token)
(.visitJumpInsn Opcodes/IF_ICMPNE $else)
(.visitInsn Opcodes/POP)
@@ -196,7 +118,7 @@
(doseq [[?token $body] ?patterns
:let [$else (new Label)]]
(doto writer
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class <wrapper-class>) <value-method> <method-sig>)
(.visitLdcInsn ?token)
(.visitInsn <cmp-op>)
(.visitJumpInsn Opcodes/IFNE $else)
@@ -217,7 +139,7 @@
(doto writer
(.visitInsn Opcodes/DUP)
(.visitLdcInsn ?token)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Object") "equals" (str "(" (->type-signature "java.lang.Object") ")Z"))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Object") "equals" (str "(" (&host/->type-signature "java.lang.Object") ")Z"))
(.visitJumpInsn Opcodes/IFEQ $else)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO (get mappings $body))
@@ -232,19 +154,117 @@
[(nth tup idx) body])
?patterns))
(range ?num-elems))
- subpm-structs (map group-patterns sub-patterns)
- [pat-h & pat-t] subpm-structs
- (for [(get-branches pat-h)
- (cull pat-t)]
- )
- (reduce (fn [branches pattern]
- ( (group-patterns pattern)))
- (get-branches pat-h)
- pat-t)
- (sequence-tests sub-patterns)]
+ ;; subpm-structs (map group-patterns sub-patterns)
+ ;; [pat-h & pat-t] subpm-structs
+ ;; (for [(get-branches pat-h)
+ ;; (cull pat-t)]
+ ;; )
+ ;; (reduce (fn [branches pattern]
+ ;; ( (group-patterns pattern)))
+ ;; (get-branches pat-h)
+ ;; pat-t)
+ ]
+ ;; (sequence-tests sub-patterns)
))
-(defn ^:private compile-pm [writer mapping pm-struct]
+(let [+tag-sig+ (&host/->type-signature "java.lang.String")
+ variant-class* (&host/->class &host/variant-class)
+ tuple-class* (&host/->class &host/tuple-class)
+ +variant-field-sig+ (&host/->type-signature "java.lang.Object")
+ oclass (&host/->class "java.lang.Object")
+ equals-sig (str "(" (&host/->type-signature "java.lang.Object") ")Z")]
+ (defn ^:private compile-decision-tree [writer mappings default-label decision-tree]
+ (match decision-tree
+ [::test-bool ?pairs]
+ (compile-bool-pm writer mappings default-label ?pairs)
+
+ [::test-int ?pairs]
+ (compile-int-pm writer mappings default-label ?pairs)
+
+ [::test-real ?pairs]
+ (compile-real-pm writer mappings default-label ?pairs)
+
+ [::test-char ?pairs]
+ (compile-char-pm writer mappings default-label ?pairs)
+
+ [::test-text ?pairs]
+ (compile-text-pm writer mappings default-label ?pairs)
+
+ [::store ?idx $body]
+ (doto writer
+ (.visitVarInsn Opcodes/ASTORE ?idx)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body)))
+
+ [::test-tuple ?branches ?cases]
+ (let [[_ ?subcases] (first ?cases)
+ arity (-> ?subcases first (nth 2) count)
+ tuple-class** (str tuple-class* arity)]
+ (doto writer
+ ;; object
+ (.visitTypeInsn Opcodes/CHECKCAST tuple-class**) ;; tuple
+ (do (doseq [subcase ?subcases
+ :let [next-subcase (new Label)]]
+ (match subcase
+ [::subcase $body ?subseq]
+ (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
+ :let [sub-next-elem (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; tuple, tuple
+ (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str &&/partial-prefix ?subidx) +variant-field-sig+) ;; tuple, object
+ (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; tuple
+ (.visitLabel sub-next-elem)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel next-subcase)))
+ )))
+ (.visitInsn Opcodes/POP) ;; ->
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+
+ [::test-variant ?branches ?cases]
+ (doto writer
+ ;; object
+ (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant
+ (.visitInsn Opcodes/DUP) ;; variant, variant
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag
+ (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag
+ (.visitLdcInsn ?tag) ;; variant, tag, tag, text
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B
+ (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag
+ (.visitInsn Opcodes/POP) ;; variant
+ (do (let [arity (-> ?subcases first (nth 2) count)
+ variant-class** (str variant-class* arity)]
+ (.visitTypeInsn writer Opcodes/CHECKCAST variant-class**) ;; variantN
+ (doseq [subcase ?subcases
+ :let [next-subcase (new Label)]]
+ (match subcase
+ [::subcase $body ?subseq]
+ (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
+ :let [sub-next-elem (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; variant, variant
+ (.visitFieldInsn Opcodes/GETFIELD variant-class** (str &&/partial-prefix ?subidx) +variant-field-sig+) ;; variant, object
+ (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; variant
+ (.visitLabel sub-next-elem)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel next-subcase)))
+ ))
+ ))
+ (.visitInsn Opcodes/POP) ;; ->
+ (.visitJumpInsn Opcodes/GOTO default-label)
+ ;; variant, tag ->
+ (.visitLabel tag-else-label))
+ (->> (doseq [[?tag ?subcases] ?cases
+ :let [tag-else-label (new Label)]])))
+ ;; variant, tag ->
+ (.visitInsn Opcodes/POP) ;; variant ->
+ (.visitInsn Opcodes/POP) ;; ->
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+ ))
+
+(defn ^:private compile-pm [writer mapping pm-struct $default]
(match pm-struct
[::BoolPM ?patterns ?defaults]
(compile-bool-pm writer mapping $default ?patterns)
@@ -310,8 +330,8 @@
[::&parser/Tuple ?members]
(match pm
[::TuplePM ?num-elems ?branches ?defaults]
- (exec [_ (assert! (= ?num-elems (count ?members))
- (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " (count ?members)))]
+ (exec [_ (&util/assert! (= ?num-elems (count ?members))
+ (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " (count ?members)))]
(return [::TuplePM ?num-elems (cons [?members body] ?branches) ?defaults]))
[::?PM ?defaults]
@@ -326,8 +346,8 @@
(match pm
[::VariantPM ?variants ?branches ?defaults]
(exec [variants* (if-let [?num-elems (get ?variants ?tag)]
- (exec [_ (assert! (= ?num-elems num-members)
- (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
+ (exec [_ (&util/assert! (= ?num-elems num-members)
+ (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
(return ?variants))
(return (assoc ?variants ?tag num-members)))]
(return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults]))
@@ -344,8 +364,8 @@
(match pm
[::VariantPM ?variants ?branches ?defaults]
(exec [variants* (if-let [?num-elems (get ?variants ?tag)]
- (exec [_ (assert! (= ?num-elems num-members)
- (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
+ (exec [_ (&util/assert! (= ?num-elems num-members)
+ (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
(return ?variants))
(return (assoc ?variants ?tag num-members)))]
(return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults]))
@@ -412,9 +432,9 @@
(defn ^:private sequence-multi-pm [sequence-pm prev-paths groups]
(match groups
([head & tail] :seq)
- (for [:let [curr-paths (set/intersection prev-paths (valid-paths head))]
- [head-paths head-test] (sequence-pm curr-paths head)]
- [:multi-test head-test head-paths (sequence-multi-pm sequence-pm head-paths tail)])
+ (let [curr-paths (set/intersection prev-paths (valid-paths head))]
+ (for [[head-paths head-test] (sequence-pm curr-paths head)]
+ [:multi-test head-test head-paths (sequence-multi-pm sequence-pm head-paths tail)]))
_
(list (list))))
@@ -444,11 +464,12 @@
)
(defn ^:private sequence-? [group]
- [::?PM ([[default-register $body] & _] :seq)]
- (return (list [<test> default-register #{$body}]))
+ (match group
+ [::?PM ([[default-register $body] & _] :seq)]
+ (return (list [::test-store default-register #{$body}]))
- :else
- (fail ""))
+ :else
+ (fail "")))
(defn ^:private sequence-pm [group]
(match group
@@ -482,14 +503,15 @@
(return (cons [::test-tuple ?num-elems sub-seqs]
(match ?defaults
([[default-register $body] & _] :seq)
- (list [<test> default-register #{$body}])
+ (list [::test-store default-register #{$body}])
:else
(list)))))
[::VariantPM ?tags ?patterns ?defaults]
(map-m (fn [tag]
- (exec [:let [members+bodies (mapcat (fn [[ptag pmembers pbody]]
+ (exec [:let [?num-elems (get ?tags tag)
+ members+bodies (mapcat (fn [[ptag pmembers pbody]]
(if (= ptag tag)
(list [pmembers pbody])
(list)))
@@ -505,7 +527,7 @@
(cons [::test-variant tag ?num-elems sub-seqs]
(match ?defaults
([[default-register $body] & _] :seq)
- (list [<test> default-register #{$body}])
+ (list [::test-store default-register #{$body}])
:else
(list)))))
@@ -518,51 +540,53 @@
paths (valid-paths group*)]]
(sequence-pm paths group*)))
-(let [ex-class (->class "java.lang.IllegalStateException")]
- (defn ^:private compile-case [compile *type* ?variant ?base-register ?num-registers ?branches]
+;; [Resources]
+(let [ex-class (&host/->class "java.lang.IllegalStateException")]
+ (defn compile-case [compile *type* ?variant ?base-register ?num-registers ?branches]
(exec [*writer* &util/get-writer
:let [$start (new Label)
$end (new Label)
_ (dotimes [offset ?num-registers]
(let [idx (+ ?base-register offset)]
- (.visitLocalVariable *writer* (str +local-prefix+ idx) (->java-sig [::&type/Any]) nil $start $end idx)))]
+ (.visitLocalVariable *writer* (str &&/local-prefix idx) (&host/->java-sig [::&type/Any]) nil $start $end idx)))]
_ (compile ?variant)
:let [_ (doto *writer*
(.visitInsn Opcodes/DUP)
(.visitLabel $start))]
:let [[mapping tree] (decision-tree ?branches)]
- :let [[mappings pm-struct*] (map-bodies pm-struct)
- entries (for [[?branch ?body] mappings
- :let [label (new Label)]]
- [[?branch label]
- [label ?body]])
- mappings* (into {} (map first entries))
- ]
- :let [$default (new Label)
- _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts ?pm-struct))]
- (if (get-default pm-struct)
- (butlast pieces)
- pieces))]
- (compile-decision-tree *writer* mappings* $default decision-tree))
- (.visitLabel *writer* $default)
- (if-let [[?idx ?body] (get-default pm-struct)]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitJumpInsn Opcodes/GOTO (get mappings* ?body)))
- (doto *writer*
- (.visitInsn Opcodes/POP)
- (.visitTypeInsn Opcodes/NEW ex-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
- (.visitInsn Opcodes/ATHROW))))]
- _ (map-m (fn [[?label ?body]]
- (exec [:let [_ (do (.visitLabel *writer* ?label)
- (.visitInsn *writer* Opcodes/POP))]
- ret (compile ?body)
- :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]]
- (return ret)))
- (map second entries))
- :let [_ (.visitLabel *writer* $end)]]
+ ;; :let [[mappings pm-struct*] (map-bodies pm-struct)
+ ;; entries (for [[?branch ?body] mappings
+ ;; :let [label (new Label)]]
+ ;; [[?branch label]
+ ;; [label ?body]])
+ ;; mappings* (into {} (map first entries))
+ ;; ]
+ ;; :let [$default (new Label)
+ ;; _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts ?pm-struct))]
+ ;; (if (get-default pm-struct)
+ ;; (butlast pieces)
+ ;; pieces))]
+ ;; (compile-decision-tree *writer* mappings* $default decision-tree))
+ ;; (.visitLabel *writer* $default)
+ ;; (if-let [[?idx ?body] (get-default pm-struct)]
+ ;; (doto *writer*
+ ;; (.visitInsn Opcodes/DUP)
+ ;; (.visitVarInsn Opcodes/ASTORE ?idx)
+ ;; (.visitJumpInsn Opcodes/GOTO (get mappings* ?body)))
+ ;; (doto *writer*
+ ;; (.visitInsn Opcodes/POP)
+ ;; (.visitTypeInsn Opcodes/NEW ex-class)
+ ;; (.visitInsn Opcodes/DUP)
+ ;; (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+ ;; (.visitInsn Opcodes/ATHROW))))]
+ ;; _ (map-m (fn [[?label ?body]]
+ ;; (exec [:let [_ (do (.visitLabel *writer* ?label)
+ ;; (.visitInsn *writer* Opcodes/POP))]
+ ;; ret (compile ?body)
+ ;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]]
+ ;; (return ret)))
+ ;; (map second entries))
+ ;; :let [_ (.visitLabel *writer* $end)]
+ ]
(return nil))))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index dfe67eece..0a11decb4 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -1,18 +1,40 @@
-
-(let [class+metthod+sig {"boolean" [(->class "java.lang.Boolean") "booleanValue" "()Z"]
- "byte" [(->class "java.lang.Byte") "byteValue" "()B"]
- "short" [(->class "java.lang.Short") "shortValue" "()S"]
- "int" [(->class "java.lang.Integer") "intValue" "()I"]
- "long" [(->class "java.lang.Long") "longValue" "()J"]
- "float" [(->class "java.lang.Float") "floatValue" "()F"]
- "double" [(->class "java.lang.Double") "doubleValue" "()D"]
- "char" [(->class "java.lang.Character") "charValue" "()C"]}]
+(ns lux.compiler.host
+ (:require (clojure [string :as string]
+ [set :as set]
+ [template :refer [do-template]])
+ [clojure.core.match :refer [match]]
+ (lux [util :as &util :refer [exec return* return fail fail*
+ repeat-m exhaust-m try-m try-all-m map-m reduce-m
+ apply-m
+ normalize-ident]]
+ [type :as &type]
+ [lexer :as &lexer]
+ [parser :as &parser]
+ [analyser :as &analyser]
+ [host :as &host])
+ [lux.analyser.base :as &a]
+ [lux.compiler.base :as &&]
+ :reload)
+ (:import (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor)))
+
+;; [Utils]
+(let [class+method+sig {"boolean" [(&host/->class "java.lang.Boolean") "booleanValue" "()Z"]
+ "byte" [(&host/->class "java.lang.Byte") "byteValue" "()B"]
+ "short" [(&host/->class "java.lang.Short") "shortValue" "()S"]
+ "int" [(&host/->class "java.lang.Integer") "intValue" "()I"]
+ "long" [(&host/->class "java.lang.Long") "longValue" "()J"]
+ "float" [(&host/->class "java.lang.Float") "floatValue" "()F"]
+ "double" [(&host/->class "java.lang.Double") "doubleValue" "()D"]
+ "char" [(&host/->class "java.lang.Character") "charValue" "()C"]}]
(defn ^:private prepare-arg! [*writer* class-name]
- (if-let [[class method sig] (get class+metthod+sig class-name)]
+ (if-let [[class method sig] (get class+method+sig class-name)]
(doto *writer*
(.visitTypeInsn Opcodes/CHECKCAST class)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig))
- (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class class-name)))))
+ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class class-name)))))
;; (let [boolean-class "java.lang.Boolean"
;; integer-class "java.lang.Integer"
@@ -23,50 +45,50 @@
;; (.visitInsn *writer* Opcodes/ACONST_NULL)
;; [::&type/primitive "char"]
-;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class char-class) "valueOf" (str "(C)" (->type-signature char-class)))
+;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class)))
;; [::&type/primitive "int"]
-;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class integer-class) "valueOf" (str "(I)" (->type-signature integer-class)))
+;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class integer-class) "valueOf" (str "(I)" (&host/->type-signature integer-class)))
;; [::&type/primitive "boolean"]
-;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class boolean-class) "valueOf" (str "(Z)" (->type-signature boolean-class)))
+;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class)))
;; [::&type/Data ?oclass]
;; nil)))
-
-(defn ^:private compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args]
+;; [Resources]
+(defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args]
(exec [*writer* &util/get-writer
- :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
+ :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
_ (map-m (fn [[class-name arg]]
(exec [ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
(return ret)))
(map vector ?classes ?args))
- :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class ?class) ?method method-sig)
+ :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig)
;; (prepare-return! *writer* *type*)
)]]
(return nil)))
-(defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args]
+(defn compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args]
(exec [*writer* &util/get-writer
- :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
+ :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))]
_ (compile ?object)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))]
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))]
_ (map-m (fn [[class-name arg]]
(exec [ret (compile arg)
:let [_ (prepare-arg! *writer* class-name)]]
(return ret)))
(map vector ?classes ?args))
- :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig)
+ :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (&host/->class ?class) ?method method-sig)
;; (prepare-return! *writer* *type*)
)]]
(return nil)))
-(defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args]
+(defn compile-jvm-new [compile *type* ?class ?classes ?args]
(exec [*writer* &util/get-writer
- :let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V")
- class* (->class ?class)
+ :let [init-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")V")
+ class* (&host/->class ?class)
_ (doto *writer*
(.visitTypeInsn Opcodes/NEW class*)
(.visitInsn Opcodes/DUP))]
@@ -79,14 +101,14 @@
(.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
(return nil)))
-(defn ^:private compile-jvm-new-array [compile *type* ?class ?length]
+(defn compile-jvm-new-array [compile *type* ?class ?length]
(exec [*writer* &util/get-writer
:let [_ (doto *writer*
(.visitLdcInsn (int ?length))
- (.visitTypeInsn Opcodes/ANEWARRAY (->class ?class)))]]
+ (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]]
(return nil)))
-(defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem]
+(defn compile-jvm-aastore [compile *type* ?array ?idx ?elem]
(exec [*writer* &util/get-writer
_ (compile ?array)
:let [_ (doto *writer*
@@ -96,7 +118,7 @@
:let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
(return nil)))
-(defn ^:private compile-jvm-aaload [compile *type* ?array ?idx]
+(defn compile-jvm-aaload [compile *type* ?array ?idx]
(exec [*writer* &util/get-writer
_ (compile ?array)
:let [_ (doto *writer*
@@ -104,27 +126,27 @@
(.visitInsn Opcodes/AALOAD))]]
(return nil)))
-(defn ^:private compile-jvm-getstatic [compile *type* ?class ?field]
+(defn compile-jvm-getstatic [compile *type* ?class ?field]
(exec [*writer* &util/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?class) ?field (->java-sig *type*))]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]]
(return nil)))
-(defn ^:private compile-jvm-getfield [compile *type* ?class ?field ?object]
+(defn compile-jvm-getfield [compile *type* ?class ?field ?object]
(exec [*writer* &util/get-writer
_ (compile ?object)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))]
- :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (->class ?class) ?field (->java-sig *type*))]]
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]]
(return nil)))
-(defn ^:private compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods]
- (let [parent-dir (->package ?package)
+(defn compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods]
+ (let [parent-dir (&host/->package ?package)
full-name (str parent-dir "/" ?name)
- super-class* (->class ?super-class)
+ super-class* (&host/->class ?super-class)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
full-name nil super-class* nil))
_ (do (doseq [[field props] ?fields]
- (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil)
+ (doto (.visitField =class Opcodes/ACC_PUBLIC field (&host/->type-signature (:type props)) nil nil)
(.visitEnd)))
(doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
(.visitCode)
@@ -135,25 +157,25 @@
(.visitEnd))
(.visitEnd =class)
(.mkdirs (java.io.File. (str "output/" parent-dir))))]
- (save-class! full-name (.toByteArray =class))))
+ (&&/save-class! full-name (.toByteArray =class))))
-(defn ^:private compile-jvm-interface [compile *type* ?package ?name ?fields ?methods]
- (let [parent-dir (->package ?package)
+(defn compile-jvm-interface [compile *type* ?package ?name ?fields ?methods]
+ (let [parent-dir (&host/->package ?package)
full-name (str parent-dir "/" ?name)
=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE)
full-name nil "java/lang/Object" nil))
_ (do (doseq [[?method ?props] ?methods
:let [[?args ?return] (:type ?props)
- signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]]
+ signature (str "(" (reduce str "" (map &host/->type-signature ?args)) ")" (&host/->type-signature ?return))]]
(.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil))
(.visitEnd =interface)
(.mkdirs (java.io.File. (str "output/" parent-dir))))]
- (save-class! full-name (.toByteArray =interface))))
+ (&&/save-class! full-name (.toByteArray =interface))))
(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>]
(defn <name> [compile *type* ?x ?y]
- (exec [:let [+wrapper-class+ (->class <wrapper-class>)]
+ (exec [:let [+wrapper-class+ (&host/->class <wrapper-class>)]
*writer* &util/get-writer
_ (compile ?x)
:let [_ (doto *writer*
@@ -165,30 +187,40 @@
(.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
_ (doto *writer*
(.visitInsn <opcode>)
- (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (->type-signature <wrapper-class>))))]]
+ (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (&host/->type-signature <wrapper-class>))))]]
(return nil)))
- ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
-
- ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+
+ compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
)
+
+(defn compile-exec [compile *type* ?exprs]
+ (exec [*writer* &util/get-writer
+ _ (map-m (fn [expr]
+ (exec [ret (compile expr)
+ :let [_ (.visitInsn *writer* Opcodes/POP)]]
+ (return ret)))
+ (butlast ?exprs))
+ _ (compile (last ?exprs))]
+ (return nil)))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index b3bfc4860..d0588e073 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -1,11 +1,30 @@
-(ns lux.compiler.lambda)
+(ns lux.compiler.lambda
+ (:require (clojure [string :as string]
+ [set :as set]
+ [template :refer [do-template]])
+ [clojure.core.match :refer [match]]
+ (lux [util :as &util :refer [exec return* return fail fail*
+ repeat-m exhaust-m try-m try-all-m map-m reduce-m
+ normalize-ident]]
+ [type :as &type]
+ [lexer :as &lexer]
+ [parser :as &parser]
+ [analyser :as &analyser]
+ [host :as &host])
+ [lux.analyser.base :as &a]
+ (lux.compiler [base :as &&])
+ :reload)
+ (:import (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor)))
;; [Utils]
-(def ^:private clo-field-sig (->type-signature "java.lang.Object"))
-(def ^:private lambda-return-sig (->type-signature "java.lang.Object"))
+(def ^:private clo-field-sig (&host/->type-signature "java.lang.Object"))
+(def ^:private lambda-return-sig (&host/->type-signature "java.lang.Object"))
(def ^:private <init>-return "V")
(def ^:private counter-sig "I")
-(def ^:private +datum-sig+ (->type-signature "java.lang.Object"))
+(def ^:private +datum-sig+ (&host/->type-signature "java.lang.Object"))
(defn ^:private lambda-impl-signature [args]
(str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig))
@@ -28,7 +47,7 @@
(-> (doto (.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ALOAD ?captured-id)
(.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
- (->> (let [captured-name (str +closure-prefix+ ?captured-id)])
+ (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(match (:form ?captured)
[::&analyser/captured ?closure-id ?captured-id ?source])
(doseq [[?name ?captured] closed-over])))
@@ -38,7 +57,7 @@
(-> (doto (.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ALOAD (+ clo_idx offset))
(.visitFieldInsn Opcodes/PUTFIELD class-name field-name clo-field-sig))
- (->> (let [field-name (str +partial-prefix+ clo_idx)]
+ (->> (let [field-name (str &&/partial-prefix clo_idx)]
(doto (.visitField class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil)
(.visitEnd)))
(dotimes [clo_idx (dec num-args)])
@@ -55,21 +74,17 @@
(.visitVarInsn Opcodes/ALOAD 0)
(.visitFieldInsn Opcodes/GETFIELD class-name (str <prefix> idx) clo-field-sig))))
- ^:private add-closure-vars +closure-prefix+
- ^:private add-partial-vars +partial-prefix+
+ ^:private add-closure-vars &&/closure-prefix
+ ^:private add-partial-vars &&/partial-prefix
)
-(defn ^:private add-nulls [writer amount]
- (dotimes [_ amount]
- (.visitInsn writer Opcodes/ACONST_NULL)))
-
(defn ^:private add-lambda-apply [class class-name closed-over args impl-signature init-signature]
(let [num-args (count args)
num-captured (dec num-args)
default-label (new Label)
branch-labels (for [_ (range num-captured)]
(new Label))]
- (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" +apply-signature+ nil nil)
+ (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" &&/apply-signature nil nil)
(.visitCode)
(-> (doto (.visitVarInsn Opcodes/ALOAD 0)
(.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig)
@@ -81,7 +96,7 @@
(.visitLdcInsn (int current-captured))
(add-partial-vars class-name (take current-captured args))
(.visitVarInsn Opcodes/ALOAD 1)
- (add-nulls (- (dec num-captured) current-captured))
+ (&&/add-nulls (- (dec num-captured) current-captured))
(.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" init-signature)
(.visitInsn Opcodes/ARETURN))
(->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))])))
@@ -126,7 +141,7 @@
:let [num-args (count args)
_ (do (when (> num-args 1)
(.visitInsn *writer* Opcodes/ICONST_0)
- (add-nulls *writer* (dec num-args)))
+ (&&/add-nulls *writer* (dec num-args)))
(.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature))]]
(return nil)))
@@ -136,8 +151,8 @@
(.visitCode)
(.visitTypeInsn Opcodes/NEW class-name)
(.visitInsn Opcodes/DUP)
- (-> (doto (.visitInsn *writer* Opcodes/ICONST_0)
- (add-nulls (dec num-args)))
+ (-> (doto (.visitInsn Opcodes/ICONST_0)
+ (&&/add-nulls (dec num-args)))
(->> (when (> num-args 1))))
(.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" <init>-sig)
(.visitFieldInsn Opcodes/PUTSTATIC class-name "_datum" +datum-sig+)
@@ -152,10 +167,10 @@
<init>-sig (lambda-<init>-signature ?closure ?args)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- lambda-class nil "java/lang/Object" (into-array [(->class +function-class+)]))
+ lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/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)])
+ (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(match (:form ?captured)
[::&analyser/captured ?closure-id ?captured-id ?source])
(doseq [[?name ?captured] ?closure])))
@@ -170,7 +185,7 @@
)]
_ (add-lambda-impl =class compile impl-signature ?body)
:let [_ (.visitEnd =class)]
- _ (save-class! lambda-class (.toByteArray =class))]
+ _ (&&/save-class! lambda-class (.toByteArray =class))]
(if instance?
(instance-closure compile lambda-class ?closure ?args <init>-sig)
(return nil))))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
new file mode 100644
index 000000000..ebf376e39
--- /dev/null
+++ b/src/lux/compiler/lux.clj
@@ -0,0 +1,196 @@
+(ns lux.compiler.lux
+ (:require (clojure [string :as string]
+ [set :as set]
+ [template :refer [do-template]])
+ [clojure.core.match :refer [match]]
+ (lux [util :as &util :refer [exec return* return fail fail*
+ repeat-m exhaust-m try-m try-all-m map-m reduce-m
+ apply-m
+ normalize-ident]]
+ [type :as &type]
+ [lexer :as &lexer]
+ [parser :as &parser]
+ [analyser :as &analyser]
+ [host :as &host])
+ [lux.analyser.base :as &a]
+ (lux.compiler [base :as &&]
+ [lambda :as &&lambda])
+ :reload)
+ (:import (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor)))
+
+;; [Utils]
+(defn ^:private compile-field [compile *type* ?name body]
+ (exec [*writer* &util/get-writer
+ module-name &util/get-module-name
+ :let [outer-class (&host/->class module-name)
+ datum-sig (&host/->type-signature "java.lang.Object")
+ current-class (&host/location (list ?name outer-class))
+ _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)]))
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil)
+ (doto (.visitEnd))))]
+ _ (&util/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
+ (exec [*writer* &util/get-writer
+ :let [_ (.visitCode *writer*)]
+ _ (compile body)
+ :let [_ (doto *writer*
+ (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig)
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))
+ :let [_ (.visitEnd *writer*)]
+ _ (&&/save-class! current-class (.toByteArray =class))]
+ (return nil)))
+
+;; [Resources]
+(let [+class+ (&host/->class "java.lang.Boolean")
+ +sig+ (&host/->type-signature "java.lang.Boolean")]
+ (defn compile-bool [compile *type* ?value]
+ (exec [*writer* &util/get-writer
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (&host/->type-signature "java.lang.Boolean"))]]
+ (return nil))))
+
+(do-template [<name> <class> <sig>]
+ (let [+class+ (&host/->class <class>)]
+ (defn <name> [compile *type* value]
+ (exec [*writer* &util/get-writer
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW <class>)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn value)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]]
+ (return nil))))
+
+ compile-int "java.lang.Long" "(J)V"
+ compile-real "java.lang.Double" "(D)V"
+ compile-char "java.lang.Character" "(C)V"
+ )
+
+(defn compile-text [compile *type* ?value]
+ (exec [*writer* &util/get-writer
+ :let [_ (.visitLdcInsn *writer* ?value)]]
+ (return nil)))
+
+(defn compile-tuple [compile *type* ?elems]
+ (exec [*writer* &util/get-writer
+ :let [num-elems (count ?elems)
+ tuple-class (&host/->class (str &host/tuple-class num-elems))
+ _ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW tuple-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))]
+ _ (map-m (fn [idx]
+ (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)]
+ ret (compile (nth ?elems idx))
+ :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str &&/partial-prefix idx) "Ljava/lang/Object;")]]
+ (return ret)))
+ (range num-elems))]
+ (return nil)))
+
+(defn compile-variant [compile *type* ?tag ?members]
+ (exec [*writer* &util/get-writer
+ :let [variant-class* (str (&host/->class &host/variant-class) (count ?members))
+ _ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW variant-class*)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V")
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn ?tag)
+ (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (&host/->type-signature "java.lang.String")))]
+ _ (map-m (fn [[?tfield ?member]]
+ (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)]
+ ret (compile ?member)
+ :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD variant-class* (str &&/partial-prefix ?tfield) "Ljava/lang/Object;")]]
+ (return ret)))
+ (map vector (range (count ?members)) ?members))]
+ (return nil)))
+
+(defn compile-local [compile *type* ?idx]
+ (exec [*writer* &util/get-writer
+ :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]]
+ (return nil)))
+
+(defn compile-captured [compile *type* ?scope ?captured-id ?source]
+ (exec [*writer* &util/get-writer
+ :let [_ (doto *writer*
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD
+ (normalize-ident ?scope)
+ (str &&/closure-prefix ?captured-id)
+ "Ljava/lang/Object;"))]]
+ (return nil)))
+
+(defn compile-global [compile *type* ?owner-class ?name]
+ (exec [*writer* &util/get-writer
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]]
+ (return nil)))
+
+(defn compile-call [compile *type* ?fn ?args]
+ (exec [*writer* &util/get-writer
+ _ (compile ?fn)
+ _ (map-m (fn [arg]
+ (exec [ret (compile arg)
+ :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]]
+ (return ret)))
+ ?args)]
+ (return nil)))
+
+(defn compile-static-call [compile *type* ?needs-num ?fn ?args]
+ (assert false (pr-str 'compile-static-call))
+ (exec [*writer* &util/get-writer
+ :let [_ (match (:form ?fn)
+ [::&a/global ?owner-class ?fn-name]
+ (let [arg-sig (&host/->type-signature "java.lang.Object")
+ call-class (&host/location (list ?fn-name ?owner-class))
+ provides-num (count ?args)]
+ (if (>= provides-num ?needs-num)
+ (let [impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)]
+ (doto *writer*
+ (-> (do (compile arg))
+ (->> (doseq [arg (take ?needs-num ?args)])))
+ (.visitMethodInsn Opcodes/INVOKESTATIC call-class "impl" impl-sig)
+ (-> (doto (do (compile arg))
+ (.visitMethodInsn Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature))
+ (->> (doseq [arg (drop ?needs-num ?args)])))))
+ (let [counter-sig "I"
+ init-signature (str "(" (apply str counter-sig (repeat (dec ?needs-num) arg-sig)) ")" "V")]
+ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW call-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int provides-num))
+ (-> (do (compile arg))
+ (->> (doseq [arg ?args])))
+ (&&/add-nulls (dec (- ?needs-num provides-num)))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" init-signature)))
+ ))
+ )]]
+ (return nil)))
+
+(defn compile-def [compile *type* name value]
+ (match value
+ [::&a/Expression ?form _]
+ (match ?form
+ [::&a/lambda ?scope ?captured ?args ?body]
+ (&&lambda/compile-lambda compile *type* ?scope ?captured ?args ?body true false)
+
+ _
+ (compile-field compile *type* name value))
+
+ _
+ (fail "Can only define expressions.")))
+
+(defn compile-self-call [compile ?assumed-args]
+ (exec [*writer* &util/get-writer
+ :let [_ (.visitVarInsn *writer* Opcodes/ALOAD 0)]
+ _ (map-m (fn [arg]
+ (exec [ret (compile arg)
+ :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]]
+ (return ret)))
+ ?assumed-args)]
+ (return nil)))
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 56a29b093..b21ed03dc 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -8,6 +8,12 @@
[parser :as &parser]
[type :as &type])))
+;; [Constants]
+(def prefix "lux.")
+(def variant-class (str prefix "Variant"))
+(def tuple-class (str prefix "Tuple"))
+(def function-class (str prefix "Function"))
+
;; [Utils]
(defn ^:private class->type [class]
(if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$"
@@ -54,6 +60,40 @@
(defn ->class [class]
(string/replace class #"\." "/"))
+(def ->package ->class)
+
+(defn ->type-signature [class]
+ (case class
+ "void" "V"
+ "boolean" "Z"
+ "byte" "B"
+ "short" "S"
+ "int" "I"
+ "long" "J"
+ "float" "F"
+ "double" "D"
+ "char" "C"
+ ;; else
+ (let [class* (->class class)]
+ (if (.startsWith class* "[")
+ class*
+ (str "L" class* ";")))
+ ))
+
+(defn ->java-sig [type]
+ (match type
+ ::&type/Any
+ (->type-signature "java.lang.Object")
+
+ [::&type/Data ?name]
+ (->type-signature ?name)
+
+ [::&type/Array ?elem]
+ (str "[" (->java-sig ?elem))
+
+ [::&type/Lambda _ _]
+ (->type-signature function-class)))
+
(defn extract-jvm-param [token]
(match token
[::&parser/ident ?ident]