diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lang.clj | 273 | ||||
| -rw-r--r-- | src/lang/analyser.clj | 211 | ||||
| -rw-r--r-- | src/lang/compiler.clj | 156 | ||||
| -rw-r--r-- | src/lang/parser.clj | 19 | ||||
| -rw-r--r-- | src/lang/util.clj | 16 | ||||
| -rw-r--r-- | test2.lang | 94 |
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")))) + )# |