diff options
Diffstat (limited to 'src/lux')
| -rw-r--r-- | src/lux/analyser.clj | 823 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 937 | ||||
| -rw-r--r-- | src/lux/lexer.clj | 172 | ||||
| -rw-r--r-- | src/lux/parser.clj | 230 | ||||
| -rw-r--r-- | src/lux/type.clj | 148 | ||||
| -rw-r--r-- | src/lux/util.clj | 168 |
6 files changed, 2478 insertions, 0 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj new file mode 100644 index 000000000..115a943c9 --- /dev/null +++ b/src/lux/analyser.clj @@ -0,0 +1,823 @@ +(ns lux.analyser + (:refer-clojure :exclude [resolve]) + (:require (clojure [string :as string] + [template :refer [do-template]]) + [clojure.core.match :refer [match]] + (lux [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]] + [parser :as &parser] + [type :as &type]))) + +(declare analyse-form + ->tokens + tokens->clojure) + +;; [Util] +(defn ^:private annotated [form type] + {:form form + :type type}) + +(defn fresh-env [id] + {:id id + :counter 0 + :mappings {} + :closure/id 0}) + +(def ^:private module-name + (fn [state] + [::&util/ok [state (:name state)]])) + +(defn ^:private define [name desc] + (fn [state] + [::&util/ok [(-> state + (assoc-in [:defs (:name state) name] desc) + (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)]])) + +(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)]])) + +(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) + (assoc-in [:lambda-scope 1] 0)))] + (match =return + [::&util/ok [?state ?value]] + [::&util/ok [(assoc ?state :lambda-scope (:lambda-scope state)) ?value]] + + _ + =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])) + =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]))))) + ?value]] + + _ + =return)))) + +(def ^:private scope + (fn [state] + [::&util/ok [state (get-in state [:lambda-scope 0])]])) + +(defn ^:private with-local [name type body] + (fn [state] + (let [=return (body (update-in state [:env] + #(cons (-> (first %) + (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]]) + + _ + =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] + ;; (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) + new-top (reduce (fn [frame [name type]] + (-> frame + (update-in [:counter] inc) + (assoc-in [:mappings name] (annotated [::local frame-id (:counter frame)] type)))) + (update-in (fresh-env frame-id) [:counter] inc) + (map vector args-vars args-types))] + (conj outer new-top)))) + =return (body state*) + ;; _ (prn '=return =return) + ] + (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]]]) + + _ + =return))))) + +(defn ^:private import-class [long-name short-name] + (fn [state] + (let [=class (annotated [::class long-name] [::&type/object long-name []])] + [::&util/ok [(update-in state [:imports] merge {long-name =class, + short-name =class}) + nil]]))) + +(defn ^:private require-module [name alias] + (fn [state] + [::&util/ok [(assoc-in state [:deps alias] name) + 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) + (assoc-in [:mappings ident] register*))])) + +(defn ^:private resolve [ident] + (fn [state] + (if-let [[_ ?alias ?binding] (re-find #"^(.*)/(.*)$" ident)] + (let [?module (get-in state [:deps ?alias])] + ;; (prn 'resolve ?module ?alias ?binding) + [::&util/ok [state (annotated [::global ?module ?binding] ::&type/nothing)]]) + (let [;; _ (prn 'resolve/_1 ident) + [inner outer] (split-with #(nil? (get-in % [:mappings ident])) (:env state)) + ;; _ (prn ident '[inner outer] [inner outer]) + ;; _ (prn 'resolve/_2 '[inner outer] [inner outer]) + ] + (cond (empty? inner) + [::&util/ok [state (-> state :env first :mappings (get ident))]] + + (empty? outer) + (if-let [global|import (or (get-in state [:defs-env ident]) + (get-in state [:imports ident]))] + (do ;; (prn 'resolve/_3 'global|import global|import) + [::&util/ok [state global|import]]) + [::&util/failure (str "Unresolved identifier: " ident)]) + + :else + (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/_4 '[=local inner*] =local inner*) + ] + [::&util/ok [(assoc state :env (concat inner* outer)) =local]]))) + ))) + +(defmacro ^:private defanalyser [name match return] + `(def ~name + (fn [{[token# & left#] :forms :as state#}] + (match token# + ~match + (~return (assoc state# :forms left#)) + _# + (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) + ] + (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]))))) + +(do-template [<name> <tag> <class>] + (defanalyser <name> + [<tag> ?value] + (return (annotated [::literal ?value] [::&type/object <class> []]))) + + analyse-boolean ::&parser/boolean "java.lang.Boolean" + analyse-int ::&parser/int "java.lang.Integer" + analyse-float ::&parser/float "java.lang.Float" + analyse-char ::&parser/char "java.lang.Character" + analyse-string ::&parser/string "java.lang.String" + ) + +(defanalyser analyse-variant + [::&parser/variant ?tag ?data] + (exec [;; :let [_ (prn 'analyse-variant [?tag ?value])] + =data (map-m analyse-form* ?data) + ;; :let [_ (prn '=value =value)] + ] + (return (annotated [::variant ?tag =data] [::&type/variant ?tag (map :type =data)])))) + +(defanalyser analyse-tuple + [::&parser/tuple ?elems] + (exec [=elems (map-m analyse-form* ?elems)] + (return (annotated [::tuple =elems] [::&type/tuple (mapv :type =elems)])))) + +(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))) + +(defanalyser analyse-access + [::&parser/static-access ?target ?member] + (exec [=target (resolve ?target)] + (match (:form =target) + [::class ?class] + (return (annotated [::static-access ?class ?member] ::&type/nothing))))) + +(defn extract-ident [ident] + (match ident + [::&parser/ident ?ident] + (return ?ident) + + _ + (fail ""))) + +(defn extract-class [x] + (match x + [::class ?class] + (return ?class) + + _ + (fail ""))) + +(defn class-type [x] + (match x + [::&type/object ?class []] + (return ?class) + + _ + (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)) + :dynamic (not (java.lang.reflect.Modifier/isStatic (.getModifiers =field)))))] + [(.getDeclaringClass =field) (.getType =field)]))] + (exec [=type (&type/class->type type)] + (return [(.getName owner) =type])) + (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)) + :dynamic (not (java.lang.reflect.Modifier/isStatic (.getModifiers =method)))))] + [(.getDeclaringClass =method) =method]))] + (map-m (fn [[owner method]] + (exec [=method (&type/method->type method)] + (return [(.getName owner) =method]))) + methods) + (fail (str "Method does not exist: " target method mode)))) + +(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) + (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)))) + )) + +(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)] + ;; :let [_ (prn '=args =args)] + ] + (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] + (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)] + ] + (return (annotated [::if =test =then =else] ::&type/nothing)))) + +(defanalyser analyse-do + [::&parser/do ?exprs] + (exec [=exprs (map-m analyse-form* ?exprs)] + (return (annotated [::do =exprs] (-> =exprs last :type))))) + +(let [fold-branches (fn [struct entry] + (let [struct* (clojure.core.match/match (nth entry 0) + [::pm-text ?text] + (clojure.core.match/match (:type struct) + ::text-tests (update-in struct [:patterns ?text] (fn [bodies] + (if bodies + (conj bodies (nth entry 1)) + #{(nth entry 1)}))) + nil (-> struct + (assoc :type ::text-tests) + (assoc-in [:patterns ?text] #{(nth entry 1)})) + _ (assert false "Can't do match.")) + [::pm-variant ?tag ?members] + (clojure.core.match/match (:type struct) + ::adt (update-in struct [:patterns] + (fn [branches] + (if-let [{:keys [arity cases]} (get branches ?tag)] + (if (= arity (count ?members)) + (-> branches + (update-in [?tag :cases] conj {:case ?members + :body (nth entry 1)}) + (update-in [?tag :branches] conj (nth entry 1))) + (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity))) + (assoc branches ?tag {:arity (count ?members) + :cases [{:case ?members + :body (nth entry 1)}] + :branches #{(nth entry 1)}})))) + nil (-> struct + (assoc :type ::adt) + (assoc-in [:patterns ?tag] {:arity (count ?members) + :cases [{:case ?members + :body (nth entry 1)}] + :branches #{(nth entry 1)}})) + _ (assert false "Can't do match.")) + + [::pm-local ?local] + (update-in struct [:defaults] conj [::default ?local (nth entry 1)]))] + (update-in struct* [:branches] conj (nth entry 1)))) + base-struct {:type nil + :patterns {} + :defaults [] + :branches #{}} + generate-branches (fn generate-branches [data] + (let [branches* (reduce fold-branches 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*) + ::text-tests branches* + ::adt (do (assert (<= (count (:defaults branches*)) 1)) + {:type ::adt* + :patterns (into {} (for [[?tag ?struct] (:patterns branches*) + ;; :let [_ (prn '(:patterns branches*) ?tag ?struct)] + ] + [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)] + (map #(vector % body) case)))] + (map generate-branches grouped-parts)) + :branches (:branches ?struct)}])) + :default (-> branches* :defaults first) + :branches (:branches branches*)}) + nil {:type ::defaults, + :stores (reduce (fn [total [_ ?store ?body]] + (update-in total [?store] (fn [mapping] + (if mapping + (conj mapping ?body) + #{?body})))) + {} + (:defaults branches*)) + :branches (:branches branches*)}))) + 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] + '())) + ->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] + ))] + (defn ->decision-tree [$scope $base branches] + (let [;; Step 1: Get all vars + vars+body (for [branch branches] + (clojure.core.match/match branch + [::&parser/case-branch ?pattern ?body] + [(get-vars ?pattern) ?body])) + max-registers (reduce max 0 (map (comp count first) vars+body)) + ;; Step 2: Analyse 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 + 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])]) + [$base {}] branch-vars)]] + (clojure.core.match/match branch + [::&parser/case-branch ?pattern ?body] + [(->instructions locals ?pattern) ?body])) + ;; _ (prn branches**) + ;; Step 5: Re-structure branching + ] + [max-registers branch-mappings (generate-branches branches**)]))) + +(defanalyser analyse-case + [::&parser/case ?variant ?branches] + (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 [?branch] + (match ?branch + [::&parser/case-branch [::&parser/ident ?name] ?body] + (exec [=body (with-locals {?name (annotated [::local $scope $base] [::&type/object "java.lang.Object" []])} + (analyse-form* ?body))] + (return [::&parser/case-branch [::&parser/ident ?name] =body])) + + [::&parser/case-branch [::&parser/variant ?tag ?members] ?body] + (exec [[_ locals+] (reduce-m (fn member-fold [[$local locals-map] ?member] + (match ?member + [::&parser/ident ?name] + (return [(inc $local) (assoc locals-map ?name (annotated [::local $scope $local] [::&type/object "java.lang.Object" []]))]) + + [::&parser/variant ?subtag ?submembers] + (reduce-m member-fold [$local locals-map] ?submembers) + + _ + (return [$local locals-map]) + )) + [$base {}] + ?members) + ;; :let [_ (prn 'analyse-case 'locals+ locals+)] + =body (with-locals locals+ + (analyse-form* ?body)) + ;; :let [_ (prn 'analyse-case '=body =body)] + ] + (return [::&parser/case-branch [::&parser/variant ?tag ?members] =body])))) + ?branches)] + (return (->decision-tree $scope $base =branches))) + ;; :let [_ (prn 'analyse-case '[registers mappings tree] [registers mappings tree])] + ] + (return (annotated [::case (dec $base) =variant registers mappings tree] ::&type/nothing)))) + +(defanalyser analyse-let + [::&parser/let ?label ?value ?body] + (exec [=value (analyse-form* ?value) + idx next-local-idx + =body (with-local ?label =value + (analyse-form* ?body))] + (return (annotated [::let idx ?label =value =body] (:type =body))))) + +(defanalyser analyse-defclass + [::&parser/defclass ?name ?fields] + (let [=members {:fields (into {} (for [[class field] ?fields] + [field {:access ::public + :type class}]))} + =class [::class ?name =members]] + (exec [name module-name] + (return (annotated [::defclass [name ?name] =members] ::&type/nothing))))) + +(defanalyser analyse-definterface + [::&parser/definterface ?name ?members] + (let [=members {:methods (into {} (for [[method [inputs output]] ?members] + [method {:access ::public + :type [inputs output]}]))} + =interface [::interface ?name =members]] + (exec [name module-name] + (return (annotated [::definterface [name ?name] =members] ::&type/nothing))))) + +(defanalyser analyse-def + [::&parser/def ?usage ?value] + (match ?usage + [::&parser/ident ?name] + (exec [=value (with-scope ?name + (analyse-form* ?value)) + _ (define ?name {:mode ::constant + :access ::public + :type (:type =value)})] + (return (annotated [::def ?name =value] ::&type/nothing))) + + [::&parser/fn-call [::&parser/ident ?name] ?args] + (let [args (for [a ?args] + (match a + [::&parser/ident ?ident] + ?ident))] + (exec [[=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 ?name {:mode ::function + :access ::public + :type =function})] + (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)] + [=function =args =return] (within :types (&type/fresh-function (count ?args))) + ;; :let [_ (prn '[=function =args =return] [=function =args =return])] + ;; :let [_ (prn 'PRE/?body ?body)] + ;; _env (fn [state] [::&util/ok [state (:env state)]]) + ;; :let [_ (prn 'analyse-lambda _env)] + [=scope =frame =body] (with-fresh-env [?args =args] + (analyse-form* ?body)) + ;; :let [_ (prn '=body =body)] + =function (within :types (exec [_ (&type/solve =return (:type =body))] + (&type/clean =function))) + ;; :let [_ (prn '=function =function)] + ] + (return (annotated [::lambda =scope =frame ?args =body] =function)))) + +(defanalyser analyse-import + [::&parser/import ?class] + (exec [_ (import-class ?class (last (string/split ?class #"\.")))] + (return (annotated [::import ?class] ::&type/nothing)))) + +(defanalyser analyse-require + [::&parser/require ?file ?alias] + (let [;; _ (prn `[require ~?file ~?alias]) + module-name (re-find #"[^/]+$" ?file) + ;; _ (prn 'module-name module-name) + ] + (exec [_ (require-module module-name ?alias)] + (return (annotated [::require ?file ?alias] ::&type/nothing))))) + +(defanalyser analyse-quote + [::&parser/quote ?quoted] + (return (annotated [::quote ?quoted] ::&type/nothing))) + +(def analyse-form + (try-all-m [analyse-boolean + analyse-int + analyse-float + analyse-char + analyse-string + analyse-variant + analyse-tuple + analyse-lambda + analyse-ident + analyse-access + analyse-fn-call + analyse-if + analyse-do + analyse-case + analyse-let + analyse-defclass + analyse-definterface + analyse-def + analyse-defmacro + analyse-import + analyse-require + analyse-quote])) + +;; [Interface] +(defn analyse [module-name tokens] + (match ((repeat-m (with-scope module-name + analyse-form)) {:name module-name, + :forms tokens + :deps {} + :imports {} + :defs {} + :defs-env {} + :lambda-scope [[] 0] + :env (list (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))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj new file mode 100644 index 000000000..d4d7431a2 --- /dev/null +++ b/src/lux/compiler.clj @@ -0,0 +1,937 @@ +(ns lux.compiler + (:refer-clojure :exclude [compile]) + (:require [clojure.string :as string] + [clojure.set :as set] + [clojure.core.match :refer [match]] + (lux [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]) + :reload) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +(declare compile-form + compile) + +;; [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) + ) + +(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") + +(defmacro ^:private defcompiler [name match body] + `(defn ~name [~'*state*] + (let [~'*class-name* (:class-name ~'*state*) + ~'*writer* (:writer ~'*state*) + ~'*parent* (:parent ~'*state*) + ~'*type* (:type (:form ~'*state*))] + ;; (prn '~name (:form (:form ~'*state*))) + (match (:form (:form ~'*state*)) + ~match + (do ~body + true) + _# + false)))) + +(defn ^:private unwrap-ident [ident] + (match ident + [::&parser/ident ?label] + ?label)) + +(defn ^:private unwrap-tagged [ident] + (match ident + [::&parser/tagged ?tag ?data] + [?tag ?data])) + +(defn ^:private ->class [class] + (string/replace class #"\." "/")) + +(def ^:private ->package ->class) + +(defn ^:private ->type-signature [class] + (case class + "Void" "V" + ;; else + (str "L" (->class class) ";"))) + +(defn ^:private ->java-sig [type] + (match type + ::&type/any + (->java-sig [::&type/object "java.lang.Object" []]) + + [::&type/object ?name []] + (->type-signature ?name) + + [::&type/variant ?tag ?value] + (->type-signature +variant-class+) + + [::&type/function ?args ?return] + (->java-sig [::&type/object "test2/Function" []]))) + +(defn ^:private method->sig [method] + (match method + [::&type/function ?args ?return] + (str "(" (apply str (map ->java-sig ?args)) ")" + (if (= ::&type/nothing ?return) + "V" + (->java-sig ?return))))) + +;; [Utils/Compilers] +(defcompiler ^:private compile-literal + [::&analyser/literal ?literal] + (cond (instance? java.lang.Integer ?literal) + (doto *writer* + (.visitTypeInsn Opcodes/NEW (->class "java.lang.Integer")) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?literal) + (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Integer") "<init>" "(I)V")) + + (instance? java.lang.Float ?literal) + (doto *writer* + (.visitTypeInsn Opcodes/NEW (->class "java.lang.Float")) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?literal) + (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Float") "<init>" "(F)V")) + + (instance? java.lang.Character ?literal) + (doto *writer* + (.visitTypeInsn Opcodes/NEW (->class "java.lang.Character")) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?literal) + (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Character") "<init>" "(C)V")) + + (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) + (.visitLdcInsn *writer* ?literal) + + :else + (assert false (str "[Unknown literal type] " ?literal " : " (class ?literal))))) + +(defcompiler ^:private compile-tuple + [::&analyser/tuple ?elems] + (let [num-elems (count ?elems)] + (let [tuple-class (str "test2/Tuple" num-elems)] + (doto *writer* + (.visitTypeInsn Opcodes/NEW tuple-class) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V")) + (dotimes [idx num-elems] + (.visitInsn *writer* Opcodes/DUP) + (compile-form (assoc *state* :form (nth ?elems idx))) + (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str "_" idx) "Ljava/lang/Object;"))))) + +(defcompiler ^:private compile-local + [::&analyser/local ?env ?idx] + (do ;; (prn 'LOCAL ?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 "$" ?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*) + )))) + +;; (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) + (match (:form ?fn) + [::&analyser/global ?owner-class ?fn-name] + (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;" + clo-field-sig (->type-signature "java.lang.Object") + counter-sig "I" + num-args (count ?args) + 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) "$" (normalize-ident ?fn-name))] + (doto *writer* + (.visitTypeInsn Opcodes/NEW call-class) + (.visitInsn Opcodes/DUP) + (-> (doto (.visitLdcInsn (-> ?args count dec int)) + ;; (.visitInsn Opcodes/ICONST_0) + (-> (do (compile-form (assoc *state* :form arg))) + (->> (doseq [arg (butlast ?args)])))) + (->> (when (> (count ?args) 1)))) + (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" signature) + (do (compile-form (assoc *state* :form (last ?args)))) + (.visitMethodInsn Opcodes/INVOKEINTERFACE "test2/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 "test2/Function" "apply" apply-signature)))) + ))) + +(defcompiler ^:private compile-static-field + [::&analyser/static-field ?owner ?field] + (do ;; (prn 'compile-static-field ?owner ?field) + ;; (assert false) + (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)) + (doto *writer* + (.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))) + )) + +(defcompiler ^:private compile-dynamic-method + [::&analyser/dynamic-method ?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) + )) + )) + +(defcompiler ^:private compile-if + [::&analyser/if ?test ?then ?else] + (let [else-label (new Label) + end-label (new Label)] + ;; (println "PRE") + (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)) + (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 + [::&analyser/do ?exprs] + (do (doseq [expr (butlast ?exprs)] + (compile-form (assoc *state* :form expr)) + (.visitInsn *writer* Opcodes/POP)) + (compile-form (assoc *state* :form (last ?exprs))))) + +(let [+tag-sig+ (->type-signature "java.lang.String") + variant-class* (->class +variant-class+) + oclass (->class "java.lang.Object") + +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) + (match decision-tree + [::test-text ?text $body] + (let [$else (new Label)] + (doto writer + ;; object + (.visitInsn Opcodes/DUP) ;; object, object + (.visitLdcInsn ?text) ;; object, object, text + (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B + (.visitJumpInsn Opcodes/IFEQ $else) ;; object + (.visitInsn Opcodes/POP) ;; + (.visitJumpInsn Opcodes/GOTO next-label) + (.visitLabel $else) + (-> (doto (.visitInsn Opcodes/POP)) + (->> (dotimes [_ (inc cleanup-level)]))) + (.visitJumpInsn Opcodes/GOTO default-label))) + + [::store [::&analyser/local _ ?idx] $body] + (doto writer + (.visitVarInsn Opcodes/ASTORE ?idx) + (-> (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (->> (when (nil? next-label))))) + + [::test-adt ?branches ?cases] + (doto writer + ;; object + (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant + (.visitInsn Opcodes/DUP) ;; variant, variant + (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag + (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag + (.visitLdcInsn ?tag) ;; variant, tag, tag, text + (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B + (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag + (.visitInsn Opcodes/POP) ;; variant + (do (let [arity (-> ?subcases first (nth 2) count) + tuple-class (str "test2/Tuple" arity) + ;; _ (prn ?tag arity tuple-class) + ] + (when (> arity 0) + (doto writer + (.visitInsn Opcodes/DUP) ;; variant, variant + (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" +tuple-field-sig+) ;; variant, object + (.visitTypeInsn Opcodes/CHECKCAST tuple-class) ;; variant, tuple + )) + (doseq [subcase ?subcases + :let [else-label (new Label)]] + (match subcase + [::subcase $body ?subseq] + (do (when (not (empty? ?subseq)) + (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq))) + :let [next-label (new Label)]] + (doto writer + (.visitInsn Opcodes/DUP) ;; variant, tuple, tuple + (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?subidx) +tuple-field-sig+) ;; variant, tuple, object + (compile-decision-tree mappings cleanup-level next-label else-label ?subpart) ;; variant, tuple + (.visitLabel next-label)))) + (doto writer + (-> (doto (.visitInsn Opcodes/POP)) + (->> (dotimes [_ (+ cleanup-level (if (> arity 0) 2 1))]))) ;; + (.visitJumpInsn Opcodes/GOTO (or next-label (get mappings $body))) + (.visitLabel else-label))) + )) + )) + ;; 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)]]))) + (-> (doto (.visitInsn Opcodes/POP)) + (->> (dotimes [_ (+ cleanup-level 2)]))) + (.visitJumpInsn Opcodes/GOTO default-label))) + )) + +(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) + ] + [[::store ?local ?body] #{?body}]) + + ::&analyser/text-tests + (concat (for [[?text ?supports] (:patterns head) + ?body (set/intersection branches ?supports) + ;; :when (set/subset? branches ?supports) + ] + [[::test-text ?text ?body] #{?body}]) + (for [[_ ?local ?body] (:defaults head) + :when (contains? branches ?body)] + [[::store ?local ?body] #{?body}])) + + ::&analyser/adt* + (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 [?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})] + [[::store ?local ?body] #{?body}]) + '()))) + )] + (for [[step branches*] expanded + tail* (sequence-parts branches* tail) + ;; :let [_ (.print System/out (prn-str 'tail* tail*))] + ] + (cons step tail*))))) + +(def !case-vars (atom -1)) + +(let [oclass (->class "java.lang.Object") + 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) + (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)) + (.visitLabel *writer* 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 (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))] + (compile-decision-tree *writer* mappings* 0 nil default-label decision-tree)) + (.visitLabel *writer* default-label) + (when (not 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) + (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* + (.visitVarInsn Opcodes/ASTORE ?idx) + (.visitLabel start-label)) + (assert (compile-form (assoc *state* :form ?body)) "CAN't COMPILE LET-BODY") + (.visitLabel *writer* end-label))) + +(defn ^:private compile-method-function [writer class-name fn-name num-args body *state*] + (let [outer-class (->class class-name) + 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 (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") + (str "()" "V"))] + (.visitInnerClass writer current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) + (let [=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 ["test2/Function"])) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) + (.visitEnd)) + (->> (when (not= 0 num-captured))))) + =impl (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "impl" real-signature nil nil) + (.visitCode) + (->> (assoc *state* :form body :writer) compile-form) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + =init (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitFieldInsn Opcodes/PUTFIELD current-class "_counter" counter-sig) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (+ clo_idx 2)) + (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig)) + (->> (let [field-name (str "_" clo_idx)] + (doto (.visitField =class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil) + (.visitEnd))) + (dotimes [clo_idx num-captured])))) + (->> (when (not= 0 num-captured)))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + =method (let [default-label (new Label) + branch-labels (for [_ (range num-captured)] + (new Label))] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil) + (.visitCode) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig) + (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels)) + (-> (doto (.visitLabel branch-label) + (.visitTypeInsn Opcodes/NEW current-class) + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig) + (.visitInsn Opcodes/ICONST_1) + (.visitInsn Opcodes/IADD) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig)) + (->> (dotimes [clo_idx current-captured]))) + (.visitVarInsn Opcodes/ALOAD 1) + (-> (.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])] + ]))) + (.visitLabel default-label) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig)) + (->> (dotimes [clo_idx num-captured])))) + (->> (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))) + _ (.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] + (let [outer-class (->class class-name) + datum-sig (->type-signature "java.lang.Object") + current-class (str outer-class "$" ?name)] + (.visitInnerClass writer current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) + (let [=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 ["test2/Function"])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) + (doto (.visitEnd))) + (-> (.visitMethod Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + (doto (.visitCode) + (->> (assoc state :form body :writer) compile-form) + (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))) + (.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 + [::&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*))) + ))) + +(defn ^:private captured? [form] + (match form + [::&analyser/captured ?closure-id ?captured-id ?source] + true + _ + false)) + +(defcompiler ^:private compile-lambda + [::&analyser/lambda ?scope ?frame ?args ?body] + (let [;; _ (prn '[?scope ?frame] ?scope ?frame) + num-args (count ?args) + outer-class (->class *class-name*) + 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)) + num-captured (dec num-args) + init-signature (str "(" (apply str (repeat (->> (:mappings ?frame) + (map (comp :form second)) + (filter captured?) + count) + clo-field-sig)) + (if (not= 0 num-captured) + (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 ["test2/Function"])) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str "__" ?captured-id)]) + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] (:mappings ?frame) + :when (captured? (:form ?captured))]))) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) + (.visitEnd)) + (->> (when (not= 0 num-captured))))) + =init (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD current-class captured-name clo-field-sig)) + (->> (let [captured-name (str "__" ?captured-id)]) + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] (:mappings ?frame) + :when (captured? (:form ?captured))]))) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD (inc (count (:mappings ?frame)))) + (.visitFieldInsn Opcodes/PUTFIELD current-class "_counter" counter-sig) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset)) + (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig)) + (->> (let [field-name (str "_" clo_idx)] + (doto (.visitField =class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil) + (.visitEnd))) + (dotimes [clo_idx num-captured]) + (let [offset (+ 2 (count (:mappings ?frame)))])))) + (->> (when (not= 0 num-captured)))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + =method (let [default-label (new Label) + branch-labels (for [_ (range num-captured)] + (new Label))] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig) + (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels)) + (-> (doto (.visitLabel branch-label) + (.visitTypeInsn Opcodes/NEW current-class) + (.visitInsn Opcodes/DUP) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD current-class (str "__" capt_idx) clo-field-sig)) + (->> (dotimes [capt_idx (count (:mappings ?frame))]))) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig) + (.visitInsn Opcodes/ICONST_1) + (.visitInsn Opcodes/IADD) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig)) + (->> (dotimes [clo_idx current-captured]))) + (.visitVarInsn Opcodes/ALOAD 1) + (-> (.visitInsn Opcodes/ACONST_NULL) + (->> (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])] + ]))) + (.visitLabel default-label) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig)) + (->> (dotimes [clo_idx num-captured])))) + (->> (when (not= 0 num-captured)))) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL current-class "impl" real-signature) + (.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) + compile-form) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (.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) + ;; (filter captured?))) + (doto *writer* + (.visitTypeInsn Opcodes/NEW current-class) + (.visitInsn Opcodes/DUP) + (-> (do (compile-form (assoc *state* :form ?source))) + (->> (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] (:mappings ?frame) + :when (captured? (:form ?captured))]))) + (-> (doto (.visitInsn Opcodes/ICONST_0) + ;; (.visitInsn Opcodes/ICONST_0) + (-> (.visitInsn Opcodes/ACONST_NULL) + (->> (doseq [_ (butlast ?args)])))) + (->> (when (> (count ?args) 1)))) + (.visitMethodInsn Opcodes/INVOKESPECIAL current-class "<init>" init-signature)) + )) + +(defcompiler ^:private compile-defclass + [::&analyser/defclass [?package ?name] ?members] + (let [parent-dir (->package ?package) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str parent-dir "/" ?name) nil "java/lang/Object" nil))] + (doseq [[field props] (:fields ?members)] + (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil) + (.visitEnd))) + (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (.visitEnd =class) + (.mkdirs (java.io.File. parent-dir)) + (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] + (let [parent-dir (->package ?package) + =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE ;; Opcodes/ACC_ABSTRACT + ) + (str parent-dir "/" ?name) nil "java/lang/Object" nil))] + (doseq [[?method ?props] (:methods ?members) + :let [[?args ?return] (:type ?props) + signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]] + (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) + (.visitEnd =interface) + (.mkdirs (java.io.File. parent-dir)) + (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] + (let [variant-class* (->class +variant-class+)] + ;; (prn 'compile-variant ?tag ?value) + (doto *writer* + (.visitTypeInsn Opcodes/NEW variant-class*) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?tag) + (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (->type-signature "java.lang.String")) + (.visitInsn Opcodes/DUP)) + (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;")) + )) + +(defcompiler compile-import + [::&analyser/import ?class] + nil) + +(defcompiler compile-require + [::&analyser/require ?file ?alias] + (let [module-name (re-find #"[^/]+$" ?file) + ;; _ (prn 'module-name module-name) + source-code (slurp (str 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)) + +(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 + compile-local + compile-captured + compile-global + compile-call + compile-static-field + compile-dynamic-field + compile-static-method + compile-dynamic-method + compile-if + compile-do + compile-case + compile-let + compile-lambda + compile-def + compile-defclass + compile-definterface + compile-import + compile-require + compile-quote]] + (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] +(defn compile [class-name inputs] + ;; (prn 'inputs inputs) + (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)) + 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 [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")) + ;; (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/lux/lexer.clj b/src/lux/lexer.clj new file mode 100644 index 000000000..a302e89ba --- /dev/null +++ b/src/lux/lexer.clj @@ -0,0 +1,172 @@ +(ns lux.lexer + (:require [clojure.template :refer [do-template]] + [clojure.core.match :refer [match]] + [lux.util :as &util :refer [exec return* return fail fail* + repeat-m try-m try-all-m]])) + +(declare lex-forms lex-list lex-tuple lex-record lex-tag) + +;; [Utils] +(defn ^:private lex-regex [regex] + (fn [text] + (if-let [[match] (re-find regex text)] + (return* (.substring text (.length match)) match) + (fail* (str "Pattern failed: " regex " -- " text))))) + +(defn ^:private lex-regex2 [regex] + (fn [text] + (if-let [[match tok1 tok2] (re-find regex text)] + (return* (.substring text (.length match)) [tok1 tok2]) + (fail* (str "Pattern failed: " regex " -- " text))))) + +(defn ^:private lex-str [prefix] + (fn [text] + (if (.startsWith text prefix) + (return* (.substring text (.length prefix)) prefix) + (fail* (str "String failed: " prefix " -- " text))))) + +(defn ^:private escape-char [escaped] + (condp = escaped + "\\t" (return "\t") + "\\b" (return "\b") + "\\n" (return "\n") + "\\r" (return "\r") + "\\f" (return "\f") + "\\\"" (return "\"") + "\\\\" (return "\\") + ;; else + (fail (str "Unknown escape character: " escaped)))) + +(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))] + ] + (return (str prefix unescaped postfix))) + (lex-regex #"(?s)^([^\"\\]*)")])) + +;; [Lexers] +(def ^:private lex-white-space (lex-regex #"^(\s+)")) + +(def +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~\?]*)") + +(do-template [<name> <tag> <regex>] + (def <name> + (exec [token (lex-regex <regex>)] + (return [<tag> token]))) + + ^:private lex-boolean ::boolean #"^(true|false)" + ^:private lex-float ::float #"^(0|[1-9][0-9]*)\.[0-9]+" + ^:private lex-int ::int #"^(0|[1-9][0-9]*)" + ^:private lex-ident ::ident +ident-re+) + +(def ^:private lex-char + (exec [_ (lex-str "#\"") + token (try-all-m [(exec [escaped (lex-regex #"^(\\.)")] + (escape-char escaped)) + (lex-regex #"^(.)")]) + _ (lex-str "\"")] + (return [::char token]))) + +(def ^:private lex-string + (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)] + ] + (return [::string token]))) + +(def ^:private lex-single-line-comment + (exec [_ (lex-str "##") + comment (lex-regex #"^([^\n]*)") + _ (lex-regex #"^(\n?)") + ;; :let [_ (prn 'comment comment)] + ] + (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)] + ] + (return (str pre "#(" inner ")#" post)))]) + ;; :let [_ (prn 'COMMENT comment)] + _ (lex-str ")#") + ;; :let [_ (prn 'CLOSE)] + ;; :let [_ (prn 'multi-comment comment)] + ] + (return [::comment comment]))) + +(def ^:private lex-tag + (exec [_ (lex-str "#") + token (lex-regex +ident-re+)] + (return [::tag token]))) + +(def ^:private lex-form + (exec [_ (try-m lex-white-space) + form (try-all-m [lex-boolean + lex-float + lex-int + lex-char + lex-string + lex-ident + lex-tag + lex-list + lex-tuple + lex-record + lex-single-line-comment + lex-multi-line-comment]) + _ (try-m lex-white-space)] + (return form))) + +(def lex-forms + (exec [forms (repeat-m lex-form)] + (return (filter #(match % + [::comment _] + false + _ + true) + forms)))) + +(def ^:private lex-list + (exec [_ (lex-str "(") + members lex-forms + _ (lex-str ")")] + (return [::list members]))) + +(def ^:private lex-tuple + (exec [_ (lex-str "[") + members lex-forms + _ (lex-str "]")] + (return [::tuple members]))) + +(def ^:private lex-record + (exec [_ (lex-str "{") + members lex-forms + _ (lex-str "}")] + (return [::record members]))) + +;; [Interface] +(defn lex [text] + (match (lex-forms text) + [::&util/ok [?state ?forms]] + (if (empty? ?state) + ?forms + (assert false (str "Unconsumed input: " ?state))) + + [::&util/failure ?message] + (assert false ?message))) diff --git a/src/lux/parser.clj b/src/lux/parser.clj new file mode 100644 index 000000000..8d3cfb0dd --- /dev/null +++ b/src/lux/parser.clj @@ -0,0 +1,230 @@ +(ns lux.parser + (:require [clojure.template :refer [do-template]] + [clojure.core.match :refer [match]] + (lux [util :as &util :refer [exec return* return fail fail* + repeat-m try-m try-all-m map-m + apply-m]] + [lexer :as &lexer] + [type :as &type]))) + +(declare parse-form) + +;; [Utils] +(defmacro ^:private defparser [name match return] + `(def ~name + (fn [[token# & left#]] + (match token# + ~match + (~return left#) + _# + (fail* (str "Unmatched token: " token#)))))) + +;; [Parsers] +(do-template [<name> <input-tag> <output-tag> <method>] + (defparser <name> + [<input-tag> ?value] + (return [<output-tag> (<method> ?value)])) + + + ^:private parse-boolean ::&lexer/boolean ::boolean Boolean/parseBoolean + ^:private parse-int ::&lexer/int ::int Integer/parseInt + ^:private parse-float ::&lexer/float ::float Float/parseFloat + ) + +(defparser ^:private parse-char + [::&lexer/char ?value] + (return [::char (.charAt ?value 0)])) + +(defn ident->string [ident] + (match ident + [::&lexer/ident ?ident] + ?ident)) + +(defparser ^:private parse-ident + [::&lexer/ident ?ident] + (return [::ident ?ident])) + +(defparser ^:private parse-tuple + [::&lexer/tuple ?parts] + (exec [=parts (map-m (fn [arg] (apply-m parse-form (list arg))) + ?parts)] + (return [::tuple =parts]))) + +(defparser ^:private parse-record + [::&lexer/record ?parts] + (exec [=kvs (do (assert (even? (count ?parts))) + (map-m #(match % + ([[::&lexer/tag ?label] ?value] :seq) + (exec [=value (apply-m parse-form (list ?value))] + (return [?label =value]))) + (partition 2 ?parts)))] + (return [::record =kvs]))) + +(defparser ^:private parse-lambda + [::&lexer/list ([[::&lexer/ident "lambda"] [::&lexer/tuple ?args] ?body] :seq)] + (exec [=body (apply-m parse-form (list ?body))] + (return [::lambda (mapv ident->string ?args) =body]))) + +(defparser ^:private parse-def + [::&lexer/list ([[::&lexer/ident "def"] ?name ?body] :seq)] + (exec [=name (apply-m parse-form (list ?name)) + =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)) + =cases (map-m (fn [arg] + (match arg + [::&lexer/list ([[::&lexer/tag ?tag] ?data] :seq)] + (exec [=data (apply-m parse-form (list ?data))] + (return [::tagged ?tag =data])) + )) + ?cases)] + (return [::defdata =type =cases]))) + +(defparser ^:private parse-if + [::&lexer/list ([[::&lexer/ident "if"] ?test ?then ?else] :seq)] + (exec [=test (apply-m parse-form (list ?test)) + =then (apply-m parse-form (list ?then)) + =else (apply-m parse-form (list ?else))] + (return [::if =test =then =else]))) + +(defparser ^:private parse-do + [::&lexer/list ([[::&lexer/ident "do"] & ?exprs] :seq)] + (exec [=exprs (map-m #(apply-m parse-form (list %)) + ?exprs)] + (return [::do =exprs]))) + +(defparser ^:private parse-case + [::&lexer/list ([[::&lexer/ident "case"] ?variant & cases] :seq)] + (exec [=variant (apply-m parse-form (list ?variant)) + =branches (do (assert (even? (count cases))) + (map-m (fn [[destruct expr]] + (exec [=destruct (apply-m parse-form (list destruct)) + =expr (apply-m parse-form (list expr))] + (return [::case-branch =destruct =expr]))) + (partition 2 cases)))] + (return [::case =variant =branches]))) + +(defparser ^:private parse-let + [::&lexer/list ([[::&lexer/ident "let"] [::&lexer/ident ?label] ?value ?body] :seq)] + (exec [=value (apply-m parse-form (list ?value)) + =body (apply-m parse-form (list ?body))] + (return [::let ?label =value =body]))) + +(defparser ^:private parse-import + [::&lexer/list ([[::&lexer/ident "import"] [::&lexer/ident ?class]] :seq)] + (return [::import ?class])) + +(defparser ^:private parse-require + [::&lexer/list ([[::&lexer/ident "require"] [::&lexer/string ?file] [::&lexer/ident "as"] [::&lexer/ident ?alias]] :seq)] + (return [::require ?file ?alias])) + +(defparser ^:private parse-defclass + [::&lexer/list ([[::&lexer/ident "defclass"] [::&lexer/ident ?name] [::&lexer/tuple ?fields]] :seq)] + (let [fields (for [field ?fields] + (match field + [::&lexer/tuple ([[::&lexer/ident ?class] [::&lexer/ident ?field]] :seq)] + [?class ?field]))] + (return [::defclass ?name fields]))) + +(defparser ^:private parse-definterface + [::&lexer/list ([[::&lexer/ident "definterface"] [::&lexer/ident ?name] & ?members] :seq)] + (let [members (for [field ?members] + (match field + [::&lexer/list ([[::&lexer/ident ":"] [::&lexer/ident ?member] [::&lexer/list ([[::&lexer/ident "->"] [::&lexer/tuple ?inputs] ?output] :seq)]] :seq)] + [?member [(map ident->string ?inputs) (ident->string ?output)]]))] + (return [::definterface ?name members]))) + +(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)] + (exec [=record (apply-m parse-form (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-form (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-form (list ?value)) + =record (apply-m parse-form (list ?record))] + (return [::set ?tag =value =record]))) + +(defparser ^:private parse-access + [::&lexer/list ([[::&lexer/ident "::"] ?object ?call] :seq)] + (exec [=object (apply-m parse-form (list ?object)) + =call (apply-m parse-form (list ?call))] + (return [::access =object =call]))) + +(defparser ^:private parse-string + [::&lexer/string ?string] + (return [::string ?string])) + +(defparser ^:private parse-fn-call + [::&lexer/list ([?f & ?args] :seq)] + (exec [=f (apply-m parse-form (list ?f)) + =args (map-m (fn [arg] (apply-m parse-form (list arg))) + ?args)] + (return [::fn-call =f =args]))) + +(def ^:private parse-form + (try-all-m [parse-boolean + parse-int + parse-float + parse-char + parse-string + parse-ident + parse-tuple + parse-record + parse-lambda + parse-def + parse-defmacro + parse-defdata + parse-if + parse-do + parse-case + parse-let + parse-variant + parse-get + parse-set + parse-remove + parse-access + parse-defclass + parse-definterface + parse-import + parse-require + parse-fn-call])) + +;; [Interface] +(defn parse [text] + (match ((repeat-m parse-form) text) + [::&util/ok [?state ?forms]] + (if (empty? ?state) + ?forms + (assert false (str "Unconsumed input: " (pr-str ?state)))) + + [::&util/failure ?message] + (assert false ?message))) diff --git a/src/lux/type.clj b/src/lux/type.clj new file mode 100644 index 000000000..b29fcd5d1 --- /dev/null +++ b/src/lux/type.clj @@ -0,0 +1,148 @@ +(ns lux.type + (:refer-clojure :exclude [resolve]) + (:require [clojure.core.match :refer [match]] + [lux.util :as &util :refer [exec return* return fail fail* + repeat-m try-m try-all-m map-m + apply-m assert!]])) + +;; [Util] +(def ^:private success (return nil)) + +(defn ^:private resolve [id] + (fn [state] + (if-let [top+bottom (get-in state [::mappings id])] + [::&util/ok [state top+bottom]] + [::&util/failure (str "Unknown type-var: " id)]))) + +(defn ^:private update [id top bottom] + (fn [state] + (if-let [top+bottom (get-in state [::mappings id])] + [::&util/ok [(assoc-in state [::mappings id] [top bottom]) nil]] + [::&util/failure (str "Unknown type-var: " id)]))) + +;; [Interface] +(def +init+ {::counter 0 + ::mappings {}}) + +(def fresh-var + (fn [state] + (let [id (::counter state)] + [::&util/ok [(-> state + (update-in [::counter] inc) + (assoc-in [::mappings id] [::any ::nothing])) + [::var id]]]))) + +(defn fresh-function [num-args] + (exec [=args (map-m (constantly fresh-var) (range num-args)) + =return fresh-var + :let [=function [::function =args =return]]] + (return [=function =args =return]))) + +(defn solve [expected actual] + ;; (prn 'solve expected actual) + (match [expected actual] + [::any _] + success + + [_ ::nothing] + success + + [_ [::var ?id]] + (exec [[=top =bottom] (resolve ?id)] + (try-all-m [(exec [_ (solve expected =top)] + success) + (exec [_ (solve =top expected) + _ (solve expected =bottom) + _ (update ?id expected =bottom)] + success)])) + + [[::var ?id] _] + (exec [[=top =bottom] (resolve ?id)] + (try-all-m [(exec [_ (solve =bottom actual)] + success) + (exec [_ (solve actual =bottom) + _ (solve =top actual) + _ (update ?id =top actual)] + success)])) + + [[::primitive ?prim] _] + (let [as-obj (case ?prim + "boolean" [:lang.type/object "java.lang.Boolean" []] + "int" [:lang.type/object "java.lang.Integer" []] + "long" [:lang.type/object "java.lang.Long" []] + "char" [:lang.type/object "java.lang.Character" []] + "float" [:lang.type/object "java.lang.Float" []] + "double" [:lang.type/object "java.lang.Double" []])] + (solve as-obj actual)) + + [[::object ?eclass []] [::object ?aclass []]] + (if (.isAssignableFrom (Class/forName ?eclass) (Class/forName ?aclass)) + success + (fail (str "Can't solve types: " (pr-str expected actual)))) + + [_ _] + (fail (str "Can't solve types: " (pr-str expected actual))) + )) + +(defn pick-matches [methods args] + (if (empty? methods) + (fail "No matches.") + (try-all-m [(match (-> methods first second) + [::function ?args ?return] + (exec [_ (assert! (= (count ?args) (count args)) "Args-size doesn't match.") + _ (map-m (fn [[e a]] (solve e a)) (map vector ?args args))] + (return (first methods)))) + (pick-matches (rest methods) args)]))) + +(defn clean [type] + (match type + [::var ?id] + (exec [[=top =bottom] (resolve ?id)] + (clean =top)) + + [::function ?args ?return] + (exec [=args (map-m clean ?args) + =return (clean ?return)] + (return [::function =args =return])) + + ;; ::any + ;; (return [::object "java.lang.Object" []]) + + _ + (return type))) + +;; Java Reflection +(defn class->type [class] + (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" + (str (if-let [pkg (.getPackage class)] + (str (.getName pkg) ".") + "") + (.getSimpleName class)))] + (if (= "void" base) + (return ::nothing) + (let [base* (case base + ("boolean" "byte" "short" "int" "long" "float" "double" "char") + [::primitive base] + ;; else + [::object base []])] + (if arr-level + (return (reduce (fn [inner _] + [::array inner]) + base* + (range (/ (count arr-level) 2.0)))) + (return base*))) + + ))) + +(defn method->type [method] + (exec [=args (map-m class->type (seq (.getParameterTypes method))) + =return (class->type (.getReturnType method))] + (return [::function (vec =args) =return]))) + +(defn return-type [func] + (match func + [::function _ ?return] + (return ?return) + + _ + (fail (str "Type is not a function: " (pr-str func))))) diff --git a/src/lux/util.clj b/src/lux/util.clj new file mode 100644 index 000000000..5c792c2f3 --- /dev/null +++ b/src/lux/util.clj @@ -0,0 +1,168 @@ +(ns lux.util + (:require [clojure.string :as string] + [clojure.core.match :refer [match]])) + +;; [Interface] +;; [Interface/Utils] +(defn fail* [message] + [::failure message]) + +(defn return* [state value] + [::ok [state value]]) + +;; [Interface/Monads] +(defn fail [message] + (fn [_] + [::failure message])) + +(defn return [value] + (fn [state] + [::ok [state value]])) + +(defn bind [m-value step] + #(let [inputs (m-value %)] + ;; (prn 'bind/inputs inputs) + (match inputs + [::ok [?state ?datum]] + ((step ?datum) ?state) + + [::failure _] + inputs))) + +(defmacro exec [steps return] + (assert (not= 0 (count steps)) "The steps can't be empty!") + (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") + (reduce (fn [inner [label computation]] + (case label + :let `(let ~computation ~inner) + ;; :when (assert false "Can't use :when") + :when `(if ~computation + ~inner + zero) + ;; else + `(bind ~computation (fn [~label] ~inner)))) + return + (reverse (partition 2 steps)))) + +;; [Interface/Combinators] +(defn try-m [monad] + (fn [state] + (match (monad state) + [::ok [?state ?datum]] + (return* ?state ?datum) + + [::failure _] + (return* state nil)))) + +(defn repeat-m [monad] + (fn [state] + (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))))) + + [::failure ?message] + (do ;; (println "Failed at last:" ?message) + (return* state '()))))) + +(defn try-all-m [monads] + (fn [state] + (if (empty? monads) + (fail* "No alternative worked!") + (let [output ((first monads) state)] + (match output + [::ok _] + output + :else + (if-let [monads* (seq (rest monads))] + ((try-all-m monads*) state) + output) + ))))) + +(defn map-m [f inputs] + (if (empty? inputs) + (return '()) + (exec [output (f (first inputs)) + 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) + (let [output (monad call-state)] + ;; (prn 'apply-m/output output) + (match output + [::ok [?state ?datum]] + [::ok [state ?datum]] + + [::failure _] + output)))) + +(defn assert! [test message] + (if test + (return nil) + (fail message))) + +(defn comp-m [f-m g-m] + (exec [temp g-m] + (f-m temp))) + +(defn pass [m-value] + (fn [state] + m-value)) + +(def get-state + (fn [state] + (return* state state))) + +(defn within [slot monad] + (fn [state] + (let [=return (monad (get state slot))] + (match =return + [::ok [?state ?value]] + [::ok [(assoc state slot ?state) ?value]] + _ + =return)))) + +(defn ^:private normalize-char [char] + (case char + \* "_ASTER_" + \+ "_PLUS_" + \- "_DASH_" + \/ "_SLASH_" + \\ "_BSLASH_" + \_ "_UNDERS_" + \% "_PERCENT_" + \$ "_DOLLAR_" + \' "_QUOTE_" + \` "_BQUOTE_" + \@ "_AT_" + \^ "_CARET_" + \& "_AMPERS_" + \= "_EQ_" + \! "_BANG_" + \? "_QM_" + \: "_COLON_" + \; "_SCOLON_" + \. "_PERIOD_" + \, "_COMMA_" + \< "_LT_" + \> "_GT_" + \~ "_TILDE_" + ;; 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)))) |