From 661c70e4d786e7b2188564beddc586f1a50e4656 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 3 Jan 2015 11:24:14 -0400 Subject: The language officially has a name: Lux (stylized as "lux"). --- another.lang | 4 - another.lux | 4 + src/example/test1.lang | 38 -- src/example/test1.lux | 38 ++ src/lang.clj | 54 --- src/lang/analyser.clj | 823 ------------------------------------------- src/lang/compiler.clj | 937 ------------------------------------------------- src/lang/lexer.clj | 172 --------- src/lang/parser.clj | 230 ------------ src/lang/type.clj | 148 -------- src/lang/util.clj | 168 --------- src/lux.clj | 51 +++ src/lux/analyser.clj | 823 +++++++++++++++++++++++++++++++++++++++++++ src/lux/compiler.clj | 937 +++++++++++++++++++++++++++++++++++++++++++++++++ src/lux/lexer.clj | 172 +++++++++ src/lux/parser.clj | 230 ++++++++++++ src/lux/type.clj | 148 ++++++++ src/lux/util.clj | 168 +++++++++ test2.lang | 153 -------- test2.lux | 181 ++++++++++ 20 files changed, 2752 insertions(+), 2727 deletions(-) delete mode 100644 another.lang create mode 100644 another.lux delete mode 100644 src/example/test1.lang create mode 100644 src/example/test1.lux delete mode 100644 src/lang.clj delete mode 100644 src/lang/analyser.clj delete mode 100644 src/lang/compiler.clj delete mode 100644 src/lang/lexer.clj delete mode 100644 src/lang/parser.clj delete mode 100644 src/lang/type.clj delete mode 100644 src/lang/util.clj create mode 100644 src/lux.clj create mode 100644 src/lux/analyser.clj create mode 100644 src/lux/compiler.clj create mode 100644 src/lux/lexer.clj create mode 100644 src/lux/parser.clj create mode 100644 src/lux/type.clj create mode 100644 src/lux/util.clj delete mode 100644 test2.lang create mode 100644 test2.lux diff --git a/another.lang b/another.lang deleted file mode 100644 index ff5bb6f0a..000000000 --- a/another.lang +++ /dev/null @@ -1,4 +0,0 @@ - -## (ann id #type (All [x] (-> [x] x))) -(def (id x) - x) diff --git a/another.lux b/another.lux new file mode 100644 index 000000000..ff5bb6f0a --- /dev/null +++ b/another.lux @@ -0,0 +1,4 @@ + +## (ann id #type (All [x] (-> [x] x))) +(def (id x) + x) diff --git a/src/example/test1.lang b/src/example/test1.lang deleted file mode 100644 index 8e740eabd..000000000 --- a/src/example/test1.lang +++ /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/example/test1.lux b/src/example/test1.lux new file mode 100644 index 000000000..8e740eabd --- /dev/null +++ b/src/example/test1.lux @@ -0,0 +1,38 @@ + +(* 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/lang.clj b/src/lang.clj deleted file mode 100644 index 0777812b7..000000000 --- a/src/lang.clj +++ /dev/null @@ -1,54 +0,0 @@ -(ns lang - (:require (lang [lexer :as &lexer] - [parser :as &parser] - [type :as &type] - [analyser :as &analyser] - [compiler :as &compiler]) - :reload)) - -(comment - ;; TODO: Add macros. - ;; TODO: Re-implement compiler in language. - ;; TODO: Add signatures & structures OR type-classes. - ;; TODO: Add type-level computations. - ;; TODO: Add thunks. - ;; TODO: Do tail-call optimization. - ;; TODO: Adding metadata to global vars. - ;; TODO: Add records. - ;; TODO: throw, try, catch, finally - ;; TODO: Tuple8 and Tuple8X (for arbitrary-size tuples). - ;; TODO: Add extra arities (apply2, apply3, ..., apply16) - ;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly. - ;; TODO: Add "new". Allow setting fields. - ;; TODO: Don't take into account newlines in strings unless they come from \n to allow better coding. - ;; TODO: - ;; TODO: - ;; TODO: - ;; TODO: - - (let [source-code (slurp "test2.lang") - tokens (&lexer/lex source-code) - ;; _ (prn 'tokens tokens) - syntax (&parser/parse tokens) - ;; _ (prn 'syntax syntax) - ;; ann-syntax (&analyser/analyse "test2" syntax) - ;; _ (prn 'ann-syntax ann-syntax) - ;; class-data (&compiler/compile "test2" ann-syntax) - class-data (&compiler/compile "test2" syntax) - ;; _ (prn 'class-data class-data) - ] - ;; (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. "test2.class"))] - ;; (.write stream class-data)) - ) - - (Class/forName "test2.Variant") - - ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 - ) - -;; (def (workday? d) -;; (case d -;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday] -;; true) -;; (or [#Saturday #Sunday] -;; false))) diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj deleted file mode 100644 index 30592c817..000000000 --- a/src/lang/analyser.clj +++ /dev/null @@ -1,823 +0,0 @@ -(ns lang.analyser - (:refer-clojure :exclude [resolve]) - (:require (clojure [string :as string] - [template :refer [do-template]]) - [clojure.core.match :refer [match]] - (lang [util :as &util :refer [exec return* return fail fail* - repeat-m try-m try-all-m map-m 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 [ ] - (defanalyser - [ ?value] - (return (annotated [::literal ?value] [::&type/object []]))) - - 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/lang/compiler.clj b/src/lang/compiler.clj deleted file mode 100644 index 27652c1ad..000000000 --- a/src/lang/compiler.clj +++ /dev/null @@ -1,937 +0,0 @@ -(ns lang.compiler - (:refer-clojure :exclude [compile]) - (:require [clojure.string :as string] - [clojure.set :as set] - [clojure.core.match :refer [match]] - (lang [util :as &util :refer [exec return* return fail fail* - repeat-m try-m try-all-m map-m reduce-m - apply-m within - 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") "" "(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") "" "(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") "" "(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 "" "()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 "" 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 "" "()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-signature nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()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-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 "" "()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-signature nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()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-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-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 "" "()V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()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* "" "()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 "" "()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 ".lang")) - ;; _ (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/lang/lexer.clj b/src/lang/lexer.clj deleted file mode 100644 index 7b23c5947..000000000 --- a/src/lang/lexer.clj +++ /dev/null @@ -1,172 +0,0 @@ -(ns lang.lexer - (:require [clojure.template :refer [do-template]] - [clojure.core.match :refer [match]] - [lang.util :as &util :refer [exec return* return fail fail* - repeat-m try-m try-all-m]])) - -(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 [ ] - (def - (exec [token (lex-regex )] - (return [ 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/lang/parser.clj b/src/lang/parser.clj deleted file mode 100644 index 34f3e70b4..000000000 --- a/src/lang/parser.clj +++ /dev/null @@ -1,230 +0,0 @@ -(ns lang.parser - (:require [clojure.template :refer [do-template]] - [clojure.core.match :refer [match]] - (lang [util :as &util :refer [exec return* return fail fail* - repeat-m try-m try-all-m map-m - 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 [ ] - (defparser - [ ?value] - (return [ ( ?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/lang/type.clj b/src/lang/type.clj deleted file mode 100644 index cfb404a21..000000000 --- a/src/lang/type.clj +++ /dev/null @@ -1,148 +0,0 @@ -(ns lang.type - (:refer-clojure :exclude [resolve]) - (:require [clojure.core.match :refer [match]] - [lang.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/lang/util.clj b/src/lang/util.clj deleted file mode 100644 index 063dfa061..000000000 --- a/src/lang/util.clj +++ /dev/null @@ -1,168 +0,0 @@ -(ns lang.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)))) diff --git a/src/lux.clj b/src/lux.clj new file mode 100644 index 000000000..82fcb3a57 --- /dev/null +++ b/src/lux.clj @@ -0,0 +1,51 @@ +(ns lux + (:require (lux [lexer :as &lexer] + [parser :as &parser] + [type :as &type] + [analyser :as &analyser] + [compiler :as &compiler]) + :reload)) + +(comment + ;; TODO: Make macros monadic. + ;; TODO: Finish type system. + ;; TODO: Re-implement compiler in language. + ;; TODO: Add signatures & structures OR type-classes. + ;; TODO: Add type-level computations. + ;; TODO: Add thunks. + ;; TODO: Do tail-call optimization. + ;; TODO: Adding metadata to global vars. + ;; TODO: Add records. + ;; TODO: throw, try, catch, finally + ;; TODO: Tuple8 and Tuple8X (for arbitrary-size tuples). + ;; TODO: Add extra arities (apply2, apply3, ..., apply16) + ;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly. + ;; TODO: Add "new". Allow setting fields. + ;; TODO: Don't take into account newlines in strings unless they come from \n to allow better coding. + ;; TODO: monitor enter & monitor exit. + ;; TODO: + ;; TODO: + ;; TODO: + + (let [source-code (slurp "test2.lux") + tokens (&lexer/lex source-code) + ;; _ (prn 'tokens tokens) + syntax (&parser/parse tokens) + ;; _ (prn 'syntax syntax) + ;; ann-syntax (&analyser/analyse "test2" syntax) + ;; _ (prn 'ann-syntax ann-syntax) + ;; class-data (&compiler/compile "test2" ann-syntax) + class-data (&compiler/compile "test2" syntax) + ;; _ (prn 'class-data class-data) + ] + ) + + ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 + ) + +;; (def (workday? d) +;; (case d +;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday] +;; true) +;; (or [#Saturday #Sunday] +;; false))) 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 [ ] + (defanalyser + [ ?value] + (return (annotated [::literal ?value] [::&type/object []]))) + + 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") "" "(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") "" "(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") "" "(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 "" "()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 "" 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 "" "()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-signature nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()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-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 "" "()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-signature nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()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-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-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 "" "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()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* "" "()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 "" "()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 [ ] + (def + (exec [token (lex-regex )] + (return [ 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 [ ] + (defparser + [ ?value] + (return [ ( ?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)))) diff --git a/test2.lang b/test2.lang deleted file mode 100644 index 13fabc59a..000000000 --- a/test2.lang +++ /dev/null @@ -1,153 +0,0 @@ -(import java.lang.System) -(require "./another" as another) - -(definterface Function - (: apply (-> [java.lang.Object] java.lang.Object))) - -(defclass Tuple0 []) -(defclass Tuple1 [[java.lang.Object _0]]) -(defclass Tuple2 [[java.lang.Object _0] [java.lang.Object _1]]) - -(defclass Variant [[java.lang.String tag] [java.lang.Object value]]) - -(def (++ xs ys) - (case xs - #Nil - ys - - (#Cons x xs*) - (#Cons x (++ xs* ys)))) - -(def (template elems) - (case elems - #Nil - elems - - (#Cons head tail) - (case head - (#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) - (#Cons unquoted (template tail)) - - (#Form (#Cons (#Ident "~@") (#Cons spliced #Nil))) - (#Cons (#Ident "++") (#Cons spliced (template tail))) - - _ - (#Cons head (template tail)) - ))) - -(defmacro (' form) - (case form - (#Cons form* #Nil) - (case form* - (#Form elems) - (#Quote (#Form (template elems))) - - _ - (#Quote form*) - ))) - -## Utils -(def (fail* message) - (#Failure message)) - -(def (return* state value) - (#Ok state value)) - -(def (fail message) - (lambda [state] - (#Failure message))) - -(def (return value) - (lambda [state] - (#Ok state value))) - -(def (bind m-value step) - (lambda [state] - (let inputs (m-value state) - (case inputs - (#Ok ?state ?datum) - (step ?datum ?state) - - _ - inputs)))) - -## Ideally, this is what I want... -## (exec [yolo lol -## #let [foo bar] -## #when foo] -## (meme yolo foo)) - -(defmacro (exec tokens) - (case tokens - (#Cons (#Tuple steps) (#Cons return #Nil)) - (if (= 0 (mod (length steps) 2)) - (fold (lambda [inner pair] - (case pair - [label computation] - (` (bind (~ computation) - (lambda [(~ label)] (~ inner)))))) - return - (as-pairs steps)) - (#Text "Oh no!")))) - -## Program -(def (main args) - (case (' ((~ "TROLOLOL"))) - (#Form (#Cons (#Text text) #Nil)) - (:: (:: System out) (println text)) - )) - -#( - (defmacro (::+ pieces) - (case pieces - (#Cons init #Nil) - init - - (#Cons init (#Cons access others)) - (' (::+ (:: (~ init) (~ access)) (~@ others))) - )) - - (def (main args) - (if true - (let f (lambda [x] (lambda [y] (x y))) - (let g (lambda [x] x) - (::+ System out (println (f g "WE'VE GOT CLOSURES!"))))) - (:: (:: System out) (println "FALSE")))) - - (def (main args) - (if true - (case (++ (#Cons "Pattern" #Nil) (#Cons "Matching" #Nil)) - (#Cons "Pattern" (#Cons second #Nil)) - (do (:: (:: System out) (println "Branch #1")) - (:: (:: System out) (println second))) - - (#Cons first (#Cons second #Nil)) - (do (:: (:: System out) (println "Branch #2")) - (:: (:: System out) (println first)) - (:: (:: System out) (println second)))) - (:: (:: System out) (println "FALSE")))) - - (def (main args) - (case (template (#Cons (#Cons (#Symbol "~@") (#Cons (#Symbol "Pattern") #Nil)) #Nil) - ## (#Cons (#Cons (#Symbol "~") (#Cons (#Symbol "Pattern") #Nil)) #Nil) - ) - (#Cons word #Nil) - (do (:: (:: System out) (println "Branch #1")) - (:: (:: System out) (println word))) - - (#Cons (#Symbol op) spliced) - (do (:: (:: System out) (println "Branch #2")) - (:: (:: System out) (println op))) - )) - - (def (main args) - (case (' "YOLO") - (#Text text) - (:: (:: System out) (println text)))) - - (def (main args) - (case (' ((~ "TROLOLOL"))) - (#Form (#Cons (#Text text) #Nil)) - (:: (:: System out) (println text)) - )) - )# diff --git a/test2.lux b/test2.lux new file mode 100644 index 000000000..9e46012e3 --- /dev/null +++ b/test2.lux @@ -0,0 +1,181 @@ +(import java.lang.System) +## (require "./another" as another) + +(definterface Function + (: apply (-> [java.lang.Object] java.lang.Object))) + +(defclass Tuple0 []) +(defclass Tuple1 [[java.lang.Object _0]]) +(defclass Tuple2 [[java.lang.Object _0] [java.lang.Object _1]]) + +(defclass Variant [[java.lang.String tag] [java.lang.Object value]]) + +(def (++ xs ys) + (case xs + #Nil + ys + + (#Cons x xs*) + (#Cons x (++ xs* ys)))) + +(def (template elems) + (case elems + #Nil + elems + + (#Cons head tail) + (case head + (#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) + (#Cons unquoted (template tail)) + + (#Form (#Cons (#Ident "~@") (#Cons spliced #Nil))) + (#Cons (#Ident "++") (#Cons spliced (template tail))) + + _ + (#Cons head (template tail)) + ))) + +(defmacro (' form) + (case form + (#Cons form* #Nil) + (case form* + (#Form elems) + (#Quote (#Form (template elems))) + + _ + (#Quote form*) + ))) + +## Utils +(def (fail* message) + (#Failure message)) + +(def (return* state value) + (#Ok state value)) + +(def (fail message) + (lambda [state] + (#Failure message))) + +(def (return value) + (lambda [state] + (#Ok state value))) + +(def (bind m-value step) + (lambda [state] + (let inputs (m-value state) + (case inputs + (#Ok ?state ?datum) + (step ?datum ?state) + + _ + inputs)))) + +## Ideally, this is what I want... +## (exec [yolo lol +## #let [foo (bar 1 2 3)] +## #when true] +## (meme yolo foo)) + +#( (def (+ x y) + (jvm/i+ x y)) + + (def inc (+ 1)) + + (def (fold f init values) + (case values + #Nil + init + (#Cons x xs) + (fold f (f init x) xs))) + + (def length (fold inc 0)) + + (def (mod dividend divisor) + (jvm/imod dividend divisor)) + + (def (= x y) + (.equals x y)) + + (def (as-pairs list) + (case list + (#Cons x (#Cons y list*)) + (#Cons [x y] (as-pairs list*)) + + _ + #Nil)) + + (defmacro (exec tokens) + (case tokens + (#Cons (#Tuple steps) (#Cons return #Nil)) + (if (= 0 (mod (length steps) 2)) + (fold (lambda [inner pair] + (case pair + [label computation] + (` (bind (~ computation) + (lambda [(~ label)] (~ inner)))))) + return + (as-pairs steps)) + (#Text "Oh no!")))) )# + +## Program +(def (main args) + (case (' ((~ "Doing a slight makeover."))) + (#Form (#Cons (#Text text) #Nil)) + (:: (:: System out) (println text)) + )) + +#( + (defmacro (::+ pieces) + (case pieces + (#Cons init #Nil) + init + + (#Cons init (#Cons access others)) + (' (::+ (:: (~ init) (~ access)) (~@ others))) + )) + + (def (main args) + (if true + (let f (lambda [x] (lambda [y] (x y))) + (let g (lambda [x] x) + (::+ System out (println (f g "WE'VE GOT CLOSURES!"))))) + (:: (:: System out) (println "FALSE")))) + + (def (main args) + (if true + (case (++ (#Cons "Pattern" #Nil) (#Cons "Matching" #Nil)) + (#Cons "Pattern" (#Cons second #Nil)) + (do (:: (:: System out) (println "Branch #1")) + (:: (:: System out) (println second))) + + (#Cons first (#Cons second #Nil)) + (do (:: (:: System out) (println "Branch #2")) + (:: (:: System out) (println first)) + (:: (:: System out) (println second)))) + (:: (:: System out) (println "FALSE")))) + + (def (main args) + (case (template (#Cons (#Cons (#Symbol "~@") (#Cons (#Symbol "Pattern") #Nil)) #Nil) + ## (#Cons (#Cons (#Symbol "~") (#Cons (#Symbol "Pattern") #Nil)) #Nil) + ) + (#Cons word #Nil) + (do (:: (:: System out) (println "Branch #1")) + (:: (:: System out) (println word))) + + (#Cons (#Symbol op) spliced) + (do (:: (:: System out) (println "Branch #2")) + (:: (:: System out) (println op))) + )) + + (def (main args) + (case (' "YOLO") + (#Text text) + (:: (:: System out) (println text)))) + + (def (main args) + (case (' ((~ "TROLOLOL"))) + (#Form (#Cons (#Text text) #Nil)) + (:: (:: System out) (println text)) + )) + )# -- cgit v1.2.3