aboutsummaryrefslogtreecommitdiff
path: root/src/lang
diff options
context:
space:
mode:
authorEduardo Julian2015-01-03 11:24:14 -0400
committerEduardo Julian2015-01-03 11:24:14 -0400
commit661c70e4d786e7b2188564beddc586f1a50e4656 (patch)
treefe3aff74ffa526d455b7e22d7015573dc926f5f1 /src/lang
parent212dd66966a873e3d7183b071f719ef58e4d88fe (diff)
The language officially has a name: Lux (stylized as "lux").
Diffstat (limited to 'src/lang')
-rw-r--r--src/lang/analyser.clj823
-rw-r--r--src/lang/compiler.clj937
-rw-r--r--src/lang/lexer.clj172
-rw-r--r--src/lang/parser.clj230
-rw-r--r--src/lang/type.clj148
-rw-r--r--src/lang/util.clj168
6 files changed, 0 insertions, 2478 deletions
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 [<name> <tag> <class>]
- (defanalyser <name>
- [<tag> ?value]
- (return (annotated [::literal ?value] [::&type/object <class> []])))
-
- analyse-boolean ::&parser/boolean "java.lang.Boolean"
- analyse-int ::&parser/int "java.lang.Integer"
- analyse-float ::&parser/float "java.lang.Float"
- analyse-char ::&parser/char "java.lang.Character"
- analyse-string ::&parser/string "java.lang.String"
- )
-
-(defanalyser analyse-variant
- [::&parser/variant ?tag ?data]
- (exec [;; :let [_ (prn 'analyse-variant [?tag ?value])]
- =data (map-m analyse-form* ?data)
- ;; :let [_ (prn '=value =value)]
- ]
- (return (annotated [::variant ?tag =data] [::&type/variant ?tag (map :type =data)]))))
-
-(defanalyser analyse-tuple
- [::&parser/tuple ?elems]
- (exec [=elems (map-m analyse-form* ?elems)]
- (return (annotated [::tuple =elems] [::&type/tuple (mapv :type =elems)]))))
-
-(defanalyser analyse-ident
- [::&parser/ident ?ident]
- ;; (exec [_env (fn [state] [::&util/ok [state (:env state)]])
- ;; ;; :let [_ (prn 'analyse-ident ?ident _env)]
- ;; ]
- ;; (resolve ?ident))
- (exec [;; :let [_ (prn 'analyse-ident '?ident ?ident)]
- =ident (resolve ?ident)
- ;; :let [_ (prn 'analyse-ident '=ident =ident)]
- ;; :let [_ (prn 'analyse-ident ?ident =ident)]
- ;; state &util/get-state
- ;; :let [_ (prn 'analyse-ident ?ident (:form =ident) (:env state))]
- ]
- (return =ident)))
-
-(defanalyser analyse-access
- [::&parser/static-access ?target ?member]
- (exec [=target (resolve ?target)]
- (match (:form =target)
- [::class ?class]
- (return (annotated [::static-access ?class ?member] ::&type/nothing)))))
-
-(defn extract-ident [ident]
- (match ident
- [::&parser/ident ?ident]
- (return ?ident)
-
- _
- (fail "")))
-
-(defn extract-class [x]
- (match x
- [::class ?class]
- (return ?class)
-
- _
- (fail "")))
-
-(defn class-type [x]
- (match x
- [::&type/object ?class []]
- (return ?class)
-
- _
- (fail "")))
-
-(defn lookup-field [mode target field]
- ;; (prn 'lookup-field mode target field)
- (if-let [[[owner type]] (seq (for [=field (.getFields (Class/forName target))
- ;; :let [_ (prn target (.getName =field) (if (java.lang.reflect.Modifier/isStatic (.getModifiers =field))
- ;; :static
- ;; :dynamic))]
- :when (and (= field (.getName =field))
- (case mode
- :static (java.lang.reflect.Modifier/isStatic (.getModifiers =field))
- :dynamic (not (java.lang.reflect.Modifier/isStatic (.getModifiers =field)))))]
- [(.getDeclaringClass =field) (.getType =field)]))]
- (exec [=type (&type/class->type type)]
- (return [(.getName owner) =type]))
- (fail (str "Field does not exist: " target field mode))))
-
-(defn lookup-method [mode target method args]
- ;; (prn 'lookup-method mode target method args)
- (if-let [methods (seq (for [=method (.getMethods (Class/forName target))
- ;; :let [_ (prn target (.getName =method) (if (java.lang.reflect.Modifier/isStatic (.getModifiers =method))
- ;; :static
- ;; :dynamic))]
- :when (and (= method (.getName =method))
- (case mode
- :static (java.lang.reflect.Modifier/isStatic (.getModifiers =method))
- :dynamic (not (java.lang.reflect.Modifier/isStatic (.getModifiers =method)))))]
- [(.getDeclaringClass =method) =method]))]
- (map-m (fn [[owner method]]
- (exec [=method (&type/method->type method)]
- (return [(.getName owner) =method])))
- methods)
- (fail (str "Method does not exist: " target method mode))))
-
-(defanalyser analyse-access
- [::&parser/access ?object ?member]
- (match ?member
- [::&parser/ident ?field] ;; Field
- (try-all-m [(exec [?target (extract-ident ?object)
- =target (resolve ?target)
- ?class (extract-class (:form =target))
- [=owner =type] (lookup-field :static ?class ?field)
- ;; :let [_ (prn '=type =type)]
- ]
- (return (annotated [::static-field =owner ?field] =type)))
- (exec [=target (analyse-form* ?object)
- ?class (class-type (:type =target))
- [=owner =type] (lookup-field :dynamic ?class ?field)
- ;; :let [_ (prn '=type =type)]
- ]
- (return (annotated [::dynamic-field =target =owner ?field] =type)))])
- [::&parser/fn-call [::&parser/ident ?method] ?args] ;; Method
- (exec [=args (map-m analyse-form* ?args)]
- (try-all-m [(exec [?target (extract-ident ?object)
- =target (resolve ?target)
- ?class (extract-class (:form =target))
- =methods (lookup-method :static ?class ?method (map :type =args))
- ;; :let [_ (prn '=methods =methods)]
- [=owner =method] (within :types (&type/pick-matches =methods (map :type =args)))
- ;; :let [_ (prn '=method =owner ?method =method)]
- ]
- (return (annotated [::static-method =owner ?method =method =args] (&type/return-type =method))))
- (exec [=target (analyse-form* ?object)
- ?class (class-type (:type =target))
- =methods (lookup-method :dynamic ?class ?method (map :type =args))
- ;; :let [_ (prn '=methods =methods)]
- [=owner =method] (within :types (&type/pick-matches =methods (map :type =args)))
- ;; :let [_ (prn '=method =owner ?method =method)]
- ]
- (return (annotated [::dynamic-method =target =owner ?method =method =args] (&type/return-type =method))))]))))
-
-(defn ->token [x]
- ;; (prn '->token x)
- (let [variant (.newInstance (.loadClass loader "test2.Variant"))]
- (match x
- [::&parser/string ?text]
- (doto variant
- (-> .-tag (set! "Text"))
- (-> .-value (set! (doto (.newInstance (.loadClass loader "test2.Tuple1"))
- (-> .-_0 (set! ?text))))))
- [::&parser/ident ?ident]
- (doto variant
- (-> .-tag (set! "Ident"))
- (-> .-value (set! (doto (.newInstance (.loadClass loader "test2.Tuple1"))
- (-> .-_0 (set! ?ident))))))
- [::&parser/fn-call ?fn ?args]
- (doto variant
- (-> .-tag (set! "Form"))
- (-> .-value (set! (doto (.newInstance (.loadClass loader "test2.Tuple1"))
- (-> .-_0 (set! (->tokens (cons ?fn ?args))))))
- ))
- )))
-
-(defn ->tokens [xs]
- (let [variant (.loadClass loader "test2.Variant")
- tuple2 (.loadClass loader "test2.Tuple2")]
- (reduce (fn [tail x]
- ;; (prn 'tail (.-tag tail) 'x x)
- (doto (.newInstance variant)
- (-> .-tag (set! "Cons"))
- (-> .-value (set! (doto (.newInstance tuple2)
- (-> .-_0 (set! (->token x)))
- (-> .-_1 (set! tail))
- ;; (-> prn)
- )))
- ;; (-> prn)
- ))
- (doto (.newInstance variant)
- (-> .-tag (set! "Nil"))
- (-> .-value (set! (.newInstance (.loadClass loader "test2.Tuple0")))))
- (reverse xs))))
-
-(defn ->clojure-token [x]
- ;; (prn '->clojure-token x (.-tag x))
- (case (.-tag x)
- "Text" [::&parser/string (-> x .-value .-_0 (doto (-> string? assert)))]
- "Ident" [::&parser/ident (-> x .-value .-_0 (doto (-> string? assert)))]
- "Form" (let [[?fn & ?args] (-> x .-value .-_0 tokens->clojure)]
- [::&parser/fn-call ?fn ?args])
- "Quote" [::&parser/quote (-> x .-value .-_0 ->clojure-token)]))
-
-(defn tokens->clojure [xs]
- ;; (prn 'tokens->clojure xs (.-tag xs))
- (case (.-tag xs)
- "Nil" '()
- "Cons" (let [tuple2 (.-value xs)]
- (cons (->clojure-token (.-_0 tuple2))
- (tokens->clojure (.-_1 tuple2))))
- ))
-
-(defanalyser analyse-fn-call
- [::&parser/fn-call ?fn ?args]
- (exec [;; :let [_ (prn 'PRE '?fn ?fn)]
- macro? (is-macro? ?fn)
- scoped? (in-scope? ?fn)
- :let [;; _ (prn 'macro? ?fn macro?)
- ;; _ (prn 'scoped? scoped?)
- ]
- =fn (analyse-form* ?fn)
- ;; :let [_ (prn '=fn =fn)]
- ;; :let [_ (prn '=args =args)]
- ]
- (if (and macro? (not scoped?))
- (do ;; (prn "MACRO CALL!" ?fn ?args =fn)
- (let [macro (match (:form =fn)
- [::global ?module ?name]
- (.newInstance (.loadClass loader (str ?module "$" (normalize-ident ?name)))))
- output (->clojure-token (.apply macro (->tokens ?args)))]
- ;; (prn "MACRO CALL!" macro output)
- (analyse-form* output)))
- (exec [=args (map-m analyse-form* ?args)]
- (return (annotated [::call =fn =args] [::&type/object "java.lang.Object" []]))))
- ))
-
-(defanalyser analyse-if
- [::&parser/if ?test ?then ?else]
- (exec [=test (analyse-form* ?test)
- ;; :let [_ (prn '=test =test)]
- ;; :let [_ (prn 'PRE '?then ?then)]
- =then (analyse-form* ?then)
- ;; :let [_ (prn '=then =then)]
- =else (analyse-form* ?else)
- ;; :let [_ (prn '=else =else)]
- ]
- (return (annotated [::if =test =then =else] ::&type/nothing))))
-
-(defanalyser analyse-do
- [::&parser/do ?exprs]
- (exec [=exprs (map-m analyse-form* ?exprs)]
- (return (annotated [::do =exprs] (-> =exprs last :type)))))
-
-(let [fold-branches (fn [struct entry]
- (let [struct* (clojure.core.match/match (nth entry 0)
- [::pm-text ?text]
- (clojure.core.match/match (:type struct)
- ::text-tests (update-in struct [:patterns ?text] (fn [bodies]
- (if bodies
- (conj bodies (nth entry 1))
- #{(nth entry 1)})))
- nil (-> struct
- (assoc :type ::text-tests)
- (assoc-in [:patterns ?text] #{(nth entry 1)}))
- _ (assert false "Can't do match."))
- [::pm-variant ?tag ?members]
- (clojure.core.match/match (:type struct)
- ::adt (update-in struct [:patterns]
- (fn [branches]
- (if-let [{:keys [arity cases]} (get branches ?tag)]
- (if (= arity (count ?members))
- (-> branches
- (update-in [?tag :cases] conj {:case ?members
- :body (nth entry 1)})
- (update-in [?tag :branches] conj (nth entry 1)))
- (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity)))
- (assoc branches ?tag {:arity (count ?members)
- :cases [{:case ?members
- :body (nth entry 1)}]
- :branches #{(nth entry 1)}}))))
- nil (-> struct
- (assoc :type ::adt)
- (assoc-in [:patterns ?tag] {:arity (count ?members)
- :cases [{:case ?members
- :body (nth entry 1)}]
- :branches #{(nth entry 1)}}))
- _ (assert false "Can't do match."))
-
- [::pm-local ?local]
- (update-in struct [:defaults] conj [::default ?local (nth entry 1)]))]
- (update-in struct* [:branches] conj (nth entry 1))))
- base-struct {:type nil
- :patterns {}
- :defaults []
- :branches #{}}
- generate-branches (fn generate-branches [data]
- (let [branches* (reduce fold-branches base-struct data)]
- ;; (prn 'generate-branches data)
- ;; (prn 'branches* branches*)
- ;; (.print System/out (prn-str 'branches* branches*))
- ;; (.print System/out (prn-str '(:type branches*) (:type branches*)))
- (clojure.core.match/match (:type branches*)
- ::text-tests branches*
- ::adt (do (assert (<= (count (:defaults branches*)) 1))
- {:type ::adt*
- :patterns (into {} (for [[?tag ?struct] (:patterns branches*)
- ;; :let [_ (prn '(:patterns branches*) ?tag ?struct)]
- ]
- [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)]
- (map #(vector % body) case)))]
- (map generate-branches grouped-parts))
- :branches (:branches ?struct)}]))
- :default (-> branches* :defaults first)
- :branches (:branches branches*)})
- nil {:type ::defaults,
- :stores (reduce (fn [total [_ ?store ?body]]
- (update-in total [?store] (fn [mapping]
- (if mapping
- (conj mapping ?body)
- #{?body}))))
- {}
- (:defaults branches*))
- :branches (:branches branches*)})))
- get-vars (fn get-vars [pattern]
- (clojure.core.match/match pattern
- [::&parser/ident ?name]
- (list ?name)
-
- [::&parser/variant ?tag ?members]
- (mapcat get-vars ?members)
-
- [::&parser/string ?text]
- '()))
- ->instructions (fn ->instructions [locals pattern]
- (clojure.core.match/match pattern
- [::&parser/variant ?tag ?members]
- [::pm-variant ?tag (map (partial ->instructions locals) ?members)]
-
- [::&parser/ident ?name]
- [::pm-local (get locals ?name)]
-
- [::&parser/string ?text]
- [::pm-text ?text]
- ))]
- (defn ->decision-tree [$scope $base branches]
- (let [;; Step 1: Get all vars
- vars+body (for [branch branches]
- (clojure.core.match/match branch
- [::&parser/case-branch ?pattern ?body]
- [(get-vars ?pattern) ?body]))
- max-registers (reduce max 0 (map (comp count first) vars+body))
- ;; Step 2: Analyse bodies
- [_ branch-mappings branches*] (reduce (fn [[$link links branches*] branch]
- (clojure.core.match/match branch
- [::&parser/case-branch ?pattern ?body]
- [(inc $link) (assoc links $link ?body) (conj branches* [::&parser/case-branch ?pattern $link])]))
- [0 {} []]
- branches)
- ;; Step 4: Pattens -> Instructions
- branches** (for [[branch branch-vars] (map vector branches* (map first vars+body))
- :let [[_ locals] (reduce (fn [[$local =locals] $var]
- [(inc $local) (assoc =locals $var [::local $scope $local])])
- [$base {}] branch-vars)]]
- (clojure.core.match/match branch
- [::&parser/case-branch ?pattern ?body]
- [(->instructions locals ?pattern) ?body]))
- ;; _ (prn branches**)
- ;; Step 5: Re-structure branching
- ]
- [max-registers branch-mappings (generate-branches branches**)])))
-
-(defanalyser analyse-case
- [::&parser/case ?variant ?branches]
- (exec [=variant (analyse-form* ?variant)
- ;; :let [_ (prn 'analyse-case '=variant =variant)]
- $scope scope-id
- ;; :let [_ (prn 'analyse-case '$scope $scope)]
- $base next-local-idx
- ;; :let [_ (prn 'analyse-case '$base $base)]
- [registers mappings tree] (exec [=branches (map-m (fn [?branch]
- (match ?branch
- [::&parser/case-branch [::&parser/ident ?name] ?body]
- (exec [=body (with-locals {?name (annotated [::local $scope $base] [::&type/object "java.lang.Object" []])}
- (analyse-form* ?body))]
- (return [::&parser/case-branch [::&parser/ident ?name] =body]))
-
- [::&parser/case-branch [::&parser/variant ?tag ?members] ?body]
- (exec [[_ locals+] (reduce-m (fn member-fold [[$local locals-map] ?member]
- (match ?member
- [::&parser/ident ?name]
- (return [(inc $local) (assoc locals-map ?name (annotated [::local $scope $local] [::&type/object "java.lang.Object" []]))])
-
- [::&parser/variant ?subtag ?submembers]
- (reduce-m member-fold [$local locals-map] ?submembers)
-
- _
- (return [$local locals-map])
- ))
- [$base {}]
- ?members)
- ;; :let [_ (prn 'analyse-case 'locals+ locals+)]
- =body (with-locals locals+
- (analyse-form* ?body))
- ;; :let [_ (prn 'analyse-case '=body =body)]
- ]
- (return [::&parser/case-branch [::&parser/variant ?tag ?members] =body]))))
- ?branches)]
- (return (->decision-tree $scope $base =branches)))
- ;; :let [_ (prn 'analyse-case '[registers mappings tree] [registers mappings tree])]
- ]
- (return (annotated [::case (dec $base) =variant registers mappings tree] ::&type/nothing))))
-
-(defanalyser analyse-let
- [::&parser/let ?label ?value ?body]
- (exec [=value (analyse-form* ?value)
- idx next-local-idx
- =body (with-local ?label =value
- (analyse-form* ?body))]
- (return (annotated [::let idx ?label =value =body] (:type =body)))))
-
-(defanalyser analyse-defclass
- [::&parser/defclass ?name ?fields]
- (let [=members {:fields (into {} (for [[class field] ?fields]
- [field {:access ::public
- :type class}]))}
- =class [::class ?name =members]]
- (exec [name module-name]
- (return (annotated [::defclass [name ?name] =members] ::&type/nothing)))))
-
-(defanalyser analyse-definterface
- [::&parser/definterface ?name ?members]
- (let [=members {:methods (into {} (for [[method [inputs output]] ?members]
- [method {:access ::public
- :type [inputs output]}]))}
- =interface [::interface ?name =members]]
- (exec [name module-name]
- (return (annotated [::definterface [name ?name] =members] ::&type/nothing)))))
-
-(defanalyser analyse-def
- [::&parser/def ?usage ?value]
- (match ?usage
- [::&parser/ident ?name]
- (exec [=value (with-scope ?name
- (analyse-form* ?value))
- _ (define ?name {:mode ::constant
- :access ::public
- :type (:type =value)})]
- (return (annotated [::def ?name =value] ::&type/nothing)))
-
- [::&parser/fn-call [::&parser/ident ?name] ?args]
- (let [args (for [a ?args]
- (match a
- [::&parser/ident ?ident]
- ?ident))]
- (exec [[=function =args =return] (within :types (&type/fresh-function (count args)))
- ;; :let [_ (prn '[=function =args =return] [=function =args =return])]
- ;; :let [env (-> {}
- ;; (assoc ?name =function)
- ;; (into (map vector args =args)))
- ;; _ (prn 'env env)]
- =value (with-scope ?name
- (with-scoped-name ?name =function
- (reduce (fn [inner [label type]]
- (with-local label type inner))
- (analyse-form* ?value)
- (reverse (map vector args =args)))))
- ;; :let [_ (prn '=value =value)]
- =function (within :types (exec [_ (&type/solve =return (:type =value))]
- (&type/clean =function)))
- ;; :let [_ (prn '=function =function)]
- _ (define ?name {:mode ::function
- :access ::public
- :type =function})]
- (return (annotated [::def [?name args] =value] ::&type/nothing))))
- ))
-
-(defanalyser analyse-defmacro
- [::&parser/defmacro [::&parser/fn-call [::&parser/ident ?name] ([[::&parser/ident ?tokens]] :seq)] ?value]
- (exec [[=function =tokens =return] (within :types (&type/fresh-function 1))
- =value (with-scope ?name
- (with-scoped-name ?name =function
- (with-local ?tokens =tokens
- (analyse-form* ?value))))
- =function (within :types (exec [_ (&type/solve =return (:type =value))]
- (&type/clean =function)))
- _ (define ?name {:mode ::macro
- :access ::public
- :type =function})]
- (return (annotated [::def [?name (list ?tokens)] =value] ::&type/nothing))))
-
-(defanalyser analyse-lambda
- [::&parser/lambda ?args ?body]
- (exec [;; :let [_ (prn 'analyse-lambda ?args ?body)]
- [=function =args =return] (within :types (&type/fresh-function (count ?args)))
- ;; :let [_ (prn '[=function =args =return] [=function =args =return])]
- ;; :let [_ (prn 'PRE/?body ?body)]
- ;; _env (fn [state] [::&util/ok [state (:env state)]])
- ;; :let [_ (prn 'analyse-lambda _env)]
- [=scope =frame =body] (with-fresh-env [?args =args]
- (analyse-form* ?body))
- ;; :let [_ (prn '=body =body)]
- =function (within :types (exec [_ (&type/solve =return (:type =body))]
- (&type/clean =function)))
- ;; :let [_ (prn '=function =function)]
- ]
- (return (annotated [::lambda =scope =frame ?args =body] =function))))
-
-(defanalyser analyse-import
- [::&parser/import ?class]
- (exec [_ (import-class ?class (last (string/split ?class #"\.")))]
- (return (annotated [::import ?class] ::&type/nothing))))
-
-(defanalyser analyse-require
- [::&parser/require ?file ?alias]
- (let [;; _ (prn `[require ~?file ~?alias])
- module-name (re-find #"[^/]+$" ?file)
- ;; _ (prn 'module-name module-name)
- ]
- (exec [_ (require-module module-name ?alias)]
- (return (annotated [::require ?file ?alias] ::&type/nothing)))))
-
-(defanalyser analyse-quote
- [::&parser/quote ?quoted]
- (return (annotated [::quote ?quoted] ::&type/nothing)))
-
-(def analyse-form
- (try-all-m [analyse-boolean
- analyse-int
- analyse-float
- analyse-char
- analyse-string
- analyse-variant
- analyse-tuple
- analyse-lambda
- analyse-ident
- analyse-access
- analyse-fn-call
- analyse-if
- analyse-do
- analyse-case
- analyse-let
- analyse-defclass
- analyse-definterface
- analyse-def
- analyse-defmacro
- analyse-import
- analyse-require
- analyse-quote]))
-
-;; [Interface]
-(defn analyse [module-name tokens]
- (match ((repeat-m (with-scope module-name
- analyse-form)) {:name module-name,
- :forms tokens
- :deps {}
- :imports {}
- :defs {}
- :defs-env {}
- :lambda-scope [[] 0]
- :env (list (fresh-env 0))
- :types &type/+init+})
- [::&util/ok [?state ?forms]]
- (if (empty? (:forms ?state))
- ?forms
- (assert false (str "Unconsumed input: " (pr-str (:forms ?state)))))
-
- [::&util/failure ?message]
- (assert false ?message)))
diff --git a/src/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") "<init>" "(I)V"))
-
- (instance? java.lang.Float ?literal)
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW (->class "java.lang.Float"))
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn ?literal)
- (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Float") "<init>" "(F)V"))
-
- (instance? java.lang.Character ?literal)
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW (->class "java.lang.Character"))
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn ?literal)
- (.visitMethodInsn Opcodes/INVOKESPECIAL (->class "java.lang.Character") "<init>" "(C)V"))
-
- (instance? java.lang.Boolean ?literal)
- (if ?literal
- ;; (.visitLdcInsn *writer* (int 1))
- (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") "TRUE" (->type-signature "java.lang.Boolean"))
- ;; (.visitLdcInsn *writer* (int 0))
- (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") "FALSE" (->type-signature "java.lang.Boolean")))
-
- (string? ?literal)
- (.visitLdcInsn *writer* ?literal)
-
- :else
- (assert false (str "[Unknown literal type] " ?literal " : " (class ?literal)))))
-
-(defcompiler ^:private compile-tuple
- [::&analyser/tuple ?elems]
- (let [num-elems (count ?elems)]
- (let [tuple-class (str "test2/Tuple" num-elems)]
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW tuple-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))
- (dotimes [idx num-elems]
- (.visitInsn *writer* Opcodes/DUP)
- (compile-form (assoc *state* :form (nth ?elems idx)))
- (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str "_" idx) "Ljava/lang/Object;")))))
-
-(defcompiler ^:private compile-local
- [::&analyser/local ?env ?idx]
- (do ;; (prn 'LOCAL ?idx)
- (doto *writer*
- (.visitVarInsn Opcodes/ALOAD (int ?idx)))))
-
-(defcompiler ^:private compile-captured
- [::&analyser/captured ?scope ?captured-id ?source]
- (do ;; (prn 'CAPTURED [?scope ?captured-id])
- (doto *writer*
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD (apply str (interpose "$" ?scope)) (str "__" ?captured-id) "Ljava/lang/Object;"))))
-
-(defcompiler ^:private compile-global
- [::&analyser/global ?owner-class ?name]
- (do ;; (prn 'GLOBAL ?owner-class ?name *type*)
- ;; (prn 'compile-global (->class (str ?owner-class "$" ?name)) "_datum")
- (doto *writer*
- (.visitFieldInsn Opcodes/GETSTATIC (->class (str ?owner-class "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;" ;; (->java-sig *type*)
- ))))
-
-;; (defcompiler ^:private compile-call
-;; [::&analyser/call ?fn ?args]
-;; (do (prn 'compile-call (:form ?fn) ?fn ?args)
-;; (doseq [arg (reverse ?args)]
-;; (compile-form (assoc *state* :form arg)))
-;; (match (:form ?fn)
-;; [::&analyser/global ?owner-class ?fn-name]
-;; (let [signature (str "(" (apply str (repeat (count ?args) "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")]
-;; (doto *writer*
-;; (.visitMethodInsn Opcodes/INVOKESTATIC (->class ?owner-class) ?fn-name signature))))))
-
-(defcompiler ^:private compile-call
- [::&analyser/call ?fn ?args]
- (do ;; (prn 'compile-call (:form ?fn) ?fn ?args)
- (match (:form ?fn)
- [::&analyser/global ?owner-class ?fn-name]
- (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
- clo-field-sig (->type-signature "java.lang.Object")
- counter-sig "I"
- num-args (count ?args)
- signature (if (> (count ?args) 1)
- (str "(" (apply str counter-sig (repeat (dec num-args) clo-field-sig)) ")" "V")
- (str "()" "V"))
- call-class (str (->class ?owner-class) "$" (normalize-ident ?fn-name))]
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW call-class)
- (.visitInsn Opcodes/DUP)
- (-> (doto (.visitLdcInsn (-> ?args count dec int))
- ;; (.visitInsn Opcodes/ICONST_0)
- (-> (do (compile-form (assoc *state* :form arg)))
- (->> (doseq [arg (butlast ?args)]))))
- (->> (when (> (count ?args) 1))))
- (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" signature)
- (do (compile-form (assoc *state* :form (last ?args))))
- (.visitMethodInsn Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature)))
-
- _
- (do (compile-form (assoc *state* :form ?fn))
- (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"]
- (doseq [arg ?args]
- (compile-form (assoc *state* :form arg))
- (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))))
- )))
-
-(defcompiler ^:private compile-static-field
- [::&analyser/static-field ?owner ?field]
- (do ;; (prn 'compile-static-field ?owner ?field)
- ;; (assert false)
- (doto *writer*
- (.visitFieldInsn Opcodes/GETSTATIC (->class ?owner) ?field (->java-sig *type*)))
- ))
-
-(defcompiler ^:private compile-dynamic-field
- [::&analyser/dynamic-field ?target ?owner ?field]
- (do ;; (prn 'compile-static-field ?owner ?field)
- ;; (assert false)
- (compile-form (assoc *state* :form ?target))
- (doto *writer*
- (.visitFieldInsn Opcodes/GETFIELD (->class ?owner) ?field (->java-sig *type*)))
- ))
-
-(defcompiler ^:private compile-static-method
- [::&analyser/static-method ?owner ?method-name ?method-type ?args]
- (do ;; (prn 'compile-dynamic-access ?target ?owner ?method-name ?method-type ?args)
- ;; (assert false)
- (do (doseq [arg ?args]
- (compile-form (assoc *state* :form arg)))
- (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC (->class ?owner) ?method-name (method->sig ?method-type))
- (.visitInsn Opcodes/ACONST_NULL)))
- ))
-
-(defcompiler ^:private compile-dynamic-method
- [::&analyser/dynamic-method ?target ?owner ?method-name ?method-type ?args]
- (do ;; (prn 'compile-dynamic-method ?target ?owner ?method-name ?method-type ?args)
- ;; (assert false)
- (do (compile-form (assoc *state* :form ?target))
- (doseq [arg ?args]
- (compile-form (assoc *state* :form arg)))
- (doto *writer*
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class ?owner) ?method-name (method->sig ?method-type))
- (.visitInsn Opcodes/ACONST_NULL)
- ))
- ))
-
-(defcompiler ^:private compile-if
- [::&analyser/if ?test ?then ?else]
- (let [else-label (new Label)
- end-label (new Label)]
- ;; (println "PRE")
- (compile-form (assoc *state* :form ?test))
- (doto *writer*
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Boolean") "booleanValue" "()Z")
- (.visitJumpInsn Opcodes/IFEQ else-label))
- ;; (prn 'compile-if/?then (:form ?then))
- (compile-form (assoc *state* :form ?then))
- ;; (.visitInsn *writer* Opcodes/POP)
- (doto *writer*
- (.visitJumpInsn Opcodes/GOTO end-label)
- (.visitLabel else-label))
- (compile-form (assoc *state* :form ?else))
- ;; (.visitInsn *writer* Opcodes/POP)
- (.visitLabel *writer* end-label)))
-
-(defcompiler ^:private compile-do
- [::&analyser/do ?exprs]
- (do (doseq [expr (butlast ?exprs)]
- (compile-form (assoc *state* :form expr))
- (.visitInsn *writer* Opcodes/POP))
- (compile-form (assoc *state* :form (last ?exprs)))))
-
-(let [+tag-sig+ (->type-signature "java.lang.String")
- variant-class* (->class +variant-class+)
- oclass (->class "java.lang.Object")
- +tuple-field-sig+ (->type-signature "java.lang.Object")
- equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
- (defn compile-decision-tree [writer mappings cleanup-level next-label default-label decision-tree]
- ;; (prn 'compile-decision-tree cleanup-level decision-tree)
- (match decision-tree
- [::test-text ?text $body]
- (let [$else (new Label)]
- (doto writer
- ;; object
- (.visitInsn Opcodes/DUP) ;; object, object
- (.visitLdcInsn ?text) ;; object, object, text
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B
- (.visitJumpInsn Opcodes/IFEQ $else) ;; object
- (.visitInsn Opcodes/POP) ;;
- (.visitJumpInsn Opcodes/GOTO next-label)
- (.visitLabel $else)
- (-> (doto (.visitInsn Opcodes/POP))
- (->> (dotimes [_ (inc cleanup-level)])))
- (.visitJumpInsn Opcodes/GOTO default-label)))
-
- [::store [::&analyser/local _ ?idx] $body]
- (doto writer
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (-> (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (->> (when (nil? next-label)))))
-
- [::test-adt ?branches ?cases]
- (doto writer
- ;; object
- (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant
- (.visitInsn Opcodes/DUP) ;; variant, variant
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag
- (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag
- (.visitLdcInsn ?tag) ;; variant, tag, tag, text
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B
- (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag
- (.visitInsn Opcodes/POP) ;; variant
- (do (let [arity (-> ?subcases first (nth 2) count)
- tuple-class (str "test2/Tuple" arity)
- ;; _ (prn ?tag arity tuple-class)
- ]
- (when (> arity 0)
- (doto writer
- (.visitInsn Opcodes/DUP) ;; variant, variant
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" +tuple-field-sig+) ;; variant, object
- (.visitTypeInsn Opcodes/CHECKCAST tuple-class) ;; variant, tuple
- ))
- (doseq [subcase ?subcases
- :let [else-label (new Label)]]
- (match subcase
- [::subcase $body ?subseq]
- (do (when (not (empty? ?subseq))
- (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
- :let [next-label (new Label)]]
- (doto writer
- (.visitInsn Opcodes/DUP) ;; variant, tuple, tuple
- (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?subidx) +tuple-field-sig+) ;; variant, tuple, object
- (compile-decision-tree mappings cleanup-level next-label else-label ?subpart) ;; variant, tuple
- (.visitLabel next-label))))
- (doto writer
- (-> (doto (.visitInsn Opcodes/POP))
- (->> (dotimes [_ (+ cleanup-level (if (> arity 0) 2 1))]))) ;;
- (.visitJumpInsn Opcodes/GOTO (or next-label (get mappings $body)))
- (.visitLabel else-label)))
- ))
- ))
- ;; variant, tag ->
- (.visitLabel tag-else-label))
- (->> (doseq [[?tag ?subcases] ?cases
- ;; :let [_ (.print System/out (prn-str 'COMPILE-PATTERN ?tag ?subcases))]
- :let [tag-else-label (new Label)]])))
- (-> (doto (.visitInsn Opcodes/POP))
- (->> (dotimes [_ (+ cleanup-level 2)])))
- (.visitJumpInsn Opcodes/GOTO default-label)))
- ))
-
-(defn sequence-parts [branches parts]
- ;; (.print System/out (prn-str 'sequence-parts branches parts))
- (if (empty? parts)
- '(())
- (let [[head & tail] parts
- expanded (case (:type head)
- ::&analyser/defaults
- (for [[?local ?supports] (:stores head)
- ?body (set/intersection branches ?supports)
- ;; :when (set/subset? branches ?supports)
- ]
- [[::store ?local ?body] #{?body}])
-
- ::&analyser/text-tests
- (concat (for [[?text ?supports] (:patterns head)
- ?body (set/intersection branches ?supports)
- ;; :when (set/subset? branches ?supports)
- ]
- [[::test-text ?text ?body] #{?body}])
- (for [[_ ?local ?body] (:defaults head)
- :when (contains? branches ?body)]
- [[::store ?local ?body] #{?body}]))
-
- ::&analyser/adt*
- (do ;; (prn '(:default head) (:default head))
- ;; (assert (nil? (:default head)))
- (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head)
- ;; :let [_ (.print System/out (prn-str 'PATTERN ?tag ?struct))]
- :let [?parts (:parts ?struct)
- num-parts (count ?parts)
- ?supports (:branches ?struct)
- subcases (for [?body (set/intersection branches ?supports)
- subseq (sequence-parts #{?body} ?parts)
- ;; :let [_ (when (= "Symbol" ?tag)
- ;; (.print System/out (prn-str 'counting ?tag num-parts (count subseq) subseq)))]
- :when (= num-parts (count subseq))]
- [::subcase ?body subseq])]
- :when (not (empty? subcases))]
- [?tag subcases]))]
- (if (empty? patterns)
- '()
- (list [[::test-adt branches patterns]
- branches])))
- (if-let [[_ ?local ?body] (:default head)]
- (for [?body (set/intersection branches #{?body})]
- [[::store ?local ?body] #{?body}])
- '())))
- )]
- (for [[step branches*] expanded
- tail* (sequence-parts branches* tail)
- ;; :let [_ (.print System/out (prn-str 'tail* tail*))]
- ]
- (cons step tail*)))))
-
-(def !case-vars (atom -1))
-
-(let [oclass (->class "java.lang.Object")
- equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")
- ex-class (->class "java.lang.IllegalStateException")]
- (defcompiler ^:private compile-case
- ;; [::&analyser/case ?variant ?branches]
- [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree]
- (do ;; (prn 'compile-case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree)
- ;; (assert false)
- (let [start-label (new Label)
- end-label (new Label)
- ;; default-label (new Label)
- entries (for [[?branch ?body] ?branch-mappings
- :let [label (new Label)]]
- [[?branch label]
- [label ?body]])
- mappings* (into {} (map first entries))]
- (dotimes [idx ?max-registers]
- (.visitLocalVariable *writer* (str "__" (swap! !case-vars inc) "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx))))
- (compile-form (assoc *state* :form ?variant))
- (.visitLabel *writer* start-label)
- (let [default-label (new Label)
- default-code (:default ?decision-tree)]
- ;; (prn 'sequence-parts
- ;; (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))
- (doseq [decision-tree (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))]
- (compile-decision-tree *writer* mappings* 0 nil default-label decision-tree))
- (.visitLabel *writer* default-label)
- (when (not default-code)
- ;; (do (prn 'default-code default-code)
- ;; (assert false)
- ;; ;; (.visitInsn Opcodes/POP) ;; ...
- ;; (compile-form (assoc *state* :form default-code))
- ;; (.visitJumpInsn *writer* Opcodes/GOTO end-label))
- (doto *writer*
- ;; (.visitInsn Opcodes/POP)
- (.visitTypeInsn Opcodes/NEW ex-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
- (.visitInsn Opcodes/ATHROW))))
- ;; (compile-decision-tree *state* *writer* mappings* 1 nil (:branches ?decision-tree) ?decision-tree)
- (doseq [[?label ?body] (map second entries)]
- (.visitLabel *writer* ?label)
- (compile-form (assoc *state* :form ?body))
- (.visitJumpInsn *writer* Opcodes/GOTO end-label))
- (.visitLabel *writer* end-label)
- ))
- ))
-
-(defcompiler ^:private compile-let
- [::&analyser/let ?idx ?label ?value ?body]
- (let [start-label (new Label)
- end-label (new Label)
- ?idx (int ?idx)]
- ;; (prn '(:type ?value) (:type ?value) (->java-sig (:type ?value)))
- (.visitLocalVariable *writer* (normalize-ident ?label) (->java-sig (:type ?value)) nil start-label end-label ?idx)
- (assert (compile-form (assoc *state* :form ?value)) "CAN't COMPILE LET-VALUE")
- (doto *writer*
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitLabel start-label))
- (assert (compile-form (assoc *state* :form ?body)) "CAN't COMPILE LET-BODY")
- (.visitLabel *writer* end-label)))
-
-(defn ^:private compile-method-function [writer class-name fn-name num-args body *state*]
- (let [outer-class (->class class-name)
- clo-field-sig (->type-signature "java.lang.Object")
- counter-sig "I"
- apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
- real-signature (str "(" (apply str (repeat num-args clo-field-sig)) ")" "Ljava/lang/Object;")
- current-class (str outer-class "$" (normalize-ident fn-name))
- num-captured (dec num-args)
- init-signature (if (not= 0 num-captured)
- (str "(" (apply str counter-sig (repeat num-captured clo-field-sig)) ")" "V")
- (str "()" "V"))]
- (.visitInnerClass writer current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
- (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- current-class nil "java/lang/Object" (into-array ["test2/Function"]))
- (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil)
- (.visitEnd))
- (->> (when (not= 0 num-captured)))))
- =impl (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "impl" real-signature nil nil)
- (.visitCode)
- (->> (assoc *state* :form body :writer) compile-form)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- =init (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitFieldInsn Opcodes/PUTFIELD current-class "_counter" counter-sig)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD (+ clo_idx 2))
- (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig))
- (->> (let [field-name (str "_" clo_idx)]
- (doto (.visitField =class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil)
- (.visitEnd)))
- (dotimes [clo_idx num-captured]))))
- (->> (when (not= 0 num-captured))))
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- =method (let [default-label (new Label)
- branch-labels (for [_ (range num-captured)]
- (new Label))]
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil)
- (.visitCode)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig)
- (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels))
- (-> (doto (.visitLabel branch-label)
- (.visitTypeInsn Opcodes/NEW current-class)
- (.visitInsn Opcodes/DUP)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig)
- (.visitInsn Opcodes/ICONST_1)
- (.visitInsn Opcodes/IADD)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig))
- (->> (dotimes [clo_idx current-captured])))
- (.visitVarInsn Opcodes/ALOAD 1)
- (-> (.visitInsn Opcodes/ACONST_NULL)
- (->> (dotimes [clo_idx (- (dec num-captured) current-captured)])))
- (.visitMethodInsn Opcodes/INVOKESPECIAL current-class "<init>" init-signature)
- ;; (.visitJumpInsn Opcodes/GOTO end-label)
- (.visitInsn Opcodes/ARETURN))
- (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))
- ;; :let [_ (prn '[branch-label current-captured] [branch-label current-captured])]
- ])))
- (.visitLabel default-label)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig))
- (->> (dotimes [clo_idx num-captured]))))
- (->> (when (not= 0 num-captured))))
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitMethodInsn Opcodes/INVOKESTATIC current-class "impl" real-signature)
- ;; (.visitLabel end-label)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (.visitEnd =class)
- bytecode (.toByteArray =class)]
- (write-file (str current-class ".class") bytecode)
- (load-class! (string/replace current-class #"/" ".") (str current-class ".class")))
- ))
-
-(defn compile-field [writer class-name ?name body state]
- (let [outer-class (->class class-name)
- datum-sig (->type-signature "java.lang.Object")
- current-class (str outer-class "$" ?name)]
- (.visitInnerClass writer current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
- (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- current-class nil "java/lang/Object" (into-array ["test2/Function"]))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil)
- (doto (.visitEnd)))
- (-> (.visitMethod Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (doto (.visitCode)
- (->> (assoc state :form body :writer) compile-form)
- (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig)
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- (.visitEnd))
- bytecode (.toByteArray =class)]
- (write-file (str current-class ".class") bytecode)
- (load-class! (string/replace current-class #"/" ".") (str current-class ".class")))
- ))
-
-(defcompiler ^:private compile-def
- [::&analyser/def ?form ?body]
- (do ;; (prn 'compile-def ?form)
- (match ?form
- (?name :guard string?)
- (compile-field *writer* *class-name* ?name ?body *state*)
-
- [?name ?args]
- (do ;; (prn 'compile-def `(~'def (~(symbol ?name) ~@(map symbol ?args))))
- (if (= "main" ?name)
- (let [signature "([Ljava/lang/String;)V"
- =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
- (.visitCode))]
- ;; (prn 'FN/?body ?body)
- (compile-form (assoc *state* :parent *writer* :writer =method :form ?body))
- (doto =method
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- (compile-method-function *writer* *class-name* ?name (count ?args) ?body *state*)))
- )))
-
-(defn ^:private captured? [form]
- (match form
- [::&analyser/captured ?closure-id ?captured-id ?source]
- true
- _
- false))
-
-(defcompiler ^:private compile-lambda
- [::&analyser/lambda ?scope ?frame ?args ?body]
- (let [;; _ (prn '[?scope ?frame] ?scope ?frame)
- num-args (count ?args)
- outer-class (->class *class-name*)
- clo-field-sig (->type-signature "java.lang.Object")
- counter-sig "I"
- apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
- real-signature (str "(" (apply str (repeat num-args clo-field-sig)) ")" "Ljava/lang/Object;")
- current-class (apply str (interpose "$" ?scope))
- num-captured (dec num-args)
- init-signature (str "(" (apply str (repeat (->> (:mappings ?frame)
- (map (comp :form second))
- (filter captured?)
- count)
- clo-field-sig))
- (if (not= 0 num-captured)
- (apply str counter-sig (repeat num-captured clo-field-sig)))
- ")"
- "V")
- ;; _ (prn current-class 'init-signature init-signature)
- ;; _ (prn current-class 'real-signature real-signature)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- current-class nil "java/lang/Object" (into-array ["test2/Function"]))
- (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil)
- (.visitEnd))
- (->> (let [captured-name (str "__" ?captured-id)])
- (match (:form ?captured)
- [::&analyser/captured ?closure-id ?captured-id ?source])
- (doseq [[?name ?captured] (:mappings ?frame)
- :when (captured? (:form ?captured))])))
- (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil)
- (.visitEnd))
- (->> (when (not= 0 num-captured)))))
- =init (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
- (.visitFieldInsn Opcodes/PUTFIELD current-class captured-name clo-field-sig))
- (->> (let [captured-name (str "__" ?captured-id)])
- (match (:form ?captured)
- [::&analyser/captured ?closure-id ?captured-id ?source])
- (doseq [[?name ?captured] (:mappings ?frame)
- :when (captured? (:form ?captured))])))
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD (inc (count (:mappings ?frame))))
- (.visitFieldInsn Opcodes/PUTFIELD current-class "_counter" counter-sig)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset))
- (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig))
- (->> (let [field-name (str "_" clo_idx)]
- (doto (.visitField =class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil)
- (.visitEnd)))
- (dotimes [clo_idx num-captured])
- (let [offset (+ 2 (count (:mappings ?frame)))]))))
- (->> (when (not= 0 num-captured))))
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- =method (let [default-label (new Label)
- branch-labels (for [_ (range num-captured)]
- (new Label))]
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig)
- (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels))
- (-> (doto (.visitLabel branch-label)
- (.visitTypeInsn Opcodes/NEW current-class)
- (.visitInsn Opcodes/DUP)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD current-class (str "__" capt_idx) clo-field-sig))
- (->> (dotimes [capt_idx (count (:mappings ?frame))])))
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig)
- (.visitInsn Opcodes/ICONST_1)
- (.visitInsn Opcodes/IADD)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig))
- (->> (dotimes [clo_idx current-captured])))
- (.visitVarInsn Opcodes/ALOAD 1)
- (-> (.visitInsn Opcodes/ACONST_NULL)
- (->> (dotimes [clo_idx (- (dec num-captured) current-captured)])))
- (.visitMethodInsn Opcodes/INVOKESPECIAL current-class "<init>" init-signature)
- (.visitInsn Opcodes/ARETURN))
- (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))
- ;; :let [_ (prn '[branch-label current-captured] [branch-label current-captured])]
- ])))
- (.visitLabel default-label)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig))
- (->> (dotimes [clo_idx num-captured]))))
- (->> (when (not= 0 num-captured))))
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL current-class "impl" real-signature)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; _ (prn 'LAMBDA/?body ?body)
- =impl (doto (.visitMethod =class Opcodes/ACC_PUBLIC "impl" real-signature nil nil)
- (.visitCode)
- (->> (assoc *state* :form ?body :writer)
- compile-form)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (.visitEnd =class)
- bytecode (.toByteArray =class)]
- (write-file (str current-class ".class") bytecode)
- (load-class! (string/replace current-class #"/" ".") (str current-class ".class"))
- ;; (apply prn 'LAMBDA ?scope ?args (->> (:mappings ?frame)
- ;; (map second)
- ;; (map :form)
- ;; (filter captured?)))
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW current-class)
- (.visitInsn Opcodes/DUP)
- (-> (do (compile-form (assoc *state* :form ?source)))
- (->> (match (:form ?captured)
- [::&analyser/captured ?closure-id ?captured-id ?source])
- (doseq [[?name ?captured] (:mappings ?frame)
- :when (captured? (:form ?captured))])))
- (-> (doto (.visitInsn Opcodes/ICONST_0)
- ;; (.visitInsn Opcodes/ICONST_0)
- (-> (.visitInsn Opcodes/ACONST_NULL)
- (->> (doseq [_ (butlast ?args)]))))
- (->> (when (> (count ?args) 1))))
- (.visitMethodInsn Opcodes/INVOKESPECIAL current-class "<init>" init-signature))
- ))
-
-(defcompiler ^:private compile-defclass
- [::&analyser/defclass [?package ?name] ?members]
- (let [parent-dir (->package ?package)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- (str parent-dir "/" ?name) nil "java/lang/Object" nil))]
- (doseq [[field props] (:fields ?members)]
- (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil)
- (.visitEnd)))
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- (.visitEnd =class)
- (.mkdirs (java.io.File. parent-dir))
- (write-file (str parent-dir "/" ?name ".class") (.toByteArray =class))
- (load-class! (string/replace (str parent-dir "/" ?name) #"/" ".") (str parent-dir "/" ?name ".class"))))
-
-(defcompiler ^:private compile-definterface
- [::&analyser/definterface [?package ?name] ?members]
- (let [parent-dir (->package ?package)
- =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE ;; Opcodes/ACC_ABSTRACT
- )
- (str parent-dir "/" ?name) nil "java/lang/Object" nil))]
- (doseq [[?method ?props] (:methods ?members)
- :let [[?args ?return] (:type ?props)
- signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]]
- (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil))
- (.visitEnd =interface)
- (.mkdirs (java.io.File. parent-dir))
- (write-file (str parent-dir "/" ?name ".class") (.toByteArray =interface))
- (load-class! (string/replace (str parent-dir "/" ?name) #"/" ".") (str parent-dir "/" ?name ".class"))))
-
-(defcompiler ^:private compile-variant
- [::&analyser/variant ?tag ?members]
- (let [variant-class* (->class +variant-class+)]
- ;; (prn 'compile-variant ?tag ?value)
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW variant-class*)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V")
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn ?tag)
- (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (->type-signature "java.lang.String"))
- (.visitInsn Opcodes/DUP))
- (let [tuple-class (str "test2/Tuple" (count ?members))]
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW tuple-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))
- (doseq [[?tfield ?member] (mapv vector (range (count ?members)) ?members)]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (do (compile-form (assoc *state* :form ?member)))
- (.visitFieldInsn Opcodes/PUTFIELD tuple-class (str "_" ?tfield) "Ljava/lang/Object;"))))
- (doto *writer*
- (.visitFieldInsn Opcodes/PUTFIELD variant-class* "value" "Ljava/lang/Object;"))
- ))
-
-(defcompiler compile-import
- [::&analyser/import ?class]
- nil)
-
-(defcompiler compile-require
- [::&analyser/require ?file ?alias]
- (let [module-name (re-find #"[^/]+$" ?file)
- ;; _ (prn 'module-name module-name)
- source-code (slurp (str module-name ".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 [<name> <tag> <regex>]
- (def <name>
- (exec [token (lex-regex <regex>)]
- (return [<tag> token])))
-
- ^:private lex-boolean ::boolean #"^(true|false)"
- ^:private lex-float ::float #"^(0|[1-9][0-9]*)\.[0-9]+"
- ^:private lex-int ::int #"^(0|[1-9][0-9]*)"
- ^:private lex-ident ::ident +ident-re+)
-
-(def ^:private lex-char
- (exec [_ (lex-str "#\"")
- token (try-all-m [(exec [escaped (lex-regex #"^(\\.)")]
- (escape-char escaped))
- (lex-regex #"^(.)")])
- _ (lex-str "\"")]
- (return [::char token])))
-
-(def ^:private lex-string
- (exec [_ (lex-str "\"")
- ;; state &util/get-state
- ;; :let [_ (prn 'PRE state)]
- token lex-string-body
- _ (lex-str "\"")
- ;; state &util/get-state
- ;; :let [_ (prn 'POST state)]
- ]
- (return [::string token])))
-
-(def ^:private lex-single-line-comment
- (exec [_ (lex-str "##")
- comment (lex-regex #"^([^\n]*)")
- _ (lex-regex #"^(\n?)")
- ;; :let [_ (prn 'comment comment)]
- ]
- (return [::comment comment])))
-
-(def ^:private lex-multi-line-comment
- (exec [_ (lex-str "#(")
- ;; :let [_ (prn 'OPEN)]
- ;; comment (lex-regex #"^(#\(.*\)#)")
- comment (try-all-m [(lex-regex #"(?is)^((?!#\().)*?(?=\)#)")
- (exec [pre (lex-regex #"(?is)^(.+?(?=#\())")
- ;; :let [_ (prn 'PRE pre)]
- [_ inner] lex-multi-line-comment
- ;; :let [_ (prn 'INNER inner)]
- post (lex-regex #"(?is)^(.+?(?=\)#))")
- ;:let [_ (prn 'POST post)]
- ]
- (return (str pre "#(" inner ")#" post)))])
- ;; :let [_ (prn 'COMMENT comment)]
- _ (lex-str ")#")
- ;; :let [_ (prn 'CLOSE)]
- ;; :let [_ (prn 'multi-comment comment)]
- ]
- (return [::comment comment])))
-
-(def ^:private lex-tag
- (exec [_ (lex-str "#")
- token (lex-regex +ident-re+)]
- (return [::tag token])))
-
-(def ^:private lex-form
- (exec [_ (try-m lex-white-space)
- form (try-all-m [lex-boolean
- lex-float
- lex-int
- lex-char
- lex-string
- lex-ident
- lex-tag
- lex-list
- lex-tuple
- lex-record
- lex-single-line-comment
- lex-multi-line-comment])
- _ (try-m lex-white-space)]
- (return form)))
-
-(def lex-forms
- (exec [forms (repeat-m lex-form)]
- (return (filter #(match %
- [::comment _]
- false
- _
- true)
- forms))))
-
-(def ^:private lex-list
- (exec [_ (lex-str "(")
- members lex-forms
- _ (lex-str ")")]
- (return [::list members])))
-
-(def ^:private lex-tuple
- (exec [_ (lex-str "[")
- members lex-forms
- _ (lex-str "]")]
- (return [::tuple members])))
-
-(def ^:private lex-record
- (exec [_ (lex-str "{")
- members lex-forms
- _ (lex-str "}")]
- (return [::record members])))
-
-;; [Interface]
-(defn lex [text]
- (match (lex-forms text)
- [::&util/ok [?state ?forms]]
- (if (empty? ?state)
- ?forms
- (assert false (str "Unconsumed input: " ?state)))
-
- [::&util/failure ?message]
- (assert false ?message)))
diff --git a/src/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 [<name> <input-tag> <output-tag> <method>]
- (defparser <name>
- [<input-tag> ?value]
- (return [<output-tag> (<method> ?value)]))
-
-
- ^:private parse-boolean ::&lexer/boolean ::boolean Boolean/parseBoolean
- ^:private parse-int ::&lexer/int ::int Integer/parseInt
- ^:private parse-float ::&lexer/float ::float Float/parseFloat
- )
-
-(defparser ^:private parse-char
- [::&lexer/char ?value]
- (return [::char (.charAt ?value 0)]))
-
-(defn ident->string [ident]
- (match ident
- [::&lexer/ident ?ident]
- ?ident))
-
-(defparser ^:private parse-ident
- [::&lexer/ident ?ident]
- (return [::ident ?ident]))
-
-(defparser ^:private parse-tuple
- [::&lexer/tuple ?parts]
- (exec [=parts (map-m (fn [arg] (apply-m parse-form (list arg)))
- ?parts)]
- (return [::tuple =parts])))
-
-(defparser ^:private parse-record
- [::&lexer/record ?parts]
- (exec [=kvs (do (assert (even? (count ?parts)))
- (map-m #(match %
- ([[::&lexer/tag ?label] ?value] :seq)
- (exec [=value (apply-m parse-form (list ?value))]
- (return [?label =value])))
- (partition 2 ?parts)))]
- (return [::record =kvs])))
-
-(defparser ^:private parse-lambda
- [::&lexer/list ([[::&lexer/ident "lambda"] [::&lexer/tuple ?args] ?body] :seq)]
- (exec [=body (apply-m parse-form (list ?body))]
- (return [::lambda (mapv ident->string ?args) =body])))
-
-(defparser ^:private parse-def
- [::&lexer/list ([[::&lexer/ident "def"] ?name ?body] :seq)]
- (exec [=name (apply-m parse-form (list ?name))
- =body (apply-m parse-form (list ?body))]
- (return [::def =name =body])))
-
-(defparser ^:private parse-defmacro
- [::&lexer/list ([[::&lexer/ident "defmacro"] ?name ?body] :seq)]
- (exec [=name (apply-m parse-form (list ?name))
- =body (apply-m parse-form (list ?body))]
- (return [::defmacro =name =body])))
-
-(defparser ^:private parse-defdata
- [::&lexer/list ([[::&lexer/ident "defdata"] ?type & ?cases] :seq)]
- (exec [=type (apply-m parse-form (list ?type))
- =cases (map-m (fn [arg]
- (match arg
- [::&lexer/list ([[::&lexer/tag ?tag] ?data] :seq)]
- (exec [=data (apply-m parse-form (list ?data))]
- (return [::tagged ?tag =data]))
- ))
- ?cases)]
- (return [::defdata =type =cases])))
-
-(defparser ^:private parse-if
- [::&lexer/list ([[::&lexer/ident "if"] ?test ?then ?else] :seq)]
- (exec [=test (apply-m parse-form (list ?test))
- =then (apply-m parse-form (list ?then))
- =else (apply-m parse-form (list ?else))]
- (return [::if =test =then =else])))
-
-(defparser ^:private parse-do
- [::&lexer/list ([[::&lexer/ident "do"] & ?exprs] :seq)]
- (exec [=exprs (map-m #(apply-m parse-form (list %))
- ?exprs)]
- (return [::do =exprs])))
-
-(defparser ^:private parse-case
- [::&lexer/list ([[::&lexer/ident "case"] ?variant & cases] :seq)]
- (exec [=variant (apply-m parse-form (list ?variant))
- =branches (do (assert (even? (count cases)))
- (map-m (fn [[destruct expr]]
- (exec [=destruct (apply-m parse-form (list destruct))
- =expr (apply-m parse-form (list expr))]
- (return [::case-branch =destruct =expr])))
- (partition 2 cases)))]
- (return [::case =variant =branches])))
-
-(defparser ^:private parse-let
- [::&lexer/list ([[::&lexer/ident "let"] [::&lexer/ident ?label] ?value ?body] :seq)]
- (exec [=value (apply-m parse-form (list ?value))
- =body (apply-m parse-form (list ?body))]
- (return [::let ?label =value =body])))
-
-(defparser ^:private parse-import
- [::&lexer/list ([[::&lexer/ident "import"] [::&lexer/ident ?class]] :seq)]
- (return [::import ?class]))
-
-(defparser ^:private parse-require
- [::&lexer/list ([[::&lexer/ident "require"] [::&lexer/string ?file] [::&lexer/ident "as"] [::&lexer/ident ?alias]] :seq)]
- (return [::require ?file ?alias]))
-
-(defparser ^:private parse-defclass
- [::&lexer/list ([[::&lexer/ident "defclass"] [::&lexer/ident ?name] [::&lexer/tuple ?fields]] :seq)]
- (let [fields (for [field ?fields]
- (match field
- [::&lexer/tuple ([[::&lexer/ident ?class] [::&lexer/ident ?field]] :seq)]
- [?class ?field]))]
- (return [::defclass ?name fields])))
-
-(defparser ^:private parse-definterface
- [::&lexer/list ([[::&lexer/ident "definterface"] [::&lexer/ident ?name] & ?members] :seq)]
- (let [members (for [field ?members]
- (match field
- [::&lexer/list ([[::&lexer/ident ":"] [::&lexer/ident ?member] [::&lexer/list ([[::&lexer/ident "->"] [::&lexer/tuple ?inputs] ?output] :seq)]] :seq)]
- [?member [(map ident->string ?inputs) (ident->string ?output)]]))]
- (return [::definterface ?name members])))
-
-(defparser ^:private parse-variant
- ?token
- (match ?token
- [::&lexer/tag ?tag]
- (return [::variant ?tag '()])
-
- [::&lexer/list ([[::&lexer/tag ?tag] & ?data] :seq)]
- (exec [=data (map-m #(apply-m parse-form (list %))
- ?data)]
- (return [::variant ?tag =data]))
-
- _
- (fail (str "Unmatched token: " ?token))))
-
-(defparser ^:private parse-get
- [::&lexer/list ([[::&lexer/ident "get@"] [::&lexer/tag ?tag] ?record] :seq)]
- (exec [=record (apply-m parse-form (list ?record))]
- (return [::get ?tag =record])))
-
-(defparser ^:private parse-remove
- [::&lexer/list ([[::&lexer/ident "remove@"] [::&lexer/tag ?tag] ?record] :seq)]
- (exec [=record (apply-m parse-form (list ?record))]
- (return [::remove ?tag =record])))
-
-(defparser ^:private parse-set
- [::&lexer/list ([[::&lexer/ident "set@"] [::&lexer/tag ?tag] ?value ?record] :seq)]
- (exec [=value (apply-m parse-form (list ?value))
- =record (apply-m parse-form (list ?record))]
- (return [::set ?tag =value =record])))
-
-(defparser ^:private parse-access
- [::&lexer/list ([[::&lexer/ident "::"] ?object ?call] :seq)]
- (exec [=object (apply-m parse-form (list ?object))
- =call (apply-m parse-form (list ?call))]
- (return [::access =object =call])))
-
-(defparser ^:private parse-string
- [::&lexer/string ?string]
- (return [::string ?string]))
-
-(defparser ^:private parse-fn-call
- [::&lexer/list ([?f & ?args] :seq)]
- (exec [=f (apply-m parse-form (list ?f))
- =args (map-m (fn [arg] (apply-m parse-form (list arg)))
- ?args)]
- (return [::fn-call =f =args])))
-
-(def ^:private parse-form
- (try-all-m [parse-boolean
- parse-int
- parse-float
- parse-char
- parse-string
- parse-ident
- parse-tuple
- parse-record
- parse-lambda
- parse-def
- parse-defmacro
- parse-defdata
- parse-if
- parse-do
- parse-case
- parse-let
- parse-variant
- parse-get
- parse-set
- parse-remove
- parse-access
- parse-defclass
- parse-definterface
- parse-import
- parse-require
- parse-fn-call]))
-
-;; [Interface]
-(defn parse [text]
- (match ((repeat-m parse-form) text)
- [::&util/ok [?state ?forms]]
- (if (empty? ?state)
- ?forms
- (assert false (str "Unconsumed input: " (pr-str ?state))))
-
- [::&util/failure ?message]
- (assert false ?message)))
diff --git a/src/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))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-12 21:42:47 +0000