aboutsummaryrefslogtreecommitdiff
path: root/src/lang
diff options
context:
space:
mode:
Diffstat (limited to 'src/lang')
-rw-r--r--src/lang/analyser.clj211
-rw-r--r--src/lang/compiler.clj156
-rw-r--r--src/lang/parser.clj19
-rw-r--r--src/lang/util.clj16
4 files changed, 309 insertions, 93 deletions
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
index 4436b0b61..7c94c77d5 100644
--- a/src/lang/analyser.clj
+++ b/src/lang/analyser.clj
@@ -4,7 +4,7 @@
[template :refer [do-template]])
[clojure.core.match :refer [match]]
(lang [util :as &util :refer [exec return* return fail fail*
- repeat-m try-m try-all-m map-m
+ repeat-m try-m try-all-m map-m reduce-m
apply-m within]]
[parser :as &parser]
[type :as &type])))
@@ -37,6 +37,10 @@
(fn [state]
[::&util/ok [state (-> state :env first :counter)]]))
+(def ^:private scope-id
+ (fn [state]
+ [::&util/ok [state (-> state :env first :id)]]))
+
(def ^:private my-frame
(fn [state]
[::&util/ok [state (-> state :env first)]]))
@@ -53,6 +57,20 @@
_
=return))))
+(defn ^:private with-scoped-name [name type body]
+ (fn [state]
+ (let [=return (body (update-in state [:env]
+ #(cons (assoc-in (first %) [:mappings name] (annotated [::global (:name state) name] type))
+ (rest %))))]
+ (match =return
+ [::&util/ok [?state ?value]]
+ [::&util/ok [(update-in ?state [:env] #(cons (update-in (first %) [:mappings] dissoc name)
+ (rest %)))
+ ?value]]
+
+ _
+ =return))))
+
(defn ^:private with-lambda-scope [body]
(fn [state]
(let [;; _ (prn 'with-lambda-scope (get-in state [:lambda-scope 0]) (get-in state [:lambda-scope 1]))
@@ -99,6 +117,36 @@
=return)
)))
+(defn ^:private with-anon-locals [amount k]
+ (fn [state]
+ (let [env (-> state :env first)
+ $scope (:id env)
+ =locals (for [$local (take amount (iterate inc (:counter env)))]
+ (annotated [::local $scope $local] [::&type/object "java.lang.Object" []]))
+ =return ((k =locals) (update-in state [:env] #(cons (update-in (first %) [:counter] + amount) (rest %))))]
+ (match =return
+ [::&util/ok [?state ?value]]
+ (do ;; (prn 'POST-WITH-LOCAL name (-> ?state :env first))
+ [::&util/ok [(update-in ?state [:env] #(cons (update-in (first %) [:counter] - amount) (rest %)))
+ ?value]])
+
+ _
+ =return))))
+
+(defn ^:private with-locals [mappings monad]
+ (fn [state]
+ (let [=return (monad (update-in state [:env] #(cons (update-in (first %) [:mappings] merge mappings)
+ (rest %))))]
+ (match =return
+ [::&util/ok [?state ?value]]
+ (do ;; (prn 'POST-WITH-LOCAL name (-> ?state :env first))
+ [::&util/ok [(update-in ?state [:env] #(cons (assoc (first %) :mappings (-> state :env first :mappings))
+ (rest %)))
+ ?value]])
+
+ _
+ =return))))
+
(defn ^:private with-fresh-env [[args-vars args-types] body]
(with-lambda-scope
(fn [state]
@@ -119,12 +167,12 @@
(match =return
[::&util/ok [?state ?value]]
(do ;; (prn 'PRE-LAMBDA (:env state))
- ;; (prn 'POST-LAMBDA (:env ?state) ?value)
- [::&util/ok [(-> ?state
- (update-in [:env] rest)
- ;; (update-in [:lambda-scope 1] inc)
- )
- [(get-in ?state [:lambda-scope 0]) (-> ?state :env first) ?value]]])
+ ;; (prn 'POST-LAMBDA (:env ?state) ?value)
+ [::&util/ok [(-> ?state
+ (update-in [:env] rest)
+ ;; (update-in [:lambda-scope 1] inc)
+ )
+ [(get-in ?state [:lambda-scope 0]) (-> ?state :env first) ?value]]])
_
=return)))))
@@ -221,12 +269,12 @@
)
(defanalyser analyse-variant
- [::&parser/tagged ?tag ?value]
+ [::&parser/variant ?tag ?data]
(exec [;; :let [_ (prn 'analyse-variant [?tag ?value])]
- =value (analyse-form* ?value)
+ =data (map-m analyse-form* ?data)
;; :let [_ (prn '=value =value)]
]
- (return (annotated [::variant ?tag =value] [::&type/variant ?tag (:type =value)]))))
+ (return (annotated [::variant ?tag =data] [::&type/variant ?tag (map :type =data)]))))
(defanalyser analyse-tuple
[::&parser/tuple ?elems]
@@ -239,7 +287,9 @@
;; ;; :let [_ (prn 'analyse-ident ?ident _env)]
;; ]
;; (resolve ?ident))
- (exec [=ident (resolve ?ident)
+ (exec [;; :let [_ (prn 'analyse-ident '?ident ?ident)]
+ =ident (resolve ?ident)
+ ;; :let [_ (prn 'analyse-ident '=ident =ident)]
;; :let [_ (prn 'analyse-ident ?ident =ident)]
;; state &util/get-state
;; :let [_ (prn 'analyse-ident ?ident (:form =ident) (:env state))]
@@ -378,21 +428,117 @@
(exec [;; :let [_ (prn '?variant ?variant)]
=variant (analyse-form* ?variant)
;; :let [_ (prn '=variant =variant)]
- =branches (map-m (fn [branch]
- ;; (prn 'branch branch)
- (match branch
- [::&parser/case-branch [::&parser/tagged ?tag [::&parser/ident ?label]] ?body]
- (exec [;; :let [_ (prn ?tag ?label '?body ?body)]
- idx next-local-idx
- =body (with-local ?label [::&type/object "java.lang.Object" []]
- (analyse-form* ?body))
- ;; :let [_ (prn ?tag ?label '=body =body)]
- ]
- (return [?tag ?label idx =body]))))
- ?branches)
+ ;; {:registers 3,
+ ;; :patterns {"Cons" {:arity 2, :branches [{:test [:lang/case-try "Cons" [[:lang/case-sub-bind 1] [:lang/case-sub-bind 2]]], :link 1}]},
+ ;; "Nil" {:arity 0, :branches [{:test [:lang/case-try "Nil" []], :link 0}]}},
+ ;; :paths {:total 2,
+ ;; :links {1 [:lang.parser/variant "Cons" ([:lang.parser/ident "x"] [:lang.parser/fn-call [:lang.parser/ident "++"] ([:lang.parser/ident "xs*"] [:lang.parser/ident "ys"])])],
+ ;; 0 [:lang.parser/ident "ys"]}}}
+ [$base =branches] (with-anon-locals 1
+ (fn [=locals]
+ ;; (prn 'analyse-case '=locals (map :form =locals))
+ (exec [=branches (map-m (fn [?branch]
+ ;; (prn '?branch ?branch)
+ (match ?branch
+ [::&parser/case-branch [::&parser/variant ?tag ?members] ?body]
+ (let [num-members (count ?members)]
+ (with-anon-locals num-members
+ (fn [=locals]
+ ;; (prn '?branch/=locals (map :form =locals))
+ (exec [=members (reduce-m (fn [[locals-map =members] [?local ?member]]
+ (match ?member
+ [::&parser/ident ?name]
+ (return [(assoc locals-map ?name ?local) (conj =members (:form ?local))])))
+ [{} []]
+ (map vector =locals ?members))
+ ;; :let [_ (prn (first =members) ?body)]
+ =body (with-locals (first =members)
+ (analyse-form* ?body))
+ ;; :let [_ (prn '?body ?body =body)]
+ ]
+ (return [num-members [::branch-adt ?tag (second =members) =body]])))))))
+ ?branches)]
+ (return [(first =locals) =branches]))))
+ :let [total-registers (reduce + 1 (map first =branches))
+ ;; _ (prn '=branches total-registers (map second =branches))
+ ;; _ (assert false)
+ ]
+ ;; ([::&parser/case-branch [::&parser/variant "Nil" ()]
+ ;; [::&parser/ident "ys"]]
+ ;; [::&parser/case-branch [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/ident "xs*"])]
+ ;; [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/fn-call [::&parser/ident "++"] ([::&parser/ident "xs*"] [::&parser/ident "ys"])])]])
+ ;; :let [_ (prn '?branches ?branches)
+ ;; case-analysis (let [gen-impl (fn gen-impl [offset pattern]
+ ;; (clojure.core.match/match pattern
+ ;; [::&parser/ident _]
+ ;; [1 [::case-bind -1 offset]]
+
+ ;; [::&parser/variant ?tag ?members]
+ ;; (let [regs+insns (mapv (fn [idx member]
+ ;; (clojure.core.match/match member
+ ;; [::&parser/ident _]
+ ;; [1 [::case-sub-bind (+ offset (inc idx))]]))
+ ;; (range (count ?members))
+ ;; ?members)]
+ ;; [(reduce + 1 (map first regs+insns)) [::case-try ?tag (mapv second regs+insns)]])
+ ;; (reduce + (count ?members) (map gen-impl ?members))))]
+ ;; (reduce (fn [accum branch]
+ ;; (clojure.core.match/match branch
+ ;; [::&parser/case-branch ?pattern ?body]
+ ;; (clojure.core.match/match ?pattern
+ ;; [::&parser/variant ?tag ?members]
+ ;; (let [[extra-registers impl] (gen-impl 0 ?pattern)
+ ;; _ (prn 'impl extra-registers impl)
+ ;; $branch (get-in accum [:paths :total])]
+ ;; (-> accum
+ ;; (update-in [:patterns]
+ ;; (fn [patterns]
+ ;; (if (contains? patterns ?tag)
+ ;; (if (= (get patterns [?tag :arity]) (count ?members))
+ ;; (update-in patterns [?tag :branches] conj {:test impl
+ ;; :link $branch})
+ ;; (assert "Pattern arity doesn't match!"))
+ ;; (assoc patterns ?tag {:arity (count ?members)
+ ;; :branches [{:test impl
+ ;; :link $branch}]}))))
+ ;; (update-in [:paths]
+ ;; (fn [paths]
+ ;; (-> paths
+ ;; (update-in [:total] inc)
+ ;; (assoc-in [:links $branch] ?body))))
+ ;; (update-in [:registers] + (dec extra-registers)))))
+ ;; ))
+ ;; {:registers 1
+ ;; :patterns {}
+ ;; :paths {:total 0
+ ;; :links {}}}
+ ;; ?branches))
+ ;; _ (prn 'case-analysis case-analysis)
+ ;; _ (assert false)]
+ ;; =branches (map-m identity ;; (fn [branch]
+ ;; ;; ;; (prn 'branch branch)
+ ;; ;; (match branch
+ ;; ;; [::&parser/case-branch [::&parser/variant ?tag ?parts] ?body]
+ ;; ;; (exec [;; :let [_ (prn ?tag ?label '?body ?body)]
+ ;; ;; ;; (reduce-m (fn [?part]
+ ;; ;; ;; (match ?part
+ ;; ;; ;; [::&parser/ident ?label]
+ ;; ;; ;; (exec [idx next-local-idx
+ ;; ;; ;; =body (with-local ?label [::&type/object "java.lang.Object" []]
+ ;; ;; ;; (analyse-form* ?body))]
+ ;; ;; ;; (return ...)))
+ ;; ;; ;; )
+ ;; ;; ;; ?parts)
+ ;; ;; idx next-local-idx
+ ;; ;; =body (with-local ?label [::&type/object "java.lang.Object" []]
+ ;; ;; (analyse-form* ?body))
+ ;; ;; ;; :let [_ (prn ?tag ?label '=body =body)]
+ ;; ;; ]
+ ;; ;; (return [?tag ?label idx =body]))))
+ ;; ?branches)
;; :let [_ (prn '=branches =branches)]
]
- (return (annotated [::case =variant =branches] ::&type/nothing))))
+ (return (annotated [::case $base =variant total-registers (map second =branches)] ::&type/nothing))))
(defanalyser analyse-let
[::&parser/let ?label ?value ?body]
@@ -426,9 +572,9 @@
[::&parser/ident ?name]
(exec [=value (with-scope ?name
(analyse-form* ?value))
- _ (define ?name {:mode ::constant
+ _ (define ?name {:mode ::constant
:access ::public
- :type (:type =value)})]
+ :type (:type =value)})]
(return (annotated [::def ?name =value] ::&type/nothing)))
[::&parser/fn-call [::&parser/ident ?name] ?args]
@@ -443,17 +589,18 @@
;; (into (map vector args =args)))
;; _ (prn 'env env)]
=value (with-scope ?name
- (reduce (fn [inner [label type]]
- (with-local label type inner))
- (analyse-form* ?value)
- (reverse (map vector args =args))))
+ (with-scoped-name ?name =function
+ (reduce (fn [inner [label type]]
+ (with-local label type inner))
+ (analyse-form* ?value)
+ (reverse (map vector args =args)))))
;; :let [_ (prn '=value =value)]
=function (within :types (exec [_ (&type/solve =return (:type =value))]
(&type/clean =function)))
;; :let [_ (prn '=function =function)]
- _ (define ?name {:mode ::function
+ _ (define ?name {:mode ::function
:access ::public
- :type =function})]
+ :type =function})]
(return (annotated [::def [?name args] =value] ::&type/nothing))))
))
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index 1595fe58e..e425fa0f1 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -20,7 +20,29 @@
(with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))]
(.write stream data)))
-(def ^:private +variant-class+ "test2.Tagged")
+(defn ^:private normalize-char [char]
+ (case char
+ \* "_ASTER_"
+ \+ "_PLUS_"
+ \- "_DASH_"
+ \/ "_SLASH_"
+ \_ "_UNDERS_"
+ \% "_PERCENT_"
+ \$ "_DOLLAR_"
+ \! "_BANG_"
+ \' "_QUOTE_"
+ \` "_BQUOTE_"
+ \@ "_AT_"
+ \^ "_CARET_"
+ \& "_AMPERS_"
+ \= "_EQ_"
+ ;; default
+ char))
+
+(defn ^:private normalize-ident [ident]
+ (reduce str "" (map normalize-char ident)))
+
+(def ^:private +variant-class+ "test2.Variant")
(defmacro ^:private defcompiler [name match body]
`(defn ~name [~'*state*]
@@ -28,6 +50,7 @@
~'*writer* (:writer ~'*state*)
~'*parent* (:parent ~'*state*)
~'*type* (:type (:form ~'*state*))]
+ ;; (prn '~name (:form (:form ~'*state*)))
(match (:form (:form ~'*state*))
~match
(do ~body
@@ -58,6 +81,9 @@
(defn ^:private ->java-sig [type]
(match type
+ ::&type/any
+ (->java-sig [::&type/object "java.lang.Object" []])
+
[::&type/object ?name []]
(->type-signature ?name)
@@ -143,7 +169,7 @@
(do ;; (prn 'GLOBAL ?owner-class ?name *type*)
;; (prn 'compile-global (->class (str ?owner-class "$" ?name)) "_datum")
(doto *writer*
- (.visitFieldInsn Opcodes/GETSTATIC (->class (str ?owner-class "$" ?name)) "_datum" "Ljava/lang/Object;" ;; (->java-sig *type*)
+ (.visitFieldInsn Opcodes/GETSTATIC (->class (str ?owner-class "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;" ;; (->java-sig *type*)
))))
;; (defcompiler ^:private compile-call
@@ -169,7 +195,7 @@
signature (if (> (count ?args) 1)
(str "(" (apply str counter-sig (repeat (dec num-args) clo-field-sig)) ")" "V")
(str "()" "V"))
- call-class (str (->class ?owner-class) "$" ?fn-name)]
+ call-class (str (->class ?owner-class) "$" (normalize-ident ?fn-name))]
(doto *writer*
(.visitTypeInsn Opcodes/NEW call-class)
(.visitInsn Opcodes/DUP)
@@ -220,14 +246,15 @@
(defcompiler ^:private compile-dynamic-method
[::&analyser/dynamic-method ?target ?owner ?method-name ?method-type ?args]
- (do ;; (prn 'compile-dynamic-access ?target ?owner ?method-name ?method-type ?args)
+ (do ;; (prn 'compile-dynamic-method ?target ?owner ?method-name ?method-type ?args)
;; (assert false)
(do (compile-form (assoc *state* :form ?target))
(doseq [arg ?args]
(compile-form (assoc *state* :form arg)))
(doto *writer*
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class ?owner) ?method-name (method->sig ?method-type))
- (.visitInsn Opcodes/ACONST_NULL)))
+ (.visitInsn Opcodes/ACONST_NULL)
+ ))
))
(defcompiler ^:private compile-if
@@ -235,16 +262,18 @@
(let [else-label (new Label)
end-label (new Label)]
;; (println "PRE")
- (assert (compile-form (assoc *state* :form ?test)) "CAN't COMPILE TEST")
+ (compile-form (assoc *state* :form ?test))
(doto *writer*
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Boolean") "booleanValue" "()Z")
(.visitJumpInsn Opcodes/IFEQ else-label))
;; (prn 'compile-if/?then (:form ?then))
- (assert (compile-form (assoc *state* :form ?then)) "CAN't COMPILE THEN")
+ (compile-form (assoc *state* :form ?then))
+ ;; (.visitInsn *writer* Opcodes/POP)
(doto *writer*
(.visitJumpInsn Opcodes/GOTO end-label)
(.visitLabel else-label))
- (assert (compile-form (assoc *state* :form ?else)) "CAN't COMPILE ELSE")
+ (compile-form (assoc *state* :form ?else))
+ ;; (.visitInsn *writer* Opcodes/POP)
(.visitLabel *writer* end-label)))
(defcompiler ^:private compile-do
@@ -257,34 +286,48 @@
(let [oclass (->class "java.lang.Object")
equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
(defcompiler ^:private compile-case
- [::&analyser/case ?variant ?branches]
- (do (compile-form (assoc *state* :form ?variant))
- (let [end-label (new Label)]
- (doseq [[?tag ?label ?idx ?body] ?branches]
- ;; (prn '[?tag ?label ?idx ?body] [?tag ?label ?idx ?body])
- (let [else-label (new Label)]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" "Ljava/lang/String;")
- (.visitLdcInsn ?tag)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
- (.visitJumpInsn Opcodes/IFEQ else-label))
- (let [start-label (new Label)
- end-label (new Label)]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "value" (->type-signature "java.lang.Object")))
- (.visitLocalVariable *writer* ?label (->type-signature "java.lang.Object") nil start-label end-label ?idx)
- (doto *writer*
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitLabel start-label)
- (.visitInsn Opcodes/POP))
- (compile-form (assoc *state* :form ?body))
- (.visitLabel *writer* end-label))
- (doto *writer*
- (.visitJumpInsn Opcodes/GOTO end-label)
- (.visitLabel else-label))))
- (.visitLabel *writer* end-label))
+ ;; [::&analyser/case ?variant ?branches]
+ [::&analyser/case ?base ?variant ?registers ?branches]
+ (do ;; (prn [:case ?base ?variant ?registers ?branches])
+ (match (:form ?base)
+ [::&analyser/local _ ?base-idx]
+ (let [start-label (new Label)
+ end-label (new Label)]
+ (dotimes [idx ?registers]
+ (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx idx)))
+ (.visitLabel *writer* start-label)
+ (compile-form (assoc *state* :form ?variant))
+ (.visitVarInsn *writer* Opcodes/ASTORE ?base-idx)
+ (let [variant-class* (->class +variant-class+)]
+ (doseq [?branch ?branches
+ :let [else-label (new Label)]]
+ (match ?branch
+ [::&analyser/branch-adt ?tag ?members ?body]
+ (let [tuple-class (str "test2/Tuple" (count ?members))]
+ (when (not (empty? ?members))
+ (do (doto *writer*
+ (.visitVarInsn Opcodes/ALOAD ?base-idx)
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
+ (.visitTypeInsn Opcodes/CHECKCAST tuple-class))
+ (doseq [[?tfield member] (map vector (range (count ?members)) ?members)]
+ (match member
+ [:lang.analyser/local 0 ?idx]
+ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
+ (.visitVarInsn Opcodes/ASTORE ?idx))))
+ (.visitInsn *writer* Opcodes/POP)))
+ (doto *writer*
+ (.visitVarInsn Opcodes/ALOAD ?base-idx)
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
+ (.visitLdcInsn ?tag)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
+ (.visitJumpInsn Opcodes/IFEQ else-label)
+ (do (compile-form (assoc *state* :form ?body)))
+ (.visitJumpInsn Opcodes/GOTO end-label)
+ (.visitLabel else-label))))))
+ (.visitInsn *writer* Opcodes/ACONST_NULL)
+ (.visitLabel *writer* end-label)))
)))
(defcompiler ^:private compile-let
@@ -293,7 +336,7 @@
end-label (new Label)
?idx (int ?idx)]
;; (prn '(:type ?value) (:type ?value) (->java-sig (:type ?value)))
- (.visitLocalVariable *writer* ?label (->java-sig (:type ?value)) nil start-label end-label ?idx)
+ (.visitLocalVariable *writer* (normalize-ident ?label) (->java-sig (:type ?value)) nil start-label end-label ?idx)
(assert (compile-form (assoc *state* :form ?value)) "CAN't COMPILE LET-VALUE")
(doto *writer*
(.visitVarInsn Opcodes/ASTORE ?idx)
@@ -307,7 +350,7 @@
counter-sig "I"
apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
real-signature (str "(" (apply str (repeat num-args clo-field-sig)) ")" "Ljava/lang/Object;")
- current-class (str outer-class "$" fn-name)
+ current-class (str outer-class "$" (normalize-ident fn-name))
num-captured (dec num-args)
init-signature (if (not= 0 num-captured)
(str "(" (apply str counter-sig (repeat num-captured clo-field-sig)) ")" "V")
@@ -420,7 +463,7 @@
=method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
(.visitCode))]
;; (prn 'FN/?body ?body)
- (assert (compile-form (assoc *state* :parent *writer* :writer =method :form ?body)) (str "Body couldn't compile: " (pr-str ?body)))
+ (compile-form (assoc *state* :parent *writer* :writer =method :form ?body))
(doto =method
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
@@ -605,7 +648,7 @@
(.write stream (.toByteArray =interface)))))
(defcompiler ^:private compile-variant
- [::&analyser/variant ?tag ?value]
+ [::&analyser/variant ?tag ?members]
(let [variant-class* (->class +variant-class+)]
;; (prn 'compile-variant ?tag ?value)
(doto *writer*
@@ -614,9 +657,18 @@
(.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn ?tag)
- (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" "Ljava/lang/String;")
+ (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (->type-signature "java.lang.String"))
(.visitInsn Opcodes/DUP))
- (assert (compile-form (assoc *state* :form ?value)) (pr-str "Can't compile value: " ?value))
+ (let [tuple-class (str "test2/Tuple" (count ?members))]
+ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW tuple-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))
+ (doseq [[?tfield ?member] (mapv vector (range (count ?members)) ?members)]
+ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (do (compile-form (assoc *state* :form ?member)))
+ (.visitFieldInsn Opcodes/PUTFIELD tuple-class (str "_" ?tfield) "Ljava/lang/Object;"))))
(doto *writer*
(.visitFieldInsn Opcodes/PUTFIELD variant-class* "value" "Ljava/lang/Object;"))
))
@@ -681,13 +733,15 @@
(when (not (compile-form (assoc state :form input)))
(assert false input)))
(.visitEnd =class)
- (.toByteArray =class))
-
- (comment
- (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader. (.loadClass "test2"))
- (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader. (.loadClass "test2.Function"))
- (let [test2 (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader. (.loadClass "test2"))
- main (first (.getDeclaredMethods test2))]
- (.invoke main nil (to-array [nil])))
- )
+ (let [=array (.toByteArray =class)]
+ ;; (prn 'compile class-name =array)
+ =array))
+
+ ;; (comment
+ ;; (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader. (.loadClass "test2"))
+ ;; (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader. (.loadClass "test2.Function"))
+ ;; (let [test2 (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader. (.loadClass "test2"))
+ ;; main (first (.getDeclaredMethods test2))]
+ ;; (.invoke main nil (to-array [nil])))
+ ;; )
)
diff --git a/src/lang/parser.clj b/src/lang/parser.clj
index 376e376d6..48f624ba4 100644
--- a/src/lang/parser.clj
+++ b/src/lang/parser.clj
@@ -137,10 +137,19 @@
[?member [(map ident->string ?inputs) (ident->string ?output)]]))]
(return [::definterface ?name members])))
-(defparser ^:private parse-tagged
- [::&lexer/list ([[::&lexer/tag ?tag] ?data] :seq)]
- (exec [=data (apply-m parse-form (list ?data))]
- (return [::tagged ?tag =data])))
+(defparser ^:private parse-variant
+ ?token
+ (match ?token
+ [::&lexer/tag ?tag]
+ (return [::variant ?tag '()])
+
+ [::&lexer/list ([[::&lexer/tag ?tag] & ?data] :seq)]
+ (exec [=data (map-m #(apply-m parse-form (list %))
+ ?data)]
+ (return [::variant ?tag =data]))
+
+ _
+ (fail (str "Unmatched token: " ?token))))
(defparser ^:private parse-get
[::&lexer/list ([[::&lexer/ident "get@"] [::&lexer/tag ?tag] ?record] :seq)]
@@ -191,7 +200,7 @@
parse-do
parse-case
parse-let
- parse-tagged
+ parse-variant
parse-get
parse-set
parse-remove
diff --git a/src/lang/util.clj b/src/lang/util.clj
index cdfa8555d..e2edfb550 100644
--- a/src/lang/util.clj
+++ b/src/lang/util.clj
@@ -59,14 +59,14 @@
(match (monad state)
[::ok [?state ?head]]
(do ;; (prn 'repeat-m/?state ?state)
- (match ((repeat-m monad) ?state)
- [::ok [?state* ?tail]]
- (do ;; (prn 'repeat-m/?state* ?state*)
- (return* ?state* (cons ?head ?tail)))))
+ (match ((repeat-m monad) ?state)
+ [::ok [?state* ?tail]]
+ (do ;; (prn 'repeat-m/?state* ?state*)
+ (return* ?state* (cons ?head ?tail)))))
[::failure ?message]
(do ;; (println "Failed at last:" ?message)
- (return* state '())))))
+ (return* state '())))))
(defn try-all-m [monads]
(fn [state]
@@ -89,6 +89,12 @@
outputs (map-m f (rest inputs))]
(return (conj outputs output)))))
+(defn reduce-m [f init inputs]
+ (if (empty? inputs)
+ (return init)
+ (exec [init* (f init (first inputs))]
+ (reduce-m f init* (rest inputs)))))
+
(defn apply-m [monad call-state]
(fn [state]
;; (prn 'apply-m monad call-state)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 17:02:28 +0000