diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lang.clj | 181 | ||||
| -rw-r--r-- | src/lang/analyser.clj | 169 | ||||
| -rw-r--r-- | src/lang/compiler.clj | 199 | ||||
| -rw-r--r-- | src/lang/lexer.clj | 2 | ||||
| -rw-r--r-- | src/lang/parser.clj | 7 | ||||
| -rw-r--r-- | src/lang/util.clj | 25 |
6 files changed, 316 insertions, 267 deletions
diff --git a/src/lang.clj b/src/lang.clj index 5e4316db4..0777812b7 100644 --- a/src/lang.clj +++ b/src/lang.clj @@ -16,7 +16,6 @@ ;; TODO: Adding metadata to global vars. ;; TODO: Add records. ;; TODO: throw, try, catch, finally - ;; TODO: Finish implementing pattern matching. ;; TODO: Tuple8 and Tuple8X (for arbitrary-size tuples). ;; TODO: Add extra arities (apply2, apply3, ..., apply16) ;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly. @@ -32,176 +31,24 @@ ;; _ (prn 'tokens tokens) syntax (&parser/parse tokens) ;; _ (prn 'syntax syntax) - ann-syntax (&analyser/analyse "test2" 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) + class-data (&compiler/compile "test2" syntax) ;; _ (prn 'class-data class-data) ] - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. "test2.class"))] - (.write stream class-data))) - - ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 - ) - -(comment - ;; (let [branches '([::&parser/case-branch [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "~"])] [::&parser/variant "Cons" ([::&parser/ident "unquoted"] [::&parser/variant "Nil" ()])])] [::&parser/variant "Cons" ([::&parser/ident "unquoted"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])]] - ;; [::&parser/case-branch [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "~@"])] [::&parser/variant "Cons" ([::&parser/ident "spliced"] [::&parser/variant "Nil" ()])])] [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "++"])] [::&parser/variant "Cons" ([::&parser/ident "spliced"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])])]] - ;; [::&parser/case-branch [::&parser/ident "_"] [::&parser/variant "Cons" ([::&parser/ident "head"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])]]) - ;; ;; Step 1: Get all vars - ;; get-vars (fn get-vars [pattern] - ;; (clojure.core.match/match pattern - ;; [::&parser/ident ?name] - ;; (list ?name) - - ;; [::&parser/variant ?tag ?members] - ;; (mapcat get-vars ?members) - - ;; [::&parser/string ?text] - ;; '())) - ;; vars+body (for [branch branches] - ;; (clojure.core.match/match branch - ;; [::&parser/case-branch ?pattern ?body] - ;; [(get-vars ?pattern) ?body])) - ;; ;; _ (prn 'vars+body vars+body) - ;; max-registers (reduce max 0 (map (comp count first) vars+body)) - ;; ;; _ (prn 'max-registers max-registers) - ;; ;; Step 2: Analyse bodies - ;; ;; all-analysis (map (fn [[vars body]] - ;; ;; (reduce #(with-local %2 [::&type/object "java.lang.Object" []] %1) - ;; ;; (analyse-form* body) - ;; ;; (reverse vars))) - ;; ;; vars+body) - ;; ;; Step 3: Extract bodies - ;; [_ branch-mappings branches*] (reduce (fn [[$link links branches*] branch] - ;; (clojure.core.match/match branch - ;; [::&parser/case-branch ?pattern ?body] - ;; [(inc $link) (assoc links $link ?body) (conj branches* [::&parser/case-branch ?pattern $link])])) - ;; [0 {} []] - ;; branches) - ;; ;; Step 4: Pattens -> Instructions - ;; ;; ->instructions (fn ->instructions [locals pattern] - ;; ;; (clojure.core.match/match pattern - ;; ;; [::&parser/variant ?tag ?members] - ;; ;; [::pm-variant ?tag (map (partial ->instructions locals) ?members)] - - ;; ;; [::&parser/ident ?name] - ;; ;; [::pm-local (get locals ?name)] - - ;; ;; [::&parser/string ?text] - ;; ;; [::pm-text ?text] - ;; ;; )) - ;; ;; $scope 0 ;; scope-id - ;; ;; $local 11 ;; next-local-idx - ;; ;; branches** (for [[branch branch-vars] (map vector branches* (map first vars+body)) - ;; ;; :let [[_ locals] (reduce (fn [[$local =locals] $var] - ;; ;; [(inc $local) (assoc =locals $var [::local $scope $local])]) - ;; ;; [$local {}] branch-vars)]] - ;; ;; (clojure.core.match/match branch - ;; ;; [::&parser/case-branch ?pattern ?body] - ;; ;; [(->instructions locals ?pattern) ?body])) - ;; ;; _ (prn branches**) - ;; ;; Step 5: Re-structure branching - ;; ] - ;; ;; [branch-mappings branches**] - ;; branches*) - - - + ;; (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. "test2.class"))] + ;; (.write stream class-data)) + ) + (Class/forName "test2.Variant") - ;; (let [data '([[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 0] - ;; [[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~@"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 1] - ;; [[:lang/pm-local [:lang/local 0 11]] 2]) - ;; classify-outer (fn [struct [branch $body]] - ;; (clojure.core.match/match branch - ;; [::pm-variant ?tag ?members] - ;; (update-in struct [:cases ?tag] conj {:members ?members - ;; :body $body}) - - ;; [::pm-text ?text] - ;; (update-in struct [:tests] conj {:test [::text ?text] - ;; :body $body}) - - ;; [::pm-local ?binding] - ;; (assoc struct :default {:storage ?binding - ;; :body $body}))) - ;; outer-classification (reduce classify-outer - ;; {:cases {} - ;; :tests '() - ;; :default nil} - ;; data) - ;; full-classifier (fn full-classifier [global] - ;; (prn 'full-classifier global) - ;; (let [subcases (:cases global)] - ;; (if (empty? subcases) - ;; global - ;; (let [crossed (sort (fn [x1 x2] (> (-> x1 second :cases count) (-> x2 second :cases count))) - ;; (for [[tag subs] subcases - ;; :let [_ (prn 'subcases tag subs)] - ;; :let [parts (for [cross (apply map list (map :members subs)) - ;; :let [_ (prn 'cross tag cross)] - ;; ;; :let [_ (prn '(map :body subs) (map :body subs))] - ;; ;; :let [_ (prn (class cross) (count cross) - ;; ;; (class (map :body subs)) (count (map :body subs)))] - ;; :let [cross+ (map vector cross (map :body subs))] - ;; ;; :let [_ (prn 'cross+ tag (class cross+) (count cross+))] - ;; ;; :let [_ (prn 'cross+ tag cross+)] - ;; :let [cross++ (reduce classify-outer - ;; {:cases {} - ;; :tests '() - ;; :default nil} - ;; cross+)] - ;; ;; :let [_ (prn 'cross++ tag cross++)] - ;; ] - ;; cross++)] - ;; :let [_ (prn 'parts parts)]] - ;; [tag parts])) - - ;; ] - ;; (assoc global :cases (reduce (fn [tree [tag subcases]] - ;; (update-in tree [tag] #(conj (or % []) (full-classifier subcases)))) - ;; {} - ;; crossed))))))] - ;; (full-classifier outer-classification)) + ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 ) -(comment - [{2 [:lang.parser/variant "Cons" ([:lang.parser/ident "head"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])], - 1 [:lang.parser/variant "Cons" ([:lang.parser/variant "Symbol" ([:lang.parser/string "++"])] [:lang.parser/variant "Cons" ([:lang.parser/ident "spliced"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])])], - 0 [:lang.parser/variant "Cons" ([:lang.parser/ident "unquoted"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])]} - {:type :lang/adt*, - :patterns {"Cons" ({:type :lang/adt*, - :patterns {"Symbol" ({:type :lang/text-tests, - :patterns {"~@" #{1}, - "~" #{0}}, - :defaults [], - :branches #{0 1}})}, - :default nil, - :branches #{0 1}} - {:type :lang/adt*, - :patterns {"Cons" ({:type :lang/defaults, - :stores {[:lang/local 0 11] #{0 1}}, - :branches #{0 1}} - {:type :lang/adt*, - :patterns {"Nil" ()}, - :default nil, - :branches #{0 1}})}, - :default nil, - :branches #{0 1}})}, - :default [:lang/default [:lang/local 0 11] 2], - :branches #{0 1 2}}] - - (let [data '([[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 0] - [[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~@"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 1] - [[:lang/pm-local [:lang/local 0 11]] 2]) - ] - (generate-branches data)) - - ;; (def (workday? d) - ;; (case d - ;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday] - ;; true) - ;; (or [#Saturday #Sunday] - ;; false))) - - ) +;; (def (workday? d) +;; (case d +;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday] +;; true) +;; (or [#Saturday #Sunday] +;; false))) diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj index 21117a7b7..1e2c684bb 100644 --- a/src/lang/analyser.clj +++ b/src/lang/analyser.clj @@ -5,18 +5,22 @@ [clojure.core.match :refer [match]] (lang [util :as &util :refer [exec return* return fail fail* repeat-m try-m try-all-m map-m reduce-m - apply-m within]] + apply-m within + normalize-ident + loader]] [parser :as &parser] [type :as &type]))) -(declare analyse-form) +(declare analyse-form + ->tokens + tokens->clojure) ;; [Util] (defn ^:private annotated [form type] {:form form :type type}) -(defn ^:private fresh-env [id] +(defn fresh-env [id] {:id id :counter 0 :mappings {} @@ -33,6 +37,13 @@ (assoc-in [:defs-env name] (annotated [::global (:name state) name] (:type desc)))) nil]])) +(defn ^:private is-macro? [name] + (fn [state] + (prn 'is-macro? (nth name 1) + (get-in state [:defs (:name state) (nth name 1) :mode]) + (= (get-in state [:defs (:name state) (nth name 1) :mode]) ::macro)) + [::&util/ok [state (= (get-in state [:defs (:name state) (nth name 1) :mode]) ::macro)]])) + (def ^:private next-local-idx (fn [state] [::&util/ok [state (-> state :env first :counter)]])) @@ -45,7 +56,21 @@ (fn [state] [::&util/ok [state (-> state :env first)]])) -(defn ^:private with-scope [scope body] +(defn ^:private in-scope? [scope] + (fn [state] + (match scope + [::&parser/ident ?macro-name] + (do ;; (prn 'in-scope? + ;; ?macro-name + ;; (get-in state [:lambda-scope 0]) + ;; (some (partial = ?macro-name) (get-in state [:lambda-scope 0]))) + [::&util/ok [state (some (partial = ?macro-name) (get-in state [:lambda-scope 0]))]]) + + _ + [::&util/ok [state false]]) + )) + +(defn with-scope [scope body] (fn [state] (let [=return (body (-> state (update-in [:lambda-scope 0] conj scope) @@ -237,8 +262,9 @@ [::&util/ok [?state ?value]] [::&util/ok [(assoc ?state :forms old-forms) ?value]] - _ - =return)))) + [::&util/failure ?message] + (do (prn 'analyse-form* ?message) + [::&util/failure ?message]))))) (do-template [<name> <tag> <class>] (defanalyser <name> @@ -380,15 +406,118 @@ ] (return (annotated [::dynamic-method =target =owner ?method =method =args] (&type/return-type =method))))])))) +(defn ->token [x] + (prn '->token x) + (let [variant (.newInstance (.loadClass loader "test2.Variant"))] + (match x + [::&parser/string ?text] + (doto variant + (-> .-tag (set! "Text")) + (-> .-value (set! (doto (.newInstance (.loadClass loader "test2.Tuple1")) + (-> .-_0 (set! ?text)))))) + [::&parser/ident ?ident] + (doto variant + (-> .-tag (set! "Ident")) + (-> .-value (set! (doto (.newInstance (.loadClass loader "test2.Tuple1")) + (-> .-_0 (set! ?ident)))))) + [::&parser/fn-call ?fn ?args] + (doto variant + (-> .-tag (set! "Form")) + (-> .-value (set! (doto (.newInstance (.loadClass loader "test2.Tuple1")) + (-> .-_0 (set! (->tokens (cons ?fn ?args)))))) + )) + ))) + +(defn ->tokens [xs] + (let [variant (.loadClass loader "test2.Variant") + tuple2 (.loadClass loader "test2.Tuple2")] + (reduce (fn [tail x] + ;; (prn 'tail (.-tag tail) 'x x) + (doto (.newInstance variant) + (-> .-tag (set! "Cons")) + (-> .-value (set! (doto (.newInstance tuple2) + (-> .-_0 (set! (->token x))) + (-> .-_1 (set! tail)) + ;; (-> prn) + ))) + ;; (-> prn) + )) + (doto (.newInstance variant) + (-> .-tag (set! "Nil")) + (-> .-value (set! (.newInstance (.loadClass loader "test2.Tuple0"))))) + (reverse xs)))) + +(defn ->clojure-token [x] + (prn '->clojure-token x (.-tag x)) + (case (.-tag x) + "Text" [::&parser/string (-> x .-value .-_0 (doto (-> string? assert)))] + "Ident" [::&parser/ident (-> x .-value .-_0 (doto (-> string? assert)))] + "Form" (let [[?fn & ?args] (-> x .-value .-_0 tokens->clojure)] + [::&parser/fn-call ?fn ?args]) + "Quote" [::&parser/quote (-> x .-value .-_0 ->clojure-token)])) + +(defn tokens->clojure [xs] + (prn 'tokens->clojure xs (.-tag xs)) + (case (.-tag xs) + "Nil" '() + "Cons" (let [tuple2 (.-value xs)] + (cons (->clojure-token (.-_0 tuple2)) + (tokens->clojure (.-_1 tuple2)))) + )) + +;; (defn ->clojure-tokens [xs] +;; (case (.-tag xs) +;; "Cons" (let [tuple2 (.-value xs)] +;; (cons (->clojure-token (.-_0 tuple2)) (->clojure-tokens (.-_1 tuple2)))) +;; "Nil" '())) + +(comment + (-> (->token [::&parser/string "YOLO"]) + .-value + .-_0) + + (-> (->tokens (list [::&parser/string "YOLO"])) + ;; .-tag + .-value + .-_1 + .-tag + ) + + (let [_ (prn 'loader loader) + macro (-> loader (.loadClass "test2$_QUOTE_") .newInstance) + tokens (->tokens (list [::&parser/string "YOLO"]))] + (prn macro) + (prn tokens) + (prn (.apply macro tokens)) + (prn (->clojure-token (.apply macro tokens))) + ) + + + ) + (defanalyser analyse-fn-call [::&parser/fn-call ?fn ?args] (exec [;; :let [_ (prn 'PRE '?fn ?fn)] + macro? (is-macro? ?fn) + scoped? (in-scope? ?fn) + :let [;; _ (prn 'macro? ?fn macro?) + ;; _ (prn 'scoped? scoped?) + ] =fn (analyse-form* ?fn) ;; :let [_ (prn '=fn =fn)] - =args (map-m analyse-form* ?args) ;; :let [_ (prn '=args =args)] ] - (return (annotated [::call =fn =args] [::&type/object "java.lang.Object" []])))) + (if (and macro? (not scoped?)) + (do ;; (prn "MACRO CALL!" ?fn ?args =fn) + (let [macro (match (:form =fn) + [::global ?module ?name] + (.newInstance (.loadClass loader (str ?module "$" (normalize-ident ?name))))) + output (->clojure-token (.apply macro (->tokens ?args)))] + (prn "MACRO CALL!" macro output) + (analyse-form* output))) + (exec [=args (map-m analyse-form* ?args)] + (return (annotated [::call =fn =args] [::&type/object "java.lang.Object" []])))) + )) (defanalyser analyse-if [::&parser/if ?test ?then ?else] @@ -630,6 +759,20 @@ (return (annotated [::def [?name args] =value] ::&type/nothing)))) )) +(defanalyser analyse-defmacro + [::&parser/defmacro [::&parser/fn-call [::&parser/ident ?name] ([[::&parser/ident ?tokens]] :seq)] ?value] + (exec [[=function =tokens =return] (within :types (&type/fresh-function 1)) + =value (with-scope ?name + (with-scoped-name ?name =function + (with-local ?tokens =tokens + (analyse-form* ?value)))) + =function (within :types (exec [_ (&type/solve =return (:type =value))] + (&type/clean =function))) + _ (define ?name {:mode ::macro + :access ::public + :type =function})] + (return (annotated [::def [?name (list ?tokens)] =value] ::&type/nothing)))) + (defanalyser analyse-lambda [::&parser/lambda ?args ?body] (exec [;; :let [_ (prn 'analyse-lambda ?args ?body)] @@ -661,7 +804,11 @@ (exec [_ (require-module module-name ?alias)] (return (annotated [::require ?file ?alias] ::&type/nothing))))) -(def ^:private analyse-form +(defanalyser analyse-quote + [::&parser/quote ?quoted] + (return (annotated [::quote ?quoted] ::&type/nothing))) + +(def analyse-form (try-all-m [analyse-boolean analyse-int analyse-float @@ -680,8 +827,10 @@ analyse-defclass analyse-definterface analyse-def + analyse-defmacro analyse-import - analyse-require])) + analyse-require + analyse-quote])) ;; [Interface] (defn analyse [module-name tokens] diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj index 2ead6daec..113cb2fed 100644 --- a/src/lang/compiler.clj +++ b/src/lang/compiler.clj @@ -3,7 +3,12 @@ (:require [clojure.string :as string] [clojure.set :as set] [clojure.core.match :refer [match]] - (lang [type :as &type] + (lang [util :as &util :refer [exec return* return fail fail* + repeat-m try-m try-all-m map-m reduce-m + apply-m within + normalize-ident + loader]] + [type :as &type] [lexer :as &lexer] [parser :as &parser] [analyser :as &analyser]) @@ -18,30 +23,22 @@ ;; [Utils/General] (defn ^:private write-file [file data] + (println 'write-file file (alength data)) (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] - (.write stream data))) - -(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))) + (.write stream data)) + ;; (Thread/sleep 2000) + ) + +(let [;; loader (proxy [ClassLoader] []) + ] + (defn load-class! [name file-name] + (println "Defining..." name "@" file-name ;; (alength bytecode) + ) + ;; (prn 'loader loader) + (.loadClass loader name) + (println "SUCCESFUL LOAD!") + ;; (.defineClass loader name bytecode 0 (alength bytecode)) + )) (def ^:private +variant-class+ "test2.Variant") @@ -290,7 +287,7 @@ +tuple-field-sig+ (->type-signature "java.lang.Object") equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] (defn compile-decision-tree [writer mappings cleanup-level next-label default-label decision-tree] - (prn 'compile-decision-tree cleanup-level decision-tree) + ;; (prn 'compile-decision-tree cleanup-level decision-tree) (match decision-tree [::test-text ?text $body] (let [$else (new Label)] @@ -326,7 +323,8 @@ (.visitInsn Opcodes/POP) ;; variant (do (let [arity (-> ?subcases first (nth 2) count) tuple-class (str "test2/Tuple" arity) - _ (prn ?tag arity tuple-class)] + ;; _ (prn ?tag arity tuple-class) + ] (when (> arity 0) (doto writer (.visitInsn Opcodes/DUP) ;; variant, variant @@ -355,48 +353,15 @@ ;; variant, tag -> (.visitLabel tag-else-label)) (->> (doseq [[?tag ?subcases] ?cases - :let [_ (.print System/out (prn-str 'COMPILE-PATTERN ?tag ?subcases))] + ;; :let [_ (.print System/out (prn-str 'COMPILE-PATTERN ?tag ?subcases))] :let [tag-else-label (new Label)]]))) (-> (doto (.visitInsn Opcodes/POP)) (->> (dotimes [_ (+ cleanup-level 2)]))) (.visitJumpInsn Opcodes/GOTO default-label))) )) -;; ([:lang.compiler/subcase 0 ([:lang.compiler/test-adt #{0} {"Symbol" ()}] -;; [:lang.compiler/test-adt #{0} {"Nil" ([:lang.compiler/subcase 0 ()])}])] -;; [:lang.compiler/subcase 0 ([:lang.compiler/test-adt #{0} {"Symbol" ()}] -;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])] -;; [:lang.compiler/subcase 0 ([:lang.compiler/store [:lang.analyser/local 0 1] 0] -;; [:lang.compiler/test-adt #{0} {"Nil" ([:lang.compiler/subcase 0 ()])}])] -;; [:lang.compiler/subcase 0 ([:lang.compiler/store [:lang.analyser/local 0 1] 0] -;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])] -;; [:lang.compiler/subcase 1 ([:lang.compiler/test-adt #{1} {"Symbol" ([:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 1])])}] -;; [:lang.compiler/test-adt #{1} {"Nil" ()}])] -;; [:lang.compiler/subcase 1 ([:lang.compiler/test-adt #{1} {"Symbol" ([:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 1])])}] -;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])] -;; [:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 0] -;; [:lang.compiler/test-adt #{0} {"Nil" ([:lang.compiler/subcase 0 ()])}])] -;; [:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 0] -;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])]) - -;; ({:type :lang.analyser/adt*, -;; :patterns {"Cons" {:parts ({:type :lang.analyser/adt*, -;; :patterns {"Symbol" {:parts ({:type :lang.analyser/defaults, -;; :stores {[:lang.analyser/local 0 1] #{1}}, -;; :branches #{1}}), -;; :branches #{1}}}, -;; :default [:lang.analyser/default [:lang.analyser/local 0 1] 0], -;; :branches #{0 1}} -;; {:type :lang.analyser/adt*, -;; :patterns {"Nil" {:parts (), :branches #{0}}}, -;; :default [:lang.analyser/default [:lang.analyser/local 0 2] 1], -;; :branches #{0 1}}), -;; :branches #{0 1}}}, -;; :default nil, -;; :branches #{0 1}}) - (defn sequence-parts [branches parts] - (.print System/out (prn-str 'sequence-parts branches parts)) + ;; (.print System/out (prn-str 'sequence-parts branches parts)) (if (empty? parts) '(()) (let [[head & tail] parts @@ -422,14 +387,14 @@ (do ;; (prn '(:default head) (:default head)) ;; (assert (nil? (:default head))) (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) - :let [_ (.print System/out (prn-str 'PATTERN ?tag ?struct))] + ;; :let [_ (.print System/out (prn-str 'PATTERN ?tag ?struct))] :let [?parts (:parts ?struct) num-parts (count ?parts) ?supports (:branches ?struct) subcases (for [?body (set/intersection branches ?supports) subseq (sequence-parts #{?body} ?parts) - :let [_ (when (= "Symbol" ?tag) - (.print System/out (prn-str 'counting ?tag num-parts (count subseq) subseq)))] + ;; :let [_ (when (= "Symbol" ?tag) + ;; (.print System/out (prn-str 'counting ?tag num-parts (count subseq) subseq)))] :when (= num-parts (count subseq))] [::subcase ?body subseq])] :when (not (empty? subcases))] @@ -593,8 +558,10 @@ (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd))) - _ (.visitEnd =class)] - (write-file (str current-class ".class") (.toByteArray =class))) + _ (.visitEnd =class) + bytecode (.toByteArray =class)] + (write-file (str current-class ".class") bytecode) + (load-class! (string/replace current-class #"/" ".") (str current-class ".class"))) )) (defn compile-field [writer class-name ?name body state] @@ -614,8 +581,10 @@ (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))) - (.visitEnd))] - (write-file (str current-class ".class") (.toByteArray =class))) + (.visitEnd)) + bytecode (.toByteArray =class)] + (write-file (str current-class ".class") bytecode) + (load-class! (string/replace current-class #"/" ".") (str current-class ".class"))) )) (defcompiler ^:private compile-def @@ -757,8 +726,10 @@ (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd)) - _ (.visitEnd =class)] - (write-file (str current-class ".class") (.toByteArray =class)) + _ (.visitEnd =class) + bytecode (.toByteArray =class)] + (write-file (str current-class ".class") bytecode) + (load-class! (string/replace current-class #"/" ".") (str current-class ".class")) ;; (apply prn 'LAMBDA ?scope ?args (->> (:mappings ?frame) ;; (map second) ;; (map :form) @@ -797,8 +768,8 @@ (.visitEnd)) (.visitEnd =class) (.mkdirs (java.io.File. parent-dir)) - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))] - (.write stream (.toByteArray =class))))) + (write-file (str parent-dir "/" ?name ".class") (.toByteArray =class)) + (load-class! (string/replace (str parent-dir "/" ?name) #"/" ".") (str parent-dir "/" ?name ".class")))) (defcompiler ^:private compile-definterface [::&analyser/definterface [?package ?name] ?members] @@ -813,8 +784,8 @@ (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) (.visitEnd =interface) (.mkdirs (java.io.File. parent-dir)) - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))] - (.write stream (.toByteArray =interface))))) + (write-file (str parent-dir "/" ?name ".class") (.toByteArray =interface)) + (load-class! (string/replace (str parent-dir "/" ?name) #"/" ".") (str parent-dir "/" ?name ".class")))) (defcompiler ^:private compile-variant [::&analyser/variant ?tag ?members] @@ -856,12 +827,40 @@ ;; _ (prn 'tokens tokens) syntax (&parser/parse tokens) ;; _ (prn 'syntax syntax) - ann-syntax (&analyser/analyse module-name syntax) + ;; ann-syntax (&analyser/analyse module-name syntax) ;; _ (prn 'ann-syntax ann-syntax) - class-data (compile module-name ann-syntax)] - (write-file (str module-name ".class") class-data) + bytecode (compile module-name syntax)] + ;; (write-file (str module-name ".class") bytecode) + ;; (load-class! (string/replace module-name #"/" ".") (str module-name ".class")) nil)) +(defn quoted->token [quoted] + (prn 'quoted->token quoted) + (match quoted + [::&parser/string ?text] + {:form [::&analyser/variant "Text" (list {:form [::&analyser/literal ?text] + :type [::&type/object "java.lang.String" []]})] + :type [::&type/variant "Text" (list [::&type/object "java.lang.String" []])]} + + [::&parser/fn-call ?fn ?args] + (let [members* (quoted->token (cons ?fn ?args))] + {:form [::&analyser/variant "Form" (list members*)] + :type [::&type/variant "Form" (list (:type members*))]}) + + ([] :seq) + {:form [::&analyser/variant "Nil" '()] + :type [::&type/variant "Nil" '()]} + + ([head & tail] :seq) + (let [head* (quoted->token head) + tail* (quoted->token tail)] + {:form [::&analyser/variant "Cons" (list head* tail*)] + :type [::&type/variant "Nil" (list (:type head*) (:type tail*))]}))) + +(defcompiler compile-quote + [::&analyser/quote ?quoted] + (compile-form (assoc *state* :form (quoted->token ?quoted)))) + (let [+compilers+ [compile-literal compile-variant compile-tuple @@ -882,7 +881,8 @@ compile-defclass compile-definterface compile-import - compile-require]] + compile-require + compile-quote]] (defn ^:private compile-form [state] ;; (prn 'compile-form/state state) (or (some #(% state) +compilers+) @@ -894,18 +894,39 @@ (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (->class class-name) nil "java/lang/Object" nil)) - state {:class-name class-name - :writer =class - :form nil - :parent nil}] - (doseq [input inputs] - (when (not (compile-form (assoc state :form input))) - (assert false input))) + compiler-state {:class-name class-name + :writer =class + :form nil + :parent nil}] + (match ((repeat-m + (&analyser/with-scope class-name + (exec [ann-input &analyser/analyse-form + :let [_ (when (not (compile-form (assoc compiler-state :form ann-input))) + (assert false ann-input))]] + (return ann-input)))) + {:name class-name + :forms inputs + :deps {} + :imports {} + :defs {} + :defs-env {} + :lambda-scope [[] 0] + :env (list (&analyser/fresh-env 0)) + :types &type/+init+}) + [::&util/ok [?state ?forms]] + (if (empty? (:forms ?state)) + ?forms + (assert false (str "Unconsumed input: " (pr-str (:forms ?state))))) + + [::&util/failure ?message] + (assert false ?message)) + ;;; (.visitEnd =class) - (let [=array (.toByteArray =class)] - ;; (prn 'compile class-name =array) - =array)) - + (let [bytecode (.toByteArray =class)] + (write-file (str class-name ".class") bytecode) + (load-class! (string/replace class-name #"/" ".") (str class-name ".class")) + bytecode) + ) ;; (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")) diff --git a/src/lang/lexer.clj b/src/lang/lexer.clj index 870209503..9fa533dc5 100644 --- a/src/lang/lexer.clj +++ b/src/lang/lexer.clj @@ -52,7 +52,7 @@ ;; [Lexers] (def ^:private lex-white-space (lex-regex #"^(\s+)")) -(def +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':]*)") +(def +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~]*)") (do-template [<name> <tag> <regex>] (def <name> diff --git a/src/lang/parser.clj b/src/lang/parser.clj index 48f624ba4..34f3e70b4 100644 --- a/src/lang/parser.clj +++ b/src/lang/parser.clj @@ -71,6 +71,12 @@ =body (apply-m parse-form (list ?body))] (return [::def =name =body]))) +(defparser ^:private parse-defmacro + [::&lexer/list ([[::&lexer/ident "defmacro"] ?name ?body] :seq)] + (exec [=name (apply-m parse-form (list ?name)) + =body (apply-m parse-form (list ?body))] + (return [::defmacro =name =body]))) + (defparser ^:private parse-defdata [::&lexer/list ([[::&lexer/ident "defdata"] ?type & ?cases] :seq)] (exec [=type (apply-m parse-form (list ?type)) @@ -195,6 +201,7 @@ parse-record parse-lambda parse-def + parse-defmacro parse-defdata parse-if parse-do diff --git a/src/lang/util.clj b/src/lang/util.clj index e2edfb550..7eb431033 100644 --- a/src/lang/util.clj +++ b/src/lang/util.clj @@ -132,3 +132,28 @@ [::ok [(assoc state slot ?state) ?value]] _ =return)))) + +(defn ^:private normalize-char [char] + (case char + \* "_ASTER_" + \+ "_PLUS_" + \- "_DASH_" + \/ "_SLASH_" + \_ "_UNDERS_" + \% "_PERCENT_" + \$ "_DOLLAR_" + \! "_BANG_" + \' "_QUOTE_" + \` "_BQUOTE_" + \@ "_AT_" + \^ "_CARET_" + \& "_AMPERS_" + \= "_EQ_" + ;; default + char)) + +(defn normalize-ident [ident] + (reduce str "" (map normalize-char ident))) + +(defonce loader (doto (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader.) + (->> (prn 'loader)))) |