aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2014-12-26 01:00:30 -0400
committerEduardo Julian2014-12-26 01:00:30 -0400
commit0a0300b129df4499782cbe47aeaee581f57cc3db (patch)
treed7f3fd5f5cecb5b7a7a8703516e98624b5901039
parent4dc96027d8e90734aea3a5e109b8786fc112e88b (diff)
Reimplemented basic pattern-matching.
Diffstat (limited to '')
-rw-r--r--src/lang.clj273
-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
-rw-r--r--test2.lang94
6 files changed, 639 insertions, 130 deletions
diff --git a/src/lang.clj b/src/lang.clj
index 16e76f6e5..4dd8e159c 100644
--- a/src/lang.clj
+++ b/src/lang.clj
@@ -8,6 +8,7 @@
(defn write-file [file data]
(with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))]
+ ;; (prn 'write-file 'file file 'stream stream 'data data)
(.write stream data)))
(comment
@@ -25,7 +26,33 @@
;; TODO: Add extra arities (apply2, apply3, ..., apply16)
;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly.
;; TODO: Add "new". Allow setting fields.
+ ;; TODO: Don't take into account newlines in strings unless they come from \n to allow better coding.
;; TODO:
+ ;; TODO:
+ ;; TODO:
+ ;; TODO:
+
+ (let [test '([:lang.parser/case-branch [:lang.parser/variant "Nil" ()]
+ [:lang.parser/ident "yx"]]
+ [:lang.parser/case-branch [:lang.parser/variant "Cons" ([:lang.parser/ident "x"] [:lang.parser/ident "xs*"])]
+ [:lang.parser/variant "Cons" ([:lang.parser/ident "x"] [:lang.parser/fn-call [:lang.parser/ident "++"] ([:lang.parser/ident "xs*"] [:lang.parser/ident "ys"])])]])
+ convert (fn [cases]
+ (list (reduce (fn [acc [_ shape body]]
+ (clojure.core.match/match shape
+ [::&parser/variant ?tag ?elems]
+ (let [=elems (map (fn [elem]
+ (clojure.core.match/match elem
+ [::&parser/ident ?ident]
+ [::ident ?ident]))
+ ?elems)]
+ (conj acc [?tag =elems body]))))
+ []
+ cases)))]
+ (convert test))
+
+ (enumerate (list (list '["Nil" [] branch-0]
+ '["Cons" [x xs*] branch-1])))
+
(let [source-code (slurp "test2.lang")
tokens (&lexer/lex source-code)
@@ -34,8 +61,252 @@
;; _ (prn 'syntax syntax)
ann-syntax (&analyser/analyse "test2" syntax)
;; _ (prn 'ann-syntax ann-syntax)
- class-data (&compiler/compile "test2" ann-syntax)]
+ class-data (&compiler/compile "test2" ann-syntax)
+ ;; _ (prn 'class-data class-data)
+ ]
(write-file "test2.class" class-data))
;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
)
+
+(comment
+
+ (let [data '([::&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"])])]])
+ ;; count-registers (fn count-registers [pattern]
+ ;; (clojure.core.match/match pattern
+ ;; [::&parser/ident _]
+ ;; 0
+
+ ;; [::&parser/variant _ ?members]
+ ;; (reduce + (count ?members) (map count-registers ?members))))
+ 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 {}}}
+ data))
+
+ '([::&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"])])]])
+
+ '([:try "Nil" []]
+ [:try "Cons" [[:bind 0 1] [:bind 1 2]]])
+
+ (list '["Nil" [] branch-0]
+ '["Cons" [x xs*] branch-1])
+
+ [:if [% tag "Nil"]
+ branch-0
+ [:let [%0 %1]
+ branch-1]]
+
+ (let [enumerate (fn [xs] (map vector (range (count xs)) xs))
+ cases (enumerate (list (list '["Nil" [] branch-0]
+ '["Cons" [x xs*] branch-1])))
+ classify-cases (fn [[idx cases]]
+ [idx (reduce (fn [order [tag members branch]]
+ (if-let [{:keys [arity branches] :as sub-struct} (get order tag)]
+ (if (= arity (count members))
+ (update-in order [tag :branches] conj [members branch])
+ (assert (str "Arity doesn't match:" (count members) " != " arity)))
+ (assoc order tag {:arity (count members)
+ :branches (vector [members branch])})))
+ {}
+ cases)])
+ ;; case->struct (fn [cases]
+ ;; (let [struct (classify-case cases)
+ ;; struct* (seq struct)]
+ ;; (reduce (fn [inner [tag {:keys [arity branches]}]]
+ ;; [:if [% tag "Nil"]
+ ;; branch-0
+ ;; inner])
+ ;; (second (last struct*))
+ ;; (butlast struct*))
+ ;; ))
+ ]
+ ;; (classify-case cases)
+ (let [;; separated (apply map list cases)
+ classifications (map classify-cases cases)
+ classifications* (sort-by first > classifications)]
+ ((fn [[idx struct]]
+ (prn idx struct)
+ (if-let [default (get struct nil)]
+ (reduce (fn [[dbinds dbranch] [tag [binds branch]]]
+ [:if tag
+ [:let binds
+ branch]
+ [:let dbinds
+ dbranch]])
+ (-> default :branches first)
+ (seq struct))
+ (let [struct* (seq struct)]
+ (reduce (fn [[dbinds dbranch] [tag sub-struct]]
+ (let [[binds branch] (-> sub-struct :branches first)]
+ [:if tag
+ [:let binds
+ branch]
+ [:let dbinds
+ dbranch]]))
+ (-> struct* last second :branches first)
+ (butlast struct*)))))
+ (first classifications*))
+ ))
+
+ ;; ([0 {"Cons" {:arity 2, :branches [[[x xs*] branch-1]]}, "Nil" {:arity 0, :branches [[[] branch-0]]}}])
+
+
+ ;; {"Cons" {:arity 2, :branches [[[x xs*] branch-1]]},
+ ;; "Nil" {:arity 0, :branches [[[] branch-0]]}}
+
+
+ ;; .........................
+
+ ;; (case elems
+ ;; #Nil
+ ;; elems
+
+ ;; (#Cons head tail)
+ ;; (case head
+ ;; (#Cons (#Symbol "~") (#Cons unquoted #Nil))
+ ;; (#Cons unquoted (template tail))
+
+ ;; (#Cons (#Symbol "~@") (#Cons spliced #Nil))
+ ;; (#Cons (#Symbol "++") (#Cons spliced (template tail)))
+
+ ;; _
+ ;; (#Cons head (template tail)))
+ ;; )
+
+ ;; Total registers: 3
+ ;; [{:tag "Nil" :data [] :path path-1}
+ ;; {:tag "Cons" :data [[:bind head] [:bind tail]] :path path-2}]
+
+ ;; {path-0 [:branch "Nil" []]
+ ;; path-1 [:branch "Cons" [[:bind head] [:bind tail]]]}
+
+ ;; Total registers: 6
+ ;; {path-0 [:branch "Cons" [[:adt "Symbol" [[:string-cmp "~"]]] [:adt "Cons" [[:bind unquoted] [:adt "Nil" []]]]]]
+ ;; path-1 [:branch "Cons" [[:adt "Symbol" [[:string-cmp "~@"]]] [:adt "Cons" [[:bind spliced] [:adt "Nil" []]]]]]
+ ;; path-2 [:default _]}
+
+ ;; {"#default#" [:default path-2 _]
+ ;; "Cons" [:branches [path-0 path-1]
+ ;; [[[:adt "Symbol" [[:string-cmp "~"]]] [:adt "Cons" [[:bind unquoted] [:adt "Nil" []]]]]
+ ;; [[:adt "Symbol" [[:string-cmp "~@"]]] [:adt "Cons" [[:bind spliced] [:adt "Nil" []]]]]]]}
+
+ ;; [:branches]
+
+
+ ;; (case elems
+ ;; #Nil
+ ;; elems
+
+ ;; (#Cons (list (' ~) unquoted) tail)
+ ;; (list* unquoted (template tail))
+
+ ;; (#Cons (list (' ~@) spliced) tail)
+ ;; (list* "++" spliced (template tail))
+
+ ;; _
+ ;; (#Cons head (template tail))
+ ;; )
+
+ ;; [{:tag "Nil" :data [] :path path-1}
+ ;; {:tag "Cons" :data [[:bind head] [:bind tail]] :path path-2}]
+
+ ;; [[{:tag "Cons" :data [%0 %1] :path nil
+ ;; :sub-cases [[{:tag "Symbol" :data [[:string-cmp "~"]] :path path-1}
+ ;; {:tag "Symbol" :data [[:string-cmp "~@"]] :path path-2}]
+ ;; [{:tag "Cons" :data [[:bind unquoted] {:tag "Nil" :data []}] :path path-1}
+ ;; {:tag "Cons" :data [[:bind spliced] {:tag "Nil" :data []}] :path path-2}]]}
+ ;; {:tag ::default :path path-3}]]
+
+ ;; [[["Cons" ["Symbol" "~"] ["Cons" unquoted ["Nil"]]]
+ ;; ["Cons" ["Symbol" "~@"] ["Cons" spliced ["Nil"]]]
+ ;; _]]
+
+ ;; [[["Symbol" "~"]
+ ;; ["Symbol" "~@"]]
+ ;; [["Cons" unquoted ["Nil"]]
+ ;; ["Cons" spliced ["Nil"]]]]
+
+ ;; (if (= "Cons" (:: % tag))
+ ;; (let [%0 (:: % _0)
+ ;; %1 (:: % _1)]
+ ;; (if (= "Symbol" (:: %0 tag))
+ ;; (let [%0|0 (:: %0 _0)]
+ ;; (if (= "~" %0|0)
+ ;; (if (= "Cons" (:: %1 tag))
+ ;; (let [%1|0 (:: %1 _0)
+ ;; %1|1 (:: %1 _1)]
+ ;; (if (= "Nil" (:: %1|1 tag))
+ ;; (let [unquoted %1|0]
+ ;; <path-1>)
+ ;; <path-3>))
+ ;; <path-3>)
+ ;; (if (= "@~" %0|0)
+ ;; (if (= "Cons" (:: %1 tag))
+ ;; (let [%1|0 (:: %1 _0)
+ ;; %1|1 (:: %1 _1)]
+ ;; (if (= "Nil" (:: %1|1 tag))
+ ;; (let [unquoted %1|0]
+ ;; <path-2>)
+ ;; <path-3>))
+ ;; <path-3>)
+ ;; <path-3>)))
+ ;; <path-3>))
+ ;; <path-3>)
+
+
+
+ ;; (list (list '["Nil" [] ...]
+ ;; '["Cons" [head tail] ...]))
+
+ ;; (list (list '["Cons" [["Symbol" ["~"]] ["Cons" [unquoted ["Nil" []]]]] ...]
+ ;; '["Cons" [["Symbol" ["~@"]] ["Cons" [spliced ["Nil" []]]]] ...]))
+ )
+
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)
diff --git a/test2.lang b/test2.lang
index a7892945f..cbce36ce8 100644
--- a/test2.lang
+++ b/test2.lang
@@ -1,7 +1,5 @@
(import java.lang.System)
-(require "./another" as another)
-
-(defclass Tagged [[java.lang.String tag] [java.lang.Object value]])
+## (require "./another" as another)
(definterface Function
(: apply (-> [java.lang.Object] java.lang.Object)))
@@ -10,43 +8,67 @@
(defclass Tuple1 [[java.lang.Object _0]])
(defclass Tuple2 [[java.lang.Object _0] [java.lang.Object _1]])
-(def const "IDENTITY")
-
-(def variant (#Tag "value"))
+(defclass Variant [[java.lang.String tag] [java.lang.Object value]])
-(def (constant x y)
- x)
+#( (def (++ xs ys)
+ (case xs
+ #Nil
+ ys
-(def (constant2 x)
- (lambda [y] x))
+ (#Cons x xs*)
+ (#Cons x (++ xs* ys)))) )#
(def (main args)
(if true
- (let f (lambda [x] (lambda [y] (x y)))
- (let g (lambda [x] const)
- (:: (:: System out) (println (f g "WE'VE GOT CLOSURES!")))))
+ (let variant (#Pair "Pattern" "Matching")
+ (case variant
+ (#Pair first second)
+ (do (:: (:: System out) (println first))
+ (:: (:: System out) (println second)))))
(:: (:: System out) (println "FALSE"))))
-## All of these work :D
-#( (let output "IT WORKS!"
- (_. (_.. System out) (println ((lambda [x y] output) "TRUE" "YOLO")))) )#
-#( (let output "IT WORKS!"
- (let f (lambda [x] (lambda [y] output))
- (_. (_.. System out) (println (f "TRUE" "YOLO"))))) )#
-#( (let output "IT WORKS!"
- (_. (_.. System out) (println ((lambda [x] (lambda [y] output)) "TRUE" "YOLO")))) )#
-#( (let output ((lambda [x y] x) "TRUE" "YOLO")
- (_. (_.. System out) (println output))) )#
-#( (let f (lambda [x y] x)
- (_. (_.. System out) (println (f "TRUE" "YOLO")))) )#
-## ((lambda [x y] (_. (_.. System out) (println x))) "TRUE" "YOLO")
-## (_. (_.. System out) (println ((lambda [x y] x) "TRUE" "YOLO")))
-#( (do (_. (_.. System out) (println true))
- (_. (_.. System out) (println (another/id 12345)))
- (_. (_.. System out) (println (constant "ONE" "TWO")))
- (_. (_.. System out) (println 2.3))
- (_. (_.. System out) (println #"Y"))
- (_. (_.. System out) (println "this\tis a\nstring"))
- (case (#Box "data")
- (#Box value)
- (_. (_.. System out) (println value)))) )#
+#( (def (template elems)
+ (case elems
+ #Nil
+ elems
+
+ (#Cons head tail)
+ (case head
+ (#Cons (#Symbol "~") (#Cons unquoted #Nil))
+ (#Cons unquoted (template tail))
+
+ (#Cons (#Symbol "~@") (#Cons spliced #Nil))
+ (#Cons (#Symbol "++") (#Cons spliced (template tail)))
+
+ _
+ (#Cons head (template tail)))
+ ))
+
+ (defmacro (' form)
+ (case form
+ (#Cons form* #Nil)
+ (case form*
+ (#Form elems)
+ (#Quote (#Form (template elems)))
+
+ _
+ (#Quote form*))
+ ))
+
+ (defmacro (::+ pieces)
+ (case pieces
+ (#Cons init #Nil)
+ init
+
+ (#Cons init (#Cons access others))
+ (' (::+ (:: (~ init) (~ access)) (~@ others)))
+ ))
+
+ (def (main args)
+ (if true
+ (let f (lambda [x] (lambda [y] (x y)))
+ (let g (lambda [x] const)
+ (::+ System out (println (f g "WE'VE GOT CLOSURES!")))
+ ## (:: (:: System out) (println (f g "WE'VE GOT CLOSURES!")))))
+ (:: (:: System out) (println "FALSE"))))
+ )#