aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser.clj199
-rw-r--r--src/lux/compiler.clj172
2 files changed, 170 insertions, 201 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 14bb533dc..d44c333b1 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -14,6 +14,8 @@
;; [Util]
(def +int-class+ "java.lang.Integer")
+(def +dont-care-type+ [::&type/object "java.lang.Object" []])
+
(defn ^:private annotated [form type]
{:form form
:type type})
@@ -411,7 +413,7 @@
(exec [[=test] (analyse-ast ?test)
[=then] (analyse-ast ?then)
[=else] (analyse-ast ?else)]
- (return (list (annotated [::if =test =then =else] ::&type/nothing)))))
+ (return (list (annotated [::if =test =then =else] +dont-care-type+)))))
(defn ^:private analyse-do [analyse-ast ?exprs]
(exec [=exprs (do-all-m* (map analyse-ast ?exprs))]
@@ -646,7 +648,7 @@
))
(partition 2 ?branches))]
(return (->decision-tree $scope $base =branches)))]
- (return (list (annotated [::case (dec $base) =variant registers mappings tree] ::&type/nothing))))))
+ (return (list (annotated [::case (dec $base) =variant registers mappings tree] +dont-care-type+))))))
(defn ^:private analyse-let [analyse-ast ?label ?value ?body]
(exec [[=value] (analyse-ast ?value)
@@ -655,53 +657,82 @@
(analyse-ast ?body))]
(return (list (annotated [::let idx ?label =value =body] (:type =body))))))
-(declare raise-bindings)
-(defn ^:private raise-tree-bindings [outer-scope ?tree]
- (case (:type ?tree)
- ::adt*
- (update-in ?tree [:patterns]
- #(into {} (for [[?tag ?unapply] %
- :let [=unapply (update-in ?unapply [:parts] (partial map (partial raise-tree-bindings outer-scope)))]]
- [?tag =unapply])))
-
- ::defaults
- (update-in ?tree [:stores]
- #(into {} (for [[?store ?branches] %
- :let [=store (raise-bindings outer-scope {:form ?store :type ::&type/nothing})]]
- [(:form =store) ?branches])))
- ;; else
- (assert false (pr-str ?tree))
- ))
+(defn ^:private raise-tree-bindings [raise-expr outer-scope ?tree]
+ (let [partial-f (partial raise-expr outer-scope)
+ tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)]
+ (case (:type ?tree)
+ ::adt*
+ (update-in ?tree [:patterns]
+ #(into {} (for [[?tag ?unapply] %]
+ [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))])))
+
+ ::defaults
+ (update-in ?tree [:stores]
+ #(into {} (for [[?store ?branches] %
+ :let [=store (partial-f {:form ?store :type ::&type/nothing})]]
+ [(:form =store) ?branches])))
+ ;; else
+ (assert false (pr-str ?tree))
+ )))
-(defn ^:private raise-bindings [outer-scope body]
+(defn ^:private raise-expr [outer-scope syntax]
;; (prn 'raise-bindings body)
- (match (:form body)
- [::local ?scope ?idx]
- {:form [::local outer-scope (inc ?idx)]
- :type (:type body)}
-
- [::captured _ _ ?source]
- ?source
-
- [::jvm:iadd ?x ?y]
- {:form [::jvm:iadd
- (raise-bindings outer-scope ?x)
- (raise-bindings outer-scope ?y)]
- :type (:type body)}
-
- [::case ?base ?variant ?registers ?mappings ?tree]
- (let [=variant (raise-bindings outer-scope ?variant)
- =mappings (into {} (for [[idx syntax] ?mappings]
- [idx (raise-bindings outer-scope syntax)]))
- =tree (raise-tree-bindings outer-scope ?tree)]
- {:form [::case ?base =variant ?registers =mappings =tree]
- :type (:type body)})
-
- [::call ?func ?args]
- {:form [::call (raise-bindings outer-scope ?func)
- (map (partial raise-bindings outer-scope) ?args)]
- :type (:type body)}
- ))
+ (let [partial-f (partial raise-expr outer-scope)
+ tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)]
+ (match (:form syntax)
+ [::literal ?value]
+ syntax
+
+ [::tuple ?members]
+ {:form [::tuple (map partial-f ?members)]
+ :type (:type syntax)}
+
+ [::variant ?tag ?members]
+ {:form [::variant ?tag (map partial-f ?members)]
+ :type (:type syntax)}
+
+ [::local ?scope ?idx]
+ {:form [::local outer-scope (inc ?idx)]
+ :type (:type syntax)}
+
+ [::captured _ _ ?source]
+ ?source
+
+ [::self ?self-name ?curried]
+ {:form [::self outer-scope (mapv partial-f ?curried)]
+ :type (:type syntax)}
+
+ [::jvm:iadd ?x ?y]
+ {:form [::jvm:iadd (partial-f ?x) (partial-f ?y)]
+ :type (:type syntax)}
+
+ [::let ?idx ?name ?value ?body]
+ {:form [::let ?idx ?name (partial-f ?value) (partial-f ?body)]
+ :type (:type syntax)}
+
+ [::case ?base ?variant ?registers ?mappings ?tree]
+ (let [=variant (partial-f ?variant)
+ =mappings (into {} (for [[idx syntax] ?mappings]
+ [idx (partial-f syntax)]))
+ =tree (tree-partial-f ?tree)]
+ {:form [::case ?base =variant ?registers =mappings =tree]
+ :type (:type syntax)})
+
+ [::lambda ?scope ?captured ?args ?value]
+ {:form [::lambda outer-scope
+ (into {} (for [[?name ?sub-syntax] ?captured]
+ [?name (partial-f ?sub-syntax)]))
+ ?args
+ ?value]
+ :type (:type syntax)}
+
+ [::call ?func ?args]
+ {:form [::call (partial-f ?func) (map partial-f ?args)]
+ :type (:type syntax)}
+
+ _
+ (assert false (pr-str (:form syntax)))
+ )))
(defn ^:private analyse-lambda [analyse-ast ?self ?arg ?body]
(exec [[_ =arg =return :as =function] (within ::types &type/fresh-function)
@@ -717,8 +748,7 @@
:let [;; _ (prn '(:form =body) (:form =body))
=lambda (match (:form =body)
[::lambda ?sub-scope ?sub-captured ?sub-args ?sub-body]
- (let [?sub-body* (raise-bindings =scope ?sub-body)]
- [::lambda =scope =captured (cons ?arg ?sub-args) ?sub-body*])
+ [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr =scope ?sub-body)]
_
[::lambda =scope =captured (list ?arg) =body])]
@@ -726,72 +756,6 @@
]
(return (list (annotated =lambda =function)))))
-(declare ->def-lambda)
-(defn ^:private ->def-lambda-tree [old-scope new-scope ?tree]
- (case (:type ?tree)
- ::adt*
- (update-in ?tree [:patterns]
- #(into {} (for [[?tag ?unapply] %
- :let [=unapply (update-in ?unapply [:parts] (partial map (partial ->def-lambda-tree old-scope new-scope)))]]
- [?tag =unapply])))
-
- ::defaults
- (update-in ?tree [:stores]
- #(into {} (for [[?store ?branches] %
- :let [=store (->def-lambda old-scope new-scope {:form ?store :type ::&type/nothing})]]
- [(:form =store) ?branches])))
- ;; else
- (assert false (pr-str ?tree))
- ))
-
-(defn ^:private ->def-lambda [old-scope new-scope syntax]
- (match (:form syntax)
- [::literal _]
- syntax
-
- [::variant ?tag ?elems]
- {:form [::variant ?tag (map (partial ->def-lambda old-scope new-scope) ?elems)]
- :type (:type syntax)}
-
- [::local ?local-scope ?idx]
- {:form [::local new-scope (inc ?idx)]
- :type (:type syntax)}
-
- [::self ?self-name ?curried]
- (if (= ?self-name old-scope)
- {:form [::self new-scope (mapv (partial ->def-lambda old-scope new-scope) ?curried)]
- :type (:type syntax)}
- syntax)
-
-
- [::jvm:iadd ?x ?y]
- {:form [::jvm:iadd (->def-lambda old-scope new-scope ?x) (->def-lambda old-scope new-scope ?y)]
- :type (:type syntax)}
-
- [::case ?base ?variant ?registers ?mappings ?tree]
- (let [=variant (->def-lambda old-scope new-scope ?variant)
- =mappings (into {} (for [[idx syntax] ?mappings]
- [idx (->def-lambda old-scope new-scope syntax)]))
- =tree (->def-lambda-tree old-scope new-scope ?tree)]
- {:form [::case ?base =variant ?registers =mappings =tree]
- :type (:type syntax)})
-
- [::call ?func ?args]
- {:form [::call (->def-lambda old-scope new-scope ?func)
- (map (partial ->def-lambda old-scope new-scope) ?args)]
- :type (:type syntax)}
-
- [::lambda ?scope ?captured ?args ?value]
- {:form [::lambda new-scope
- (into {} (for [[?name ?sub-syntax] ?captured]
- [?name (->def-lambda old-scope new-scope ?sub-syntax)]))
- ?args
- ?value]
- :type (:type syntax)}
-
- _
- (assert false (pr-str (:form syntax)))))
-
(defn ^:private analyse-def [analyse-ast ?name ?value]
(exec [def?? (defined? ?name)]
(if def??
@@ -802,9 +766,10 @@
(analyse-ast ?value))
;; :let [_ (prn 'DEF/PRE =value)]
:let [;; _ (prn 'analyse-def/=value =value)
+ new-scope [$module ?name]
=value (match (:form =value)
- [::lambda ?scope ?env ?args ?body]
- {:form [::lambda ?scope ?env ?args (->def-lambda ?scope [$module ?name] ?body)]
+ [::lambda ?old-scope ?env ?args ?body]
+ {:form [::lambda new-scope ?env ?args (raise-expr new-scope ?body)]
:type (:type =value)}
_
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index e9a445510..f6daaca0f 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -161,22 +161,23 @@
(defn ^:private compile-tuple [compile *type* ?elems]
(exec [*writer* get-writer
- :let [_ (let [num-elems (count ?elems)]
- (let [tuple-class (str (str +prefix+ "/Tuple") num-elems)]
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW tuple-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))
- (dotimes [idx num-elems]
- (.visitInsn *writer* Opcodes/DUP)
- (compile (nth ?elems idx))
- (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str "_" (inc idx)) "Ljava/lang/Object;"))))]]
+ :let [num-elems (count ?elems)
+ tuple-class (str (str +prefix+ "/Tuple") 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 "_" (inc idx)) "Ljava/lang/Object;")]]
+ (return ret)))
+ (range num-elems))]
(return nil)))
(defn ^:private compile-local [compile *type* ?env ?idx]
(exec [*writer* get-writer
- :let [_ (doto *writer*
- (.visitVarInsn Opcodes/ALOAD (int ?idx)))]]
+ :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]]
(return nil)))
(defn ^:private compile-captured [compile *type* ?scope ?captured-id ?source]
@@ -191,8 +192,7 @@
(defn ^:private compile-global [compile *type* ?owner-class ?name]
(exec [*writer* get-writer
- :let [_ (doto *writer*
- (.visitFieldInsn Opcodes/GETSTATIC (->class (str ?owner-class "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;"))]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (str ?owner-class "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;")]]
(return nil)))
(defn ^:private compile-global-fn [compile *type* ?owner-class ?name]
@@ -247,8 +247,7 @@
(defn ^:private compile-jvm-getstatic [compile *type* ?owner ?field]
(exec [*writer* get-writer
- :let [_ (doto *writer*
- (.visitFieldInsn Opcodes/GETSTATIC (->class ?owner) ?field (->java-sig *type*)))]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?owner) ?field (->java-sig *type*))]]
(return nil)))
(defn prepare-arg! [*writer* class-name]
@@ -310,30 +309,32 @@
(defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args]
(exec [*writer* get-writer
- :let [_ (let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
- (compile ?object)
- (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))
- (doseq [[class-name arg] (map vector ?classes ?args)]
- (do (compile arg)
- (prepare-arg! *writer* class-name)))
- (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig)
- (prepare-return! *writer* *type*)
- )]]
+ :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
+ _ (compile ?object)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->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)
+ (prepare-return! *writer* *type*))]]
(return nil)))
(defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args]
(exec [*writer* get-writer
- :let [_ (let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V")
- class* (->class ?class)]
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW class*)
- (.visitInsn Opcodes/DUP))
- (doseq [[class-name arg] (map vector ?classes ?args)]
- (do (compile arg)
- (prepare-arg! *writer* class-name)))
- (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))
- )]]
+ :let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V")
+ class* (->class ?class)
+ _ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW class*)
+ (.visitInsn Opcodes/DUP))]
+ _ (map-m (fn [[class-name arg]]
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (map vector ?classes ?args))
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
(return nil)))
(defn ^:private compile-jvm-new-array [compile *type* ?class ?length]
@@ -345,18 +346,18 @@
(defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem]
(exec [*writer* get-writer
+ _ (compile ?array)
:let [_ (doto *writer*
- (do (compile ?array))
(.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int ?idx))
- (do (compile ?elem))
- (.visitInsn Opcodes/AASTORE))]]
+ (.visitLdcInsn (int ?idx)))]
+ _ (compile ?elem)
+ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
(return nil)))
(defn ^:private compile-jvm-aaload [compile *type* ?array ?idx]
(exec [*writer* get-writer
+ _ (compile ?array)
:let [_ (doto *writer*
- (do (compile ?array))
(.visitLdcInsn (int ?idx))
(.visitInsn Opcodes/AALOAD))]]
(return nil)))
@@ -364,27 +365,29 @@
(let [+bool-class+ (->class "java.lang.Boolean")]
(defn ^:private compile-if [compile *type* ?test ?then ?else]
(exec [*writer* get-writer
- :let [_ (let [else-label (new Label)
- end-label (new Label)]
- (compile ?test)
- (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +bool-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +bool-class+ "booleanValue" "()Z")
- (.visitJumpInsn Opcodes/IFEQ else-label))
- (compile ?then)
- (doto *writer*
- (.visitJumpInsn Opcodes/GOTO end-label)
- (.visitLabel else-label))
- (compile ?else)
- (.visitLabel *writer* end-label))]]
+ :let [else-label (new Label)
+ end-label (new Label)]
+ _ (compile ?test)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +bool-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +bool-class+ "booleanValue" "()Z")
+ (.visitJumpInsn Opcodes/IFEQ else-label))]
+ _ (compile ?then)
+ :let [_ (doto *writer*
+ (.visitJumpInsn Opcodes/GOTO end-label)
+ (.visitLabel else-label))]
+ _ (compile ?else)
+ :let [_ (.visitLabel *writer* end-label)]]
(return nil))))
(defn ^:private compile-do [compile *type* ?exprs]
(exec [*writer* get-writer
- :let [_ (do (doseq [expr (butlast ?exprs)]
- (compile expr)
- (.visitInsn *writer* Opcodes/POP))
- (compile (last ?exprs)))]]
+ _ (map-m (fn [expr]
+ (exec [ret (compile expr)
+ :let [_ (.visitInsn *writer* Opcodes/POP)]]
+ (return ret)))
+ (butlast ?exprs))
+ _ (compile (last ?exprs))]
(return nil)))
(let [+tag-sig+ (->type-signature "java.lang.String")
@@ -633,16 +636,16 @@
(defn ^:private compile-let [compile *type* ?idx ?label ?value ?body]
(exec [*writer* get-writer
- :let [_ (let [start-label (new Label)
- end-label (new Label)
- ?idx (int ?idx)]
- (.visitLocalVariable *writer* (normalize-ident ?label) (->java-sig (:type ?value)) nil start-label end-label ?idx)
- (compile ?value)
- (doto *writer*
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitLabel start-label))
- (compile ?body)
- (.visitLabel *writer* end-label))]]
+ :let [start-label (new Label)
+ end-label (new Label)
+ ?idx (int ?idx)
+ _ (.visitLocalVariable *writer* (normalize-ident ?label) (->java-sig (:type ?value)) nil start-label end-label ?idx)]
+ _ (compile ?value)
+ :let [_ (doto *writer*
+ (.visitVarInsn Opcodes/ASTORE ?idx)
+ (.visitLabel start-label))]
+ _ (compile ?body)
+ :let [_ (.visitLabel *writer* end-label)]]
(return nil)))
(defn compile-field [compile ?name body]
@@ -874,7 +877,7 @@
(compile-method compile ?name ?value)
_
- (compile-field compile ?name ?value))]
+ (compile-field compile ?name ?value))]
(return nil)))
(defn ^:private compile-defclass [compile *type* ?package ?name ?super-class ?members]
@@ -919,19 +922,20 @@
(defn ^:private compile-variant [compile *type* ?tag ?members]
(exec [*writer* get-writer
- :let [_ (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"))
- (-> (doto (.visitInsn Opcodes/DUP)
- (do (compile ?member))
- (.visitFieldInsn Opcodes/PUTFIELD variant-class* (str "_" (inc ?tfield)) "Ljava/lang/Object;"))
- (->> (doseq [[?tfield ?member] (mapv vector (range (count ?members)) ?members)]))))
- )]]
+ :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 "_" (inc ?tfield)) "Ljava/lang/Object;")]]
+ (return ret)))
+ (map vector (range (count ?members)) ?members))]
(return nil)))
(let [+int-class+ (->class "java.lang.Integer")]
@@ -958,7 +962,7 @@
^:private compile-jvm-irem Opcodes/IREM
))
-(defn compile-self-call [?scope ?assumed-args]
+(defn compile-self-call [compile ?scope ?assumed-args]
(exec [*writer* get-writer
:let [lambda-class (->class (reduce str "" (interpose "$" (map normalize-ident ?scope))))
_ (doto *writer*
@@ -1058,7 +1062,7 @@
(compile-defclass compile (:type syntax) ?package ?name ?super-class ?members)
[::&analyser/self ?scope ?assumed-args]
- (compile-self-call ?scope ?assumed-args)
+ (compile-self-call compile ?scope ?assumed-args)
))
;; [Interface]