diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/example/test1.lux | 38 | ||||
-rw-r--r-- | src/lux.clj | 3 | ||||
-rw-r--r-- | src/lux/analyser.clj | 294 | ||||
-rw-r--r-- | src/lux/compiler.clj | 423 | ||||
-rw-r--r-- | src/lux/lexer.clj | 32 | ||||
-rw-r--r-- | src/lux/parser.clj | 16 |
6 files changed, 202 insertions, 604 deletions
diff --git a/src/example/test1.lux b/src/example/test1.lux deleted file mode 100644 index 8e740eabd..000000000 --- a/src/example/test1.lux +++ /dev/null @@ -1,38 +0,0 @@ - -(* 5 6) - -## My first function definition! -(def (repeat n val) - (if (<=' n 0) - (#Nil []) - (#Cons [val (repeat (-' n 1) val)]))) - -## Testing one, two, three... -(repeat 5 5) - -(def (fold f init inputs) - (case inputs - #( Outer comment #( Inner comment )# )# - (#Nil []) init - (#Cons [head tail]) (fold f (f init head) tail))) - -## It's alive! -(fold * 1 (repeat 5 5)) - -3.14 - -(def pi 3.14) - -pi - -(def (foo x) - (let [y (*' 2 x)] - (+' x y))) - -(foo 10) - -(def bar {#x 10 #y 20}) -bar -(get@ #x bar) -(set@ #z 30 bar) -(remove@ #y bar) diff --git a/src/lux.clj b/src/lux.clj index dca7034c3..7553e1845 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -22,8 +22,9 @@ ;; TODO: Add "new". Allow setting fields. ;; TODO: monitor enter & monitor exit. ;; TODO: Reinplement "if" as a macro on top of case. + ;; TODO: Remember to optimized calling global functions. ;; TODO: - + (&compiler/compile-all ["lux" "test2"]) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 179d2089e..ce84c7310 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -46,12 +46,6 @@ (defn ^:private is-macro? [module 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)) - ;; (prn 'is-macro? name (get-in state [:modules module name :mode]) - ;; (get-in state [:modules module]) - ;; (get-in state [:modules])) [::&util/ok [state (= (get-in state [:modules module name :mode]) ::macro)]])) (def ^:private next-local-idx @@ -68,12 +62,7 @@ (defn ^:private in-scope? [module name] (fn [state] - (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 = name) (get-in state [:lambda-scope 0]))]]) - )) + [::&util/ok [state (some (partial = name) (get-in state [:lambda-scope 0]))]])) (defn with-scope [scope body] (fn [state] @@ -103,17 +92,14 @@ (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])) - =return (body (-> state + (let [=return (body (-> state (update-in [:lambda-scope 0] conj (get-in state [:lambda-scope 1])) (assoc-in [:lambda-scope 1] 0)))] (match =return [::&util/ok [?state ?value]] - [::&util/ok [(do ;; (prn [:lambda-scope 0] (get-in ?state [:lambda-scope 0])) - ;; (prn [:lambda-scope 1] (get-in ?state [:lambda-scope 1])) - (-> ?state - (update-in [:lambda-scope 0] pop) - (assoc-in [:lambda-scope 1] (inc (get-in state [:lambda-scope 1]))))) + [::&util/ok [(-> ?state + (update-in [:lambda-scope 0] pop) + (assoc-in [:lambda-scope 1] (inc (get-in state [:lambda-scope 1])))) ?value]] _ @@ -130,18 +116,13 @@ (update-in [:counter] inc) (assoc-in [:mappings name] (annotated [::local (:id (first %)) (:counter (first %))] type))) (rest %))))] - ;; =return (match =return [::&util/ok [?state ?value]] - (do ;; (prn 'POST-WITH-LOCAL name (-> ?state :env first)) - [::&util/ok [(update-in ?state [:env] #(cons (-> (first %) - (update-in [:counter] dec) - (update-in [:mappings] dissoc name)) - (rest %))) - ;; (update-in ?state [:env] (fn [[top & oframes]] - ;; (prn 'NEW-FRAMES name (cons (-> state :env first (assoc :closure (-> top :closure))) oframes)) - ;; (cons (-> state :env first (assoc :closure (-> top :closure))) oframes))) - ?value]]) + [::&util/ok [(update-in ?state [:env] #(cons (-> (first %) + (update-in [:counter] dec) + (update-in [:mappings] dissoc name)) + (rest %))) + ?value]] _ =return) @@ -153,10 +134,9 @@ (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 %) [:mappings] (fn [m] (apply dissoc m (keys mappings)))) - (rest %))) - ?value]]) + [::&util/ok [(update-in ?state [:env] #(cons (update-in (first %) [:mappings] (fn [m] (apply dissoc m (keys mappings)))) + (rest %))) + ?value]] _ =return)))) @@ -164,7 +144,6 @@ (defn ^:private with-fresh-env [[args-vars args-types] body] (with-lambda-scope (fn [state] - ;; (prn '(:env state) (:env state) (-> state :env first :id inc)) (let [state* (update-in state [:env] (fn [outer] (let [frame-id (-> outer first :id inc) @@ -175,22 +154,13 @@ (update-in (fresh-env frame-id) [:counter] inc) (map vector args-vars args-types))] (conj outer new-top)))) - =return (body state*) - ;; _ (prn '=return =return) - ] + =return (body state*)] (match =return [::&util/ok [?state ?value]] - (do ;; (prn 'PRE-LAMBDA (:env state)) - ;; (prn 'POST-LAMBDA (:env ?state) ?value) - ;; (prn 'POST-LAMBDA1 (get-in ?state [:lambda-scope 0]) (-> ?state :env first :mappings)) - ;; (prn 'POST-LAMBDA2 (get-in ?state [:lambda-scope 0]) (-> ?state :env first (update-in [:mappings] #(reduce dissoc % args-vars)) :mappings)) - [::&util/ok [(-> ?state - (update-in [:env] rest) - ;; (update-in [:lambda-scope 1] inc) - ) - [(get-in ?state [:lambda-scope 0]) - (-> ?state :env first (update-in [:mappings] #(reduce dissoc % args-vars))) - ?value]]]) + [::&util/ok [(update-in ?state [:env] rest) + [(get-in ?state [:lambda-scope 0]) + (-> ?state :env first (update-in [:mappings] #(reduce dissoc % args-vars))) + ?value]]] _ =return))))) @@ -208,7 +178,6 @@ nil]])) (defn ^:private close-over [scope ident register frame] - ;; (prn 'close-over scope ident register) (let [register* (annotated [::captured scope (:closure/id frame) register] (:type register))] [register* (-> frame (update-in [:closure/id] inc) @@ -218,38 +187,29 @@ (fn [state] (or (if-let [[_ ?alias ?binding] (re-find #"^(.*)/(.*)$" ident)] (if-let [?module (get-in state [:deps ?alias])] - (do (prn 'resolve '[_ ?alias ?binding] ident [:global ?module ?binding]) - [::&util/ok [state (annotated [::global ?module ?binding] ::&type/nothing)]]))) + [::&util/ok [state (annotated [::global ?module ?binding] ::&type/nothing)]])) (let [[inner outer] (split-with #(nil? (get-in % [:mappings ident])) (:env state))] (cond (empty? inner) - (do ;; (prn 'resolve/inner ident (get-in state [:lambda-scope 0])) - (prn 'resolve/env ident (-> state :env first :mappings (get ident))) - [::&util/ok [state (-> state :env first :mappings (get ident))]]) + [::&util/ok [state (-> state :env first :mappings (get ident))]] (empty? outer) - (do ;; (prn 'resolve/outer ident (get-in state [:lambda-scope 0])) - (if-let [global|import (or (get-in state [:defs-env ident]) - (get-in state [:imports ident]))] - (do (prn 'resolve/global|import ident global|import) - [::&util/ok [state global|import]]) - (do (prn 'resolve/UNRESOLVED (str "Unresolved identifier: " ident)) - [::&util/failure (str "Unresolved identifier: " ident)]))) + (if-let [global|import (or (get-in state [:defs-env ident]) + (get-in state [:imports ident]))] + [::&util/ok [state global|import]] + [::&util/failure (str "Unresolved identifier: " ident)]) :else - (do ;; (prn 'resolve/:else ident (get-in state [:lambda-scope 0])) - (let [[=local inner*] (reduce (fn [[register new-inner] [frame scope]] - (let [[register* frame*] (close-over scope ident register frame)] - [register* (cons frame* new-inner)])) - [(-> outer first :mappings (get ident)) '()] - (map vector - (reverse inner) - (->> (get-in state [:lambda-scope 0]) - (iterate pop) - (take (count inner)) - reverse)))] - ;; (prn 'resolve/inner* inner*) - (prn 'resolve/=local ident =local) - [::&util/ok [(assoc state :env (concat inner* outer)) =local]]))))))) + (let [[=local inner*] (reduce (fn [[register new-inner] [frame scope]] + (let [[register* frame*] (close-over scope ident register frame)] + [register* (cons frame* new-inner)])) + [(-> outer first :mappings (get ident)) '()] + (map vector + (reverse inner) + (->> (get-in state [:lambda-scope 0]) + (iterate pop) + (take (count inner)) + reverse)))] + [::&util/ok [(assoc state :env (concat inner* outer)) =local]])))))) (defmacro ^:private defanalyser [name match return] `(def ~name @@ -261,19 +221,15 @@ (fail* (str "Unmatched token: " token#)))))) (defn analyse-form* [form] - ;; (prn 'analyse-form* form) (fn [state] (let [old-forms (:forms state) - =return (analyse-form (assoc state :forms (list form))) - ;; _ (prn 'analyse-form*/=return =return) - ] + =return (analyse-form (assoc state :forms (list form)))] (match =return [::&util/ok [?state ?value]] [::&util/ok [(assoc ?state :forms old-forms) ?value]] [::&util/failure ?message] - (do ;; (prn 'analyse-form* ?message) - [::&util/failure ?message]))))) + [::&util/failure ?message])))) (do-template [<name> <tag> <class>] (defanalyser <name> @@ -307,18 +263,7 @@ (defanalyser analyse-ident [::&parser/ident ?ident] - ;; (exec [_env (fn [state] [::&util/ok [state (:env state)]]) - ;; ;; :let [_ (prn 'analyse-ident ?ident _env)] - ;; ] - ;; (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))] - ] - (return =ident))) + (resolve ?ident)) (defanalyser analyse-access [::&parser/static-access ?target ?member] @@ -336,7 +281,6 @@ (fail ""))) (defn full-class [class] - ;; (prn 'full-class-name class) (case class "boolean" (return Boolean/TYPE) "byte" (return Byte/TYPE) @@ -349,9 +293,7 @@ ;; else (if (.contains class ".") (return (Class/forName class)) - (try-all-m [(exec [=class (resolve class) - ;; :let [_ (prn '=class =class)] - ] + (try-all-m [(exec [=class (resolve class)] (match (:form =class) [::class ?full-name] (return (Class/forName ?full-name)) @@ -371,11 +313,7 @@ (full-class ?ident) [::&parser/form ([[::&parser/ident "Array"] [::&parser/ident ?inner]] :seq)] - (exec [;; :let [_ (prn '?inner ?inner)] - =inner (full-class ?inner) - ;; :let [_ (prn '=inner =inner) - ;; _ (prn '(.getName =inner) (.getName =inner))] - ] + (exec [=inner (full-class ?inner)] (return (Class/forName (str "[L" (.getName =inner) ";")))) _ @@ -398,11 +336,7 @@ (fail ""))) (defn lookup-field [mode target field] - ;; (prn 'lookup-field mode target field) (if-let [[[owner type]] (seq (for [=field (.getFields (Class/forName target)) - ;; :let [_ (prn target (.getName =field) (if (java.lang.reflect.Modifier/isStatic (.getModifiers =field)) - ;; :static - ;; :dynamic))] :when (and (= field (.getName =field)) (case mode :static (java.lang.reflect.Modifier/isStatic (.getModifiers =field)) @@ -413,11 +347,7 @@ (fail (str "Field does not exist: " target field mode)))) (defn lookup-method [mode target method args] - ;; (prn 'lookup-method mode target method args) (if-let [methods (seq (for [=method (.getMethods (Class/forName target)) - ;; :let [_ (prn target (.getName =method) (if (java.lang.reflect.Modifier/isStatic (.getModifiers =method)) - ;; :static - ;; :dynamic))] :when (and (= method (.getName =method)) (case mode :static (java.lang.reflect.Modifier/isStatic (.getModifiers =method)) @@ -440,25 +370,19 @@ (fail (str "Field does not exist: " target field)))) (defn lookup-virtual-method [target method-name args] - ;; (prn 'lookup-virtual-method target method-name args) (if-let [method (first (for [=method (.getMethods target) :when (and (= target (.getDeclaringClass =method)) (= method-name (.getName =method)) (not (java.lang.reflect.Modifier/isStatic (.getModifiers =method))))] =method))] - (do ;; (prn 'lookup-virtual-method 'method method) - (exec [=method (&type/method->type method)] - (&type/return-type =method))) - (do ;; (prn 'lookup-virtual-method (str "Virtual method does not exist: " target method-name)) - (fail (str "Virtual method does not exist: " target method-name))))) + (exec [=method (&type/method->type method)] + (&type/return-type =method)) + (fail (str "Virtual method does not exist: " target method-name)))) (defn full-class-name [class] - ;; (prn 'full-class-name class) (if (.contains class ".") (return class) - (try-all-m [(exec [=class (resolve class) - ;; :let [_ (prn '=class =class)] - ] + (try-all-m [(exec [=class (resolve class)] (match (:form =class) [::class ?full-name] (return ?full-name) @@ -483,8 +407,6 @@ (exec [=class (full-class-name ?class) =classes (map-m extract-jvm-param ?classes) =return (lookup-virtual-method (Class/forName =class) ?method =classes) - ;; :let [_ (prn 'analyse-jvm-invokevirtual ?class ?method =classes '-> =return)] - ;; =return =return =object (analyse-form* ?object) =args (map-m analyse-form* ?args)] (return (annotated [::jvm-invokevirtual =class ?method (map #(.getName %) =classes) =object =args] =return)))) @@ -512,45 +434,7 @@ (exec [=array (analyse-form* ?array)] (return (annotated [::jvm-aaload =array ?idx] (-> =array :type (nth 1)))))) -;; (defanalyser analyse-access -;; [::&parser/access ?object ?member] -;; (match ?member -;; [::&parser/ident ?field] ;; Field -;; (try-all-m [(exec [?target (extract-ident ?object) -;; =target (resolve ?target) -;; ?class (extract-class (:form =target)) -;; [=owner =type] (lookup-field :static ?class ?field) -;; ;; :let [_ (prn '=type =type)] -;; ] -;; (return (annotated [::static-field =owner ?field] =type))) -;; (exec [=target (analyse-form* ?object) -;; ?class (class-type (:type =target)) -;; [=owner =type] (lookup-field :dynamic ?class ?field) -;; ;; :let [_ (prn '=type =type)] -;; ] -;; (return (annotated [::dynamic-field =target =owner ?field] =type)))]) -;; [::&parser/fn-call [::&parser/ident ?method] ?args] ;; Method -;; (exec [=args (map-m analyse-form* ?args)] -;; (try-all-m [(exec [?target (extract-ident ?object) -;; =target (resolve ?target) -;; ?class (extract-class (:form =target)) -;; =methods (lookup-method :static ?class ?method (map :type =args)) -;; ;; :let [_ (prn '=methods =methods)] -;; [=owner =method] (within :types (&type/pick-matches =methods (map :type =args))) -;; ;; :let [_ (prn '=method =owner ?method =method)] -;; ] -;; (return (annotated [::static-method =owner ?method =method =args] (&type/return-type =method)))) -;; (exec [=target (analyse-form* ?object) -;; ?class (class-type (:type =target)) -;; =methods (lookup-method :dynamic ?class ?method (map :type =args)) -;; ;; :let [_ (prn '=methods =methods)] -;; [=owner =method] (within :types (&type/pick-matches =methods (map :type =args))) -;; ;; :let [_ (prn '=method =owner ?method =method)] -;; ] -;; (return (annotated [::dynamic-method =target =owner ?method =method =args] (&type/return-type =method))))])))) - (defn ->token [x] - ;; (prn '->token x) (match x [::&parser/bool ?bool] (doto (.newInstance (.loadClass @loader "lux.Variant1")) @@ -592,7 +476,6 @@ (defn ->tokens [xs] (reduce (fn [tail x] - ;; (prn 'tail (.-tag tail) 'x x) (doto (.newInstance (.loadClass @loader "lux.Variant2")) (-> .-tag (set! "Cons")) (-> .-_1 (set! (->token x))) @@ -602,7 +485,6 @@ (reverse xs))) (defn ->clojure-token [x] - ;; (prn '->clojure-token x (.-tag x)) (case (.-tag x) "Bool" [::&parser/bool (-> x .-_1)] "Int" [::&parser/int (-> x .-_1)] @@ -615,7 +497,6 @@ "Form" [::&parser/form (-> x .-_1 tokens->clojure)])) (defn tokens->clojure [xs] - ;; (prn 'tokens->clojure xs (.-tag xs)) (case (.-tag xs) "Nil" '() "Cons" (cons (->clojure-token (.-_1 xs)) @@ -624,25 +505,17 @@ (defanalyser analyse-call [::&parser/form ([?fn & ?args] :seq)] - (exec [=fn (analyse-form* ?fn) - ;; :let [_ (prn 'analyse-call/=fn =fn)] - ] + (exec [=fn (analyse-form* ?fn)] (match (:form =fn) [::global-fn ?module ?name] (exec [macro? (is-macro? ?module ?name) - scoped? (in-scope? ?module ?name) - :let [_ (prn 'analyse-call [:global-fn ?module ?name] macro? scoped?)] - ;; :let [_ (prn 'analyse-call [:global-fn ?module ?name] macro? scoped?)] - ] + scoped? (in-scope? ?module ?name)] (if (and macro? (not scoped?)) (let [macro-class (str ?module "$" (normalize-ident ?name)) transformed (-> (.loadClass @loader macro-class) .newInstance (.apply (->tokens ?args)) - ->clojure-token) - _ (prn 'analyse-call/macro-raw ?args) - _ (prn 'analyse-call/transformed transformed) - ] + ->clojure-token)] (-> transformed analyse-form*)) (exec [=args (map-m analyse-form* ?args) @@ -652,9 +525,7 @@ provides-num (count =args)] (if (> needs-num provides-num) [needs-num [::&type/function (drop provides-num ?fargs) ?freturn]] - [needs-num [::&type/object "java.lang.Object" []]]))) - ;; _ (prn '[needs-num =return-type] [needs-num =return-type]) - ]] + [needs-num [::&type/object "java.lang.Object" []]])))]] (return (annotated [::static-call needs-num =fn =args] =return-type))))) _ @@ -665,13 +536,8 @@ (defanalyser analyse-if [::&parser/form ([[::&parser/ident "if"] ?test ?then ?else] :seq)] (exec [=test (analyse-form* ?test) - ;; :let [_ (prn '=test =test)] - ;; :let [_ (prn 'PRE '?then ?then)] =then (analyse-form* ?then) - ;; :let [_ (prn '=then =then)] - =else (analyse-form* ?else) - ;; :let [_ (prn '=else =else)] - ] + =else (analyse-form* ?else)] (return (annotated [::if =test =then =else] ::&type/nothing)))) (defanalyser analyse-do @@ -754,18 +620,12 @@ :branches #{}} generate-branches (fn generate-branches [data] (let [branches* (reduce fold-branch base-struct data)] - ;; (prn 'generate-branches data) - ;; (prn 'branches* branches*) - ;; (.print System/out (prn-str 'branches* branches*)) - ;; (.print System/out (prn-str '(:type branches*) (:type branches*))) (clojure.core.match/match (:type branches*) ::char-tests branches* ::text-tests branches* ::tuple (do (assert (<= (count (:defaults branches*)) 1)) {:type ::tuple* - :patterns (into {} (for [[?tag ?struct] {nil (:patterns branches*)} - ;; :let [_ (prn '(:patterns branches*) ?tag ?struct)] - ] + :patterns (into {} (for [[?tag ?struct] {nil (:patterns branches*)}] [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)] (map #(vector % body) case)))] (map generate-branches grouped-parts)) @@ -774,9 +634,7 @@ :branches (:branches branches*)}) ::adt (do (assert (<= (count (:defaults branches*)) 1)) {:type ::adt* - :patterns (into {} (for [[?tag ?struct] (:patterns branches*) - ;; :let [_ (prn '(:patterns branches*) ?tag ?struct)] - ] + :patterns (into {} (for [[?tag ?struct] (:patterns branches*)] [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)] (map #(vector % body) case)))] (map generate-branches grouped-parts)) @@ -860,7 +718,6 @@ (clojure.core.match/match branch [::case-branch ?pattern ?body] [(->instructions locals ?pattern) ?body])) - ;; _ (prn branches**) ;; Step 5: Re-structure branching ] [max-registers branch-mappings (generate-branches branches**)]))) @@ -883,13 +740,9 @@ (defanalyser analyse-case [::&parser/form ([[::&parser/ident "case"] ?variant & ?branches] :seq)] (exec [=variant (analyse-form* ?variant) - ;; :let [_ (prn 'analyse-case '=variant =variant)] $scope scope-id - ;; :let [_ (prn 'analyse-case '$scope $scope)] $base next-local-idx - ;; :let [_ (prn 'analyse-case '$base $base)] [registers mappings tree] (exec [=branches (map-m (fn [[?pattern ?body]] - ;; (prn '?branch ?branch) (match ?pattern [::&parser/char ?token] (exec [=body (analyse-form* ?body)] @@ -910,26 +763,18 @@ [::&parser/tuple ?members] (exec [[_ locals+] (reduce-m (locals-getter $scope) [$base {}] ?members) - ;; :let [_ (prn 'analyse-case 'locals+ locals+)] =body (with-locals locals+ - (analyse-form* ?body)) - ;; :let [_ (prn 'analyse-case '=body =body)] - ] + (analyse-form* ?body))] (return [::case-branch [::&parser/tuple ?members] =body])) [::&parser/form ([[::&parser/tag ?tag] & ?members] :seq)] (exec [[_ locals+] (reduce-m (locals-getter $scope) [$base {}] ?members) - ;; :let [_ (prn 'analyse-case 'locals+ locals+)] =body (with-locals locals+ - (analyse-form* ?body)) - ;; :let [_ (prn 'analyse-case '=body =body)] - ] + (analyse-form* ?body))] (return [::case-branch [::&parser/variant ?tag ?members] =body])) )) (partition 2 ?branches))] - (return (->decision-tree $scope $base =branches))) - ;; :let [_ (prn 'analyse-case '[registers mappings tree] [registers mappings tree])] - ] + (return (->decision-tree $scope $base =branches)))] (return (annotated [::case (dec $base) =variant registers mappings tree] ::&type/nothing))))) (defanalyser analyse-let @@ -942,8 +787,7 @@ (defanalyser analyse-defclass [::&parser/form ([[::&parser/ident "jvm/defclass"] [::&parser/ident ?name] [::&parser/ident ?super-class] [::&parser/tuple ?fields]] :seq)] - (exec [;; :let [_ (prn 'analyse-defclass/?fields ?fields)] - ?fields (map-m (fn [?field] + (exec [?fields (map-m (fn [?field] (match ?field [::&parser/tuple ([[::&parser/ident ?class] [::&parser/ident ?field-name]] :seq)] (return [?class ?field-name]) @@ -951,8 +795,7 @@ _ (fail ""))) ?fields) - :let [;; _ (prn 'analyse-defclass/?fields ?fields) - =members {:fields (into {} (for [[class field] ?fields] + :let [=members {:fields (into {} (for [[class field] ?fields] [field {:access ::public :type class}]))}] name module-name] @@ -960,22 +803,17 @@ (defanalyser analyse-definterface [::&parser/form ([[::&parser/ident "jvm/definterface"] [::&parser/ident ?name] & ?members] :seq)] - (exec [;; :let [_ (prn 'analyse-definterface/?members ?members)] - ?members (map-m #(match % + (exec [?members (map-m #(match % [::&parser/form ([[::&parser/ident ":"] [::&parser/ident ?member-name] [::&parser/form ([[::&parser/ident "->"] [::&parser/tuple ?inputs] [::&parser/ident ?output]] :seq)]] :seq)] - (exec [;; :let [_ (prn '[?member-name ?inputs ?output] [?member-name ?inputs ?output])] - ?inputs (map-m extract-ident ?inputs) - ;; :let [_ (prn '[?member-name ?inputs ?output] [?member-name ?inputs ?output])] - ] + (exec [?inputs (map-m extract-ident ?inputs)] (return [?member-name [?inputs ?output]])) _ (fail "")) ?members) - :let [;; _ (prn '?members ?members) - =members {:methods (into {} (for [[method [inputs output]] ?members] + :let [=members {:methods (into {} (for [[method [inputs output]] ?members] [method {:access ::public :type [inputs output]}]))} =interface [::interface ?name =members]] @@ -995,23 +833,15 @@ [::&parser/form ([[::&parser/ident ?name] & ?args] :seq)] (exec [args (map-m extract-ident ?args) - ;; :let [_ (prn 'analyse-def/args args)] [=function =args =return] (within :types (&type/fresh-function (count args))) - ;; :let [_ (prn '[=function =args =return] [=function =args =return])] - ;; :let [env (-> {} - ;; (assoc ?name =function) - ;; (into (map vector args =args))) - ;; _ (prn 'env env)] =value (with-scope ?name (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-fn ?name {:mode ::function :access ::public :type =function})] @@ -1021,19 +851,15 @@ (defanalyser analyse-defmacro [::&parser/form ([[::&parser/ident "defmacro"] [::&parser/form ([[::&parser/ident ?name] [::&parser/ident ?tokens]] :seq)] ?value] :seq)] (exec [[=function =tokens =return] (within :types (&type/fresh-function 1)) - :let [_ (prn 'analyse-defmacro/_1 ?name)] =value (with-scope ?name (with-scoped-name ?name =function (with-local ?tokens =tokens (analyse-form* ?value)))) - :let [_ (prn 'analyse-defmacro/_2 ?name)] =function (within :types (exec [_ (&type/solve =return (:type =value))] (&type/clean =function))) - :let [_ (prn 'analyse-defmacro/_3 ?name)] _ (define-fn ?name {:mode ::macro :access ::public - :type =function}) - :let [_ (prn 'analyse-defmacro/_4 ?name)]] + :type =function})] (return (annotated [::def [?name (list ?tokens)] =value] ::&type/nothing)))) (defanalyser analyse-lambda diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 07a1df1a4..9f6a6cd6c 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -26,11 +26,8 @@ ;; [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)) - ;; (Thread/sleep 2000) - ) + (.write stream data))) (defn ^:private write-class [name data] (write-file (str "output/" name ".class") data)) @@ -47,7 +44,6 @@ ~'*writer* (:writer ~'*state*) ~'*parent* (:parent ~'*state*) ~'*type* (:type (:form ~'*state*))] - ;; (prn '~name (:form (:form ~'*state*))) (match (:form (:form ~'*state*)) ~match (do ~body @@ -146,9 +142,7 @@ (instance? java.lang.Boolean ?literal) (if ?literal - ;; (.visitLdcInsn *writer* (int 1)) (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") "TRUE" (->type-signature "java.lang.Boolean")) - ;; (.visitLdcInsn *writer* (int 0)) (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") "FALSE" (->type-signature "java.lang.Boolean"))) (string? ?literal) @@ -159,8 +153,7 @@ (defcompiler ^:private compile-tuple [::&analyser/tuple ?elems] - (let [;; _ (prn 'compile-tuple (count ?elems)) - num-elems (count ?elems)] + (let [num-elems (count ?elems)] (let [tuple-class (str (str +prefix+ "/Tuple") num-elems)] (doto *writer* (.visitTypeInsn Opcodes/NEW tuple-class) @@ -173,112 +166,85 @@ (defcompiler ^:private compile-local [::&analyser/local ?env ?idx] - (do ;; (prn 'LOCAL ?idx) - (doto *writer* - (.visitVarInsn Opcodes/ALOAD (int ?idx))))) + (doto *writer* + (.visitVarInsn Opcodes/ALOAD (int ?idx)))) (defcompiler ^:private compile-captured [::&analyser/captured ?scope ?captured-id ?source] - (do ;; (prn 'CAPTURED [?scope ?captured-id]) - (doto *writer* - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD - (apply str (interpose "$" (map (comp normalize-ident str) ?scope))) - (str "__" ?captured-id) - "Ljava/lang/Object;")))) + (doto *writer* + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD + (apply str (interpose "$" (map (comp normalize-ident str) ?scope))) + (str "__" ?captured-id) + "Ljava/lang/Object;"))) (defcompiler ^:private compile-global [::&analyser/global ?owner-class ?name] - (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 "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;" ;; (->java-sig *type*) - )))) + (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC (->class (str ?owner-class "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;"))) (defcompiler ^:private compile-global-fn [::&analyser/global-fn ?owner-class ?name] (let [fn-class (str ?owner-class "$" (normalize-ident ?name))] (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class fn-class) "_datum" (->type-signature fn-class)))) -;; (defcompiler ^:private compile-call -;; [::&analyser/call ?fn ?args] -;; (do (prn 'compile-call (:form ?fn) ?fn ?args) -;; (doseq [arg (reverse ?args)] -;; (compile-form (assoc *state* :form arg))) -;; (match (:form ?fn) -;; [::&analyser/global ?owner-class ?fn-name] -;; (let [signature (str "(" (apply str (repeat (count ?args) "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")] -;; (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC (->class ?owner-class) ?fn-name signature)))))) - (defcompiler ^:private compile-call [::&analyser/call ?fn ?args] - (do ;; (prn 'compile-call (:form ?fn) ?fn ?args) - (do (compile-form (assoc *state* :form ?fn)) - (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"] - (doseq [arg ?args] - (compile-form (assoc *state* :form arg)) - (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" apply-signature)))))) + (do (compile-form (assoc *state* :form ?fn)) + (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"] + (doseq [arg ?args] + (compile-form (assoc *state* :form arg)) + (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" apply-signature))))) (defcompiler ^:private compile-static-call [::&analyser/static-call ?needs-num ?fn ?args] - (do ;; (prn 'compile-call (:form ?fn) ?fn ?args) - (match (:form ?fn) - [::&analyser/global-fn ?owner-class ?fn-name] - (let [arg-sig (->type-signature "java.lang.Object") - call-class (str (->class ?owner-class) "$" (normalize-ident ?fn-name)) - provides-num (count ?args)] - (if (>= provides-num ?needs-num) - (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;" - impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)] - (doto *writer* - (-> (do (compile-form (assoc *state* :form arg))) - (->> (doseq [arg (take ?needs-num ?args)]))) - (.visitMethodInsn Opcodes/INVOKESTATIC call-class "impl" impl-sig) - (-> (doto (do (compile-form (assoc *state* :form arg))) - (.visitMethodInsn Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" apply-signature)) - (->> (doseq [arg (drop ?needs-num ?args)]))))) - (let [counter-sig "I" - init-signature (str "(" (apply str counter-sig (repeat (dec ?needs-num) arg-sig)) ")" "V")] - (doto *writer* - (.visitTypeInsn Opcodes/NEW call-class) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int provides-num)) - (-> (do (compile-form (assoc *state* :form arg))) - (->> (doseq [arg ?args]))) - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (dotimes [_ (dec (- ?needs-num provides-num))]))) - (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" init-signature))) - )) - ))) + (match (:form ?fn) + [::&analyser/global-fn ?owner-class ?fn-name] + (let [arg-sig (->type-signature "java.lang.Object") + call-class (str (->class ?owner-class) "$" (normalize-ident ?fn-name)) + provides-num (count ?args)] + (if (>= provides-num ?needs-num) + (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;" + impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)] + (doto *writer* + (-> (do (compile-form (assoc *state* :form arg))) + (->> (doseq [arg (take ?needs-num ?args)]))) + (.visitMethodInsn Opcodes/INVOKESTATIC call-class "impl" impl-sig) + (-> (doto (do (compile-form (assoc *state* :form arg))) + (.visitMethodInsn Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" apply-signature)) + (->> (doseq [arg (drop ?needs-num ?args)]))))) + (let [counter-sig "I" + init-signature (str "(" (apply str counter-sig (repeat (dec ?needs-num) arg-sig)) ")" "V")] + (doto *writer* + (.visitTypeInsn Opcodes/NEW call-class) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int provides-num)) + (-> (do (compile-form (assoc *state* :form arg))) + (->> (doseq [arg ?args]))) + (-> (.visitInsn Opcodes/ACONST_NULL) + (->> (dotimes [_ (dec (- ?needs-num provides-num))]))) + (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" init-signature))) + )) + )) (defcompiler ^:private compile-jvm-getstatic [::&analyser/jvm-getstatic ?owner ?field] - (do ;; (prn 'compile-static-field ?owner ?field) - ;; (assert false) - (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (->class ?owner) ?field (->java-sig *type*))) - )) + (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC (->class ?owner) ?field (->java-sig *type*)))) (defcompiler ^:private compile-dynamic-field [::&analyser/dynamic-field ?target ?owner ?field] - (do ;; (prn 'compile-static-field ?owner ?field) - ;; (assert false) - (compile-form (assoc *state* :form ?target)) + (do (compile-form (assoc *state* :form ?target)) (doto *writer* - (.visitFieldInsn Opcodes/GETFIELD (->class ?owner) ?field (->java-sig *type*))) - )) + (.visitFieldInsn Opcodes/GETFIELD (->class ?owner) ?field (->java-sig *type*))))) (defcompiler ^:private compile-static-method [::&analyser/static-method ?owner ?method-name ?method-type ?args] - (do ;; (prn 'compile-dynamic-access ?target ?owner ?method-name ?method-type ?args) - ;; (assert false) - (do (doseq [arg ?args] - (compile-form (assoc *state* :form arg))) - (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (->class ?owner) ?method-name (method->sig ?method-type)) - (.visitInsn Opcodes/ACONST_NULL))) - )) + (do (doseq [arg ?args] + (compile-form (assoc *state* :form arg))) + (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC (->class ?owner) ?method-name (method->sig ?method-type)) + (.visitInsn Opcodes/ACONST_NULL)))) (defn prepare-arg! [*writer* class-name] (condp = class-name @@ -339,8 +305,7 @@ (defcompiler ^:private compile-jvm-invokevirtual [::&analyser/jvm-invokevirtual ?class ?method ?classes ?object ?args] - (let [;; _ (prn 'compile-jvm-invokevirtual [?class ?method ?classes] '-> *type*) - method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))] + (let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))] (compile-form (assoc *state* :form ?object)) (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class)) (doseq [[class-name arg] (map vector ?classes ?args)] @@ -391,20 +356,16 @@ [::&analyser/if ?test ?then ?else] (let [else-label (new Label) end-label (new Label)] - ;; (println "PRE") (compile-form (assoc *state* :form ?test)) (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +bool-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +bool-class+ "booleanValue" "()Z") (.visitJumpInsn Opcodes/IFEQ else-label)) - ;; (prn 'compile-if/?then (:form ?then)) (compile-form (assoc *state* :form ?then)) - ;; (.visitInsn *writer* Opcodes/POP) (doto *writer* (.visitJumpInsn Opcodes/GOTO end-label) (.visitLabel else-label)) (compile-form (assoc *state* :form ?else)) - ;; (.visitInsn *writer* Opcodes/POP) (.visitLabel *writer* end-label)))) (defcompiler ^:private compile-do @@ -421,7 +382,6 @@ +variant-field-sig+ (->type-signature "java.lang.Object") equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] (defn compile-decision-tree [writer mappings default-label decision-tree] - ;; (prn 'compile-decision-tree decision-tree) (match decision-tree [::test-char ?pairs] (do (doseq [[?token $body] ?pairs @@ -506,9 +466,7 @@ (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag (.visitInsn Opcodes/POP) ;; variant (do (let [arity (-> ?subcases first (nth 2) count) - variant-class** (str variant-class* arity) - ;; _ (prn ?tag arity variant-class**) - ] + variant-class** (str variant-class* arity)] (.visitTypeInsn writer Opcodes/CHECKCAST variant-class**) ;; variantN (doseq [subcase ?subcases :let [next-subcase (new Label)]] @@ -532,7 +490,6 @@ ;; variant, tag -> (.visitLabel tag-else-label)) (->> (doseq [[?tag ?subcases] ?cases - ;; :let [_ (.print System/out (prn-str 'COMPILE-PATTERN ?tag ?subcases))] :let [tag-else-label (new Label)]]))) ;; variant, tag -> (.visitInsn Opcodes/POP) ;; variant -> @@ -541,23 +498,18 @@ )) (defn sequence-parts [branches parts] - ;; (.print System/out (prn-str 'sequence-parts branches parts)) (if (empty? parts) '(()) (let [[head & tail] parts expanded (case (:type head) ::&analyser/defaults (for [[?local ?supports] (:stores head) - ?body (set/intersection branches ?supports) - ;; :when (set/subset? branches ?supports) - ] + ?body (set/intersection branches ?supports)] [[::store ?local ?body] #{?body}]) ::&analyser/char-tests (concat (list [[::test-char (for [[?token ?supports] (:patterns head) - ?body (set/intersection branches ?supports) - ;; :when (set/subset? branches ?supports) - ] + ?body (set/intersection branches ?supports)] [?token ?body])] branches]) (for [[_ ?local ?body] (:defaults head) @@ -566,9 +518,7 @@ ::&analyser/text-tests (concat (list [[::test-text (for [[?token ?supports] (:patterns head) - ?body (set/intersection branches ?supports) - ;; :when (set/subset? branches ?supports) - ] + ?body (set/intersection branches ?supports)] [?token ?body])] branches]) (for [[_ ?local ?body] (:defaults head) @@ -577,14 +527,11 @@ ::&analyser/tuple* (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) - ;; :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)))] :when (= num-parts (count subseq))] [::subcase ?body subseq])] :when (not (empty? subcases))] @@ -599,52 +546,27 @@ '())) ::&analyser/adt* - (do ;; (prn '(:default head) (:default head)) - ;; (assert (nil? (:default head))) - ;; (let [patterns (into {} (for [[?tag ?struct] (:patterns head) - ;; ;; :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)))] - ;; :when (= num-parts (count subseq))] - ;; [::subcase ?body subseq])] - ;; :when (not (empty? subcases))] - ;; [?tag subcases]))] - ;; (if (empty? patterns) - ;; '() - ;; (list [[::test-adt branches patterns] - ;; branches]))) - (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) - ;; :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)))] - :when (= num-parts (count subseq))] - [::subcase ?body subseq])] - :when (not (empty? subcases))] - [?tag subcases]))] - (if (empty? patterns) - '() - (list [[::test-adt branches patterns] - branches]))) - (if-let [[_ ?local ?body] (:default head)] - (for [?body (set/intersection branches #{?body})] - [[::default ?local ?body] #{?body}]) - '())) - ) + (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) + :let [?parts (:parts ?struct) + num-parts (count ?parts) + ?supports (:branches ?struct) + subcases (for [?body (set/intersection branches ?supports) + subseq (sequence-parts #{?body} ?parts) + :when (= num-parts (count subseq))] + [::subcase ?body subseq])] + :when (not (empty? subcases))] + [?tag subcases]))] + (if (empty? patterns) + '() + (list [[::test-adt branches patterns] + branches]))) + (if-let [[_ ?local ?body] (:default head)] + (for [?body (set/intersection branches #{?body})] + [[::default ?local ?body] #{?body}]) + '())) )] (for [[step branches*] expanded - tail* (sequence-parts branches* tail) - ;; :let [_ (.print System/out (prn-str 'tail* tail*))] - ] + tail* (sequence-parts branches* tail)] (cons step tail*))))) (def !case-vars (atom -1)) @@ -653,83 +575,53 @@ equals-sig (str "(" (->type-signature "java.lang.Object") ")Z") ex-class (->class "java.lang.IllegalStateException")] (defcompiler ^:private compile-case - ;; [::&analyser/case ?variant ?branches] [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree] - (do ;; (prn 'compile-case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree) - ;; (assert false) - ;; (prn 'compile-case ?decision-tree) - (let [start-label (new Label) - end-label (new Label) - ;; default-label (new Label) - entries (for [[?branch ?body] ?branch-mappings - :let [label (new Label)]] - [[?branch label] - [label ?body]]) - mappings* (into {} (map first entries))] - (dotimes [idx ?max-registers] - (.visitLocalVariable *writer* (str "__" (swap! !case-vars inc) "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx)))) - (compile-form (assoc *state* :form ?variant)) + (let [start-label (new Label) + end-label (new Label) + entries (for [[?branch ?body] ?branch-mappings + :let [label (new Label)]] + [[?branch label] + [label ?body]]) + mappings* (into {} (map first entries))] + (dotimes [idx ?max-registers] + (.visitLocalVariable *writer* (str "__" (swap! !case-vars inc) "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx)))) + (compile-form (assoc *state* :form ?variant)) + (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLabel start-label)) + (let [default-label (new Label)] + (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))] + (if (or (:default ?decision-tree) + (not (empty? (:defaults ?decision-tree)))) + (butlast pieces) + pieces))] + (compile-decision-tree *writer* mappings* default-label decision-tree)) + (.visitLabel *writer* default-label) + (if-let [[_ [_ _ ?idx] ?body] (or (:default ?decision-tree) + (first (:defaults ?decision-tree)))] (doto *writer* (.visitInsn Opcodes/DUP) - (.visitLabel start-label)) - (let [default-label (new Label) - ;; default-code (:default ?decision-tree) - ] - ;; (prn 'sequence-parts - ;; (sequence-parts (:branches ?decision-tree) (list ?decision-tree))) - (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))] - (if (or (:default ?decision-tree) - (not (empty? (:defaults ?decision-tree)))) - (butlast pieces) - pieces))] - (compile-decision-tree *writer* mappings* default-label decision-tree)) - (.visitLabel *writer* default-label) - (if-let [[_ [_ _ ?idx] ?body] (or (:default ?decision-tree) - (first (:defaults ?decision-tree)))] - (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitVarInsn Opcodes/ASTORE ?idx) - (.visitJumpInsn Opcodes/GOTO (get mappings* ?body))) - (doto *writer* - (.visitInsn Opcodes/POP) - ;; (.visitTypeInsn Opcodes/CHECKCAST (->class +variant-class+)) - ;; (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" (->type-signature "java.lang.String")) - (.visitTypeInsn Opcodes/NEW ex-class) - (.visitInsn Opcodes/DUP) - ;; (.visitInsn Opcodes/DUP_X1) - ;; (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V") - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" (str "(" (->type-signature "java.lang.String") ")" "V")) - (.visitInsn Opcodes/ATHROW))) - ;; (if default-code - ;; ;; (do (prn 'default-code default-code) - ;; ;; (assert false) - ;; ;; ;; (.visitInsn Opcodes/POP) ;; ... - ;; ;; (compile-form (assoc *state* :form default-code)) - ;; ;; (.visitJumpInsn *writer* Opcodes/GOTO end-label)) - ;; (doto *writer* - ;; (.visitInsn Opcodes/POP) - ;; (.visitTypeInsn Opcodes/NEW ex-class) - ;; (.visitInsn Opcodes/DUP) - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V") - ;; (.visitInsn Opcodes/ATHROW))) - ) - ;; (compile-decision-tree *state* *writer* mappings* 1 nil (:branches ?decision-tree) ?decision-tree) - (doseq [[?label ?body] (map second entries)] - (.visitLabel *writer* ?label) - (.visitInsn *writer* Opcodes/POP) - (compile-form (assoc *state* :form ?body)) - (.visitJumpInsn *writer* Opcodes/GOTO end-label)) - (.visitLabel *writer* end-label) - )) - )) + (.visitVarInsn Opcodes/ASTORE ?idx) + (.visitJumpInsn Opcodes/GOTO (get mappings* ?body))) + (doto *writer* + (.visitInsn Opcodes/POP) + (.visitTypeInsn Opcodes/NEW ex-class) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V") + (.visitInsn Opcodes/ATHROW)))) + (doseq [[?label ?body] (map second entries)] + (.visitLabel *writer* ?label) + (.visitInsn *writer* Opcodes/POP) + (compile-form (assoc *state* :form ?body)) + (.visitJumpInsn *writer* Opcodes/GOTO end-label)) + (.visitLabel *writer* end-label) + ))) (defcompiler ^:private compile-let [::&analyser/let ?idx ?label ?value ?body] (let [start-label (new Label) end-label (new Label) ?idx (int ?idx)] - ;; (prn '(:type ?value) (:type ?value) (->java-sig (:type ?value))) (.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* @@ -817,11 +709,8 @@ (-> (.visitInsn Opcodes/ACONST_NULL) (->> (dotimes [clo_idx (- (dec num-captured) current-captured)]))) (.visitMethodInsn Opcodes/INVOKESPECIAL current-class "<init>" init-signature) - ;; (.visitJumpInsn Opcodes/GOTO end-label) (.visitInsn Opcodes/ARETURN)) - (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels))) - ;; :let [_ (prn '[branch-label current-captured] [branch-label current-captured])] - ]))) + (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))]))) (.visitLabel default-label) (-> (doto (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig)) @@ -829,7 +718,6 @@ (->> (when (not= 0 num-captured)))) (.visitVarInsn Opcodes/ALOAD 1) (.visitMethodInsn Opcodes/INVOKESTATIC current-class "impl" real-signature) - ;; (.visitLabel end-label) (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd))) @@ -864,25 +752,22 @@ (defcompiler ^:private compile-def [::&analyser/def ?form ?body] - (do ;; (prn 'compile-def ?form) - (match ?form - (?name :guard string?) - (compile-field *writer* *class-name* ?name ?body *state*) - - [?name ?args] - (do ;; (prn 'compile-def `(~'def (~(symbol ?name) ~@(map symbol ?args)))) - (if (= "main" ?name) - (let [signature "([Ljava/lang/String;)V" - =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil) - (.visitCode))] - ;; (prn 'FN/?body ?body) - (compile-form (assoc *state* :parent *writer* :writer =method :form ?body)) - (doto =method - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))) - (compile-method-function *writer* *class-name* ?name (count ?args) ?body *state*))) - ))) + (match ?form + (?name :guard string?) + (compile-field *writer* *class-name* ?name ?body *state*) + + [?name ?args] + (if (= "main" ?name) + (let [signature "([Ljava/lang/String;)V" + =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil) + (.visitCode))] + (compile-form (assoc *state* :parent *writer* :writer =method :form ?body)) + (doto =method + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))) + (compile-method-function *writer* *class-name* ?name (count ?args) ?body *state*)) + )) (defn ^:private captured? [form] (match form @@ -893,14 +778,11 @@ (defcompiler ^:private compile-lambda [::&analyser/lambda ?scope ?frame ?args ?body] - (let [;; _ (prn '[?scope ?frame] ?scope ?frame ?args) - num-args (count ?args) - ;; outer-class (->class *class-name*) + (let [num-args (count ?args) clo-field-sig (->type-signature "java.lang.Object") 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 (apply str (interpose "$" ?scope)) current-class (apply str (interpose "$" (map (comp normalize-ident str) ?scope))) num-captured (dec num-args) init-signature (str "(" (apply str (repeat (->> (:mappings ?frame) @@ -912,8 +794,6 @@ (apply str counter-sig (repeat num-captured clo-field-sig))) ")" "V") - ;; _ (prn current-class 'init-signature init-signature) - ;; _ (prn current-class 'real-signature real-signature) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) current-class nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) @@ -981,9 +861,7 @@ (->> (dotimes [clo_idx (- (dec num-captured) current-captured)]))) (.visitMethodInsn Opcodes/INVOKESPECIAL current-class "<init>" init-signature) (.visitInsn Opcodes/ARETURN)) - (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels))) - ;; :let [_ (prn '[branch-label current-captured] [branch-label current-captured])] - ]))) + (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))]))) (.visitLabel default-label) (-> (doto (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig)) @@ -994,7 +872,6 @@ (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd))) - ;; _ (prn 'LAMBDA/?body ?body) =impl (doto (.visitMethod =class Opcodes/ACC_PUBLIC "impl" real-signature nil nil) (.visitCode) (->> (assoc *state* :form ?body :writer) @@ -1006,17 +883,6 @@ bytecode (.toByteArray =class)] (write-class current-class bytecode) (load-class! (string/replace current-class #"/" ".") (str current-class ".class")) - ;; (apply prn 'LAMBDA ?scope ?args (->> (:mappings ?frame) - ;; (map second) - ;; (map :form) - ;; (filter captured?))) - ;; (prn 'M2 (:mappings ?frame)) - ;; (prn 'M2 (->> (:mappings ?frame) - ;; (filter (comp captured? :form second)))) - ;; (prn 'M3 (->> (:mappings ?frame) - ;; (filter (comp captured? :form second)) - ;; (sort #(< (-> %1 second :form (nth 2)) - ;; (-> %2 second :form (nth 2)))))) (doto *writer* (.visitTypeInsn Opcodes/NEW current-class) (.visitInsn Opcodes/DUP) @@ -1028,7 +894,6 @@ (sort #(< (-> %1 second :form (nth 2)) (-> %2 second :form (nth 2)))))]))) (-> (doto (.visitInsn Opcodes/ICONST_0) - ;; (.visitInsn Opcodes/ICONST_0) (-> (.visitInsn Opcodes/ACONST_NULL) (->> (doseq [_ (butlast ?args)])))) (->> (when (> (count ?args) 1)))) @@ -1076,7 +941,6 @@ (defcompiler ^:private compile-variant [::&analyser/variant ?tag ?members] (let [variant-class* (str (->class +variant-class+) (count ?members))] - ;; (prn 'compile-variant ?tag ?value) (doto *writer* (.visitTypeInsn Opcodes/NEW variant-class*) (.visitInsn Opcodes/DUP) @@ -1097,18 +961,10 @@ (defcompiler compile-use [::&analyser/use ?file ?alias] (let [module-name (re-find #"[^/]+$" ?file) - ;; _ (prn 'module-name module-name) source-code (slurp (str "source/" module-name ".lux")) - ;; _ (prn 'source-code source-code) tokens (&lexer/lex source-code) - ;; _ (prn 'tokens tokens) syntax (&parser/parse tokens) - ;; _ (prn 'syntax syntax) - ;; ann-syntax (&analyser/analyse module-name syntax) - ;; _ (prn 'ann-syntax ann-syntax) bytecode (compile module-name syntax)] - ;; (write-file (str module-name ".class") bytecode) - ;; (load-class! (string/replace module-name #"/" ".") (str module-name ".class")) nil)) (let [+int-class+ (->class "java.lang.Integer")] @@ -1166,22 +1022,13 @@ compile-jvm-aastore compile-jvm-aaload]] (defn ^:private compile-form [state] - ;; (prn 'compile-form/state state) (or (some #(% state) +compilers+) (assert false (str "Can't compile: " (pr-str (:form state))))))) ;; [Interface] (def !state (atom nil)) -;; "map" {:mode :lux.analyser/function, -;; :access :lux.analyser/public, -;; :type [:lux.type/function (:lux.type/any :lux.type/any) :lux.type/any]} - -;; "map" {:form [:lux.analyser/global-fn "lux" "map"], -;; :type [:lux.type/function (:lux.type/any :lux.type/any) :lux.type/any]} - (defn compile [module-name inputs] - ;; (prn 'inputs inputs) (if-let [module (get-in @!state [:modules module-name])] (assert false "Can't redefine a module!") (do (reset-loader!) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index c0ced6baf..8f7bdbb1d 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -39,13 +39,8 @@ (def ^:private lex-string-body (try-all-m [(exec [[prefix escaped] (lex-regex2 #"(?s)^([^\"\\]*)(\\.)") - ;; :let [_ (prn '[prefix escaped] [prefix escaped])] unescaped (escape-char escaped) - ;; :let [_ (prn 'unescaped unescaped)] - postfix lex-string-body - ;; :let [_ (prn 'postfix postfix)] - ;; :let [_ (prn 'FULL (str prefix unescaped postfix))] - ] + postfix lex-string-body] (return (str prefix unescaped postfix))) (lex-regex #"(?s)^([^\"\\]*)")])) @@ -74,41 +69,24 @@ (def ^:private lex-text (exec [_ (lex-str "\"") - ;; state &util/get-state - ;; :let [_ (prn 'PRE state)] token lex-string-body - _ (lex-str "\"") - ;; state &util/get-state - ;; :let [_ (prn 'POST state)] - ] + _ (lex-str "\"")] (return [::text token]))) (def ^:private lex-single-line-comment (exec [_ (lex-str "##") comment (lex-regex #"^([^\n]*)") - _ (lex-regex #"^(\n?)") - ;; :let [_ (prn 'comment comment)] - ] + _ (lex-regex #"^(\n?)")] (return [::comment comment]))) (def ^:private lex-multi-line-comment (exec [_ (lex-str "#(") - ;; :let [_ (prn 'OPEN)] - ;; comment (lex-regex #"^(#\(.*\)#)") comment (try-all-m [(lex-regex #"(?is)^((?!#\().)*?(?=\)#)") (exec [pre (lex-regex #"(?is)^(.+?(?=#\())") - ;; :let [_ (prn 'PRE pre)] [_ inner] lex-multi-line-comment - ;; :let [_ (prn 'INNER inner)] - post (lex-regex #"(?is)^(.+?(?=\)#))") - ;:let [_ (prn 'POST post)] - ] + post (lex-regex #"(?is)^(.+?(?=\)#))")] (return (str pre "#(" inner ")#" post)))]) - ;; :let [_ (prn 'COMMENT comment)] - _ (lex-str ")#") - ;; :let [_ (prn 'CLOSE)] - ;; :let [_ (prn 'multi-comment comment)] - ] + _ (lex-str ")#")] (return [::comment comment]))) (def ^:private lex-comment diff --git a/src/lux/parser.clj b/src/lux/parser.clj index d25208dc5..bb7b0f212 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -60,22 +60,6 @@ ?elems)] (return [::form =elems]))) -;; (defparser ^:private parse-get -;; [::&lexer/list ([[::&lexer/ident "get@"] [::&lexer/tag ?tag] ?record] :seq)] -;; (exec [=record (apply-m parse-token (list ?record))] -;; (return [::get ?tag =record]))) - -;; (defparser ^:private parse-remove -;; [::&lexer/list ([[::&lexer/ident "remove@"] [::&lexer/tag ?tag] ?record] :seq)] -;; (exec [=record (apply-m parse-token (list ?record))] -;; (return [::remove ?tag =record]))) - -;; (defparser ^:private parse-set -;; [::&lexer/list ([[::&lexer/ident "set@"] [::&lexer/tag ?tag] ?value ?record] :seq)] -;; (exec [=value (apply-m parse-token (list ?value)) -;; =record (apply-m parse-token (list ?record))] -;; (return [::set ?tag =value =record]))) - (def ^:private parse-token (try-all-m [parse-bool parse-int |