diff options
Diffstat (limited to 'src/lang')
| -rw-r--r-- | src/lang/analyser.clj | 191 | ||||
| -rw-r--r-- | src/lang/compiler.clj | 207 | ||||
| -rw-r--r-- | src/lang/type.clj | 81 | ||||
| -rw-r--r-- | src/lang/util.clj | 9 |
4 files changed, 393 insertions, 95 deletions
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj new file mode 100644 index 000000000..a7f6a7dd5 --- /dev/null +++ b/src/lang/analyser.clj @@ -0,0 +1,191 @@ +(ns lang.analyser + (: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 within]] + [parser :as &parser] + [type :as &type]))) + +(declare analyse-form) + +;; [Util] +(defn ^:private with-env [env monad] + (fn [state] + (let [=return (monad (update-in state [:env] merge env))] + (match =return + [::&util/ok [?state ?value]] + [::&util/ok [(assoc ?state :env (:env state)) ?value]] + + _ + =return)))) + +(def ^:private module-name + (fn [state] + [::&util/ok [state (:name state)]])) + +(defn ^:private resolve [ident] + (fn [state] + (if-let [=ident (get-in state [:env ident])] + [::&util/ok [state =ident]] + [::&util/failure (str "Unresolved identifier: " ident)]))) + +(defn ^:private define [name desc] + (fn [state] + [::&util/ok [(assoc-in state [:defs (:name state) name] desc) nil]])) + +(defn ^:private annotated [form type] + {:form form + :type type}) + +(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] + (fn [state] + (let [old-forms (:forms state) + =return (analyse-form (assoc state :forms (list form)))] + (match =return + [::&util/ok [?state ?value]] + [::&util/ok [(assoc ?state :forms old-forms) ?value]] + + _ + =return)))) + +(defanalyser analyse-boolean + [::&parser/boolean ?boolean] + (return (annotated [::literal ?boolean] [::&type/object "java.lang.Boolean" []]))) + +(defanalyser analyse-string + [::&parser/string ?string] + (return (annotated [::literal ?string] [::&type/object "java.lang.String" []]))) + +(defanalyser analyse-variant + [::&parser/tagged ?tag ?value] + (exec [=value (analyse-form* ?value)] + (return (annotated [::variant ?tag =value] [::&type/variant ?tag (:type =value)])))) + +(defanalyser analyse-ident + [::&parser/ident ?name] + (exec [=ident (resolve ?name)] + (return (annotated [::ident ?name] =ident)))) + +(defanalyser analyse-ann-class + [::&parser/ann-class ?class ?members] + (return (annotated [::ann-class ?class ?members] ::&type/nothing))) + +(defanalyser analyse-static-access + [::&parser/static-access ?class ?member] + (return (annotated [::static-access ?class ?member] ::&type/nothing))) + +(defanalyser analyse-dynamic-access + [::&parser/dynamic-access ?object ?member] + (exec [=object (analyse-form* ?object)] + (match ?member + [::&parser/fn-call [::&parser/ident ?method] ?args] + (exec [=args (map-m analyse-form* ?args)] + (return (annotated [::dynamic-access =object [?method =args]] ::&type/nothing)))))) + +(defanalyser analyse-fn-call + [::&parser/fn-call [::&parser/ident ?fn] ?args] + (exec [name module-name + =args (map-m analyse-form* ?args)] + (return (annotated [::call [name ?fn] =args] ::&type/nothing)))) + +(defanalyser analyse-if + [::&parser/if ?test ?then ?else] + (exec [=test (analyse-form* ?test) + =then (analyse-form* ?then) + =else (analyse-form* ?else)] + (return (annotated [::if =test =then =else] ::&type/nothing)))) + +(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 (analyse-form* ?value) + _ (define ?name {:mode ::constant + :access ::public + :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-env env + (analyse-form* ?value)) + :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-module + [::&parser/module] + (exec [name module-name] + (return (annotated [::module name] ::&type/nothing)))) + +(def ^:private analyse-form + (try-all-m [analyse-boolean + analyse-string + analyse-variant + analyse-ident + analyse-ann-class + analyse-static-access + analyse-dynamic-access + analyse-fn-call + analyse-if + analyse-defclass + analyse-definterface + analyse-def + analyse-module])) + +;; [Interface] +(defn analyse [module-name tokens] + (match ((repeat-m analyse-form) {:name module-name, + :forms tokens + :env {} + :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 index dbc088668..1976c48e9 100644 --- a/src/lang/compiler.clj +++ b/src/lang/compiler.clj @@ -2,7 +2,9 @@ (:refer-clojure :exclude [compile]) (:require [clojure.string :as string] [clojure.core.match :refer [match]] - [lang.parser :as &parser] + (lang [type :as &type] + [parser :as &parser] + [analyser :as &analyser]) :reload) (:import (org.objectweb.asm Opcodes Label @@ -12,21 +14,18 @@ (declare compile-form) ;; [Utils/General] +(def ^:private +variant-class+ "test2.Tagged") + (defmacro ^:private defcompiler [name match body] `(defn ~name [~'*state*] - (let [~'*name* (:name ~'*state*) - ~'*writer* (:writer ~'*state*) - ~'*form* (:form ~'*state*)] - (match ~'*form* + (let [~'*writer* (:writer ~'*state*)] + (match (:form (:form ~'*state*)) ~match (do ~body true) _# false)))) -(defn compile-form* [writer form] - (compile-form {:writer writer, :form form})) - (defn ^:private unwrap-ident [ident] (match ident [::&parser/ident ?label] @@ -40,78 +39,98 @@ (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/object ?name []] + (->type-signature ?name) + + [::&type/variant ?tag ?value] + (->type-signature +variant-class+))) + ;; [Utils/Compilers] -(defcompiler ^:private compile-boolean - [::&parser/boolean ?boolean] - (if ?boolean - (.visitLdcInsn *writer* (int 1)) - (.visitLdcInsn *writer* (int 0)))) +(defcompiler ^:private compile-literal + [::&analyser/literal ?literal] + (cond (string? ?literal) + (.visitLdcInsn *writer* ?literal) + + (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"))) -(defcompiler ^:private compile-string - [::&parser/string ?string] - (.visitLdcInsn *writer* ?string)) + :else + (assert false (str "[Unknown literal type] " ?literal " : " (class ?literal))))) (defcompiler ^:private compile-ident - [::&parser/ident ?name] + [::&analyser/ident ?name] (doto *writer* - (.visitVarInsn Opcodes/ALOAD (int 0))) - ;; nil - ) + (.visitVarInsn Opcodes/ALOAD (int 0)))) -(defcompiler ^:private compile-fn-call - [::&parser/fn-call [::&parser/ident ?fn] ?args] +(defcompiler ^:private compile-call + [::&analyser/call [?owner-class ?fn] ?args] (do (doseq [arg ?args] (compile-form (assoc *state* :form arg))) (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (->class *name*) ?fn "(Ljava/lang/Object;)Ljava/lang/Object;")))) + (.visitMethodInsn Opcodes/INVOKESTATIC (->class ?owner-class) ?fn "(Ljava/lang/Object;)Ljava/lang/Object;")))) (defcompiler ^:private compile-static-access - [::&parser/static-access ?class ?member] + [::&analyser/static-access ?class ?member] (doto *writer* (.visitFieldInsn Opcodes/GETSTATIC (->class ?class) ?member (->type-signature "java.io.PrintStream")))) (defcompiler ^:private compile-dynamic-access - [::&parser/dynamic-access ?object ?access] - (let [=object (compile-form (assoc *state* :form ?object)) - method (match ?access - [::&parser/fn-call [::&parser/ident ?method] ?args] - (do (doseq [arg ?args] - (compile-form (assoc *state* :form arg))) - ?method))] + [::&analyser/dynamic-access ?object [?method ?args]] + (do (compile-form (assoc *state* :form ?object)) + (doseq [arg ?args] + (compile-form (assoc *state* :form arg))) (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") method "(Ljava/lang/Object;)V")))) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") ?method "(Ljava/lang/Object;)V")))) (defcompiler ^:private compile-ann-class - [::&parser/ann-class ?class ?members] + [::&analyser/ann-class ?class ?members] nil) (defcompiler ^:private compile-if - [::&parser/if ?test ?then ?else] + [::&analyser/if ?test ?then ?else] (let [else-label (new Label) end-label (new Label)] - (compile-form (assoc *state* :form ?test)) - (.visitJumpInsn *writer* Opcodes/IFEQ else-label) - (compile-form (assoc *state* :form ?then)) + (println "PRE") + (assert (compile-form (assoc *state* :form ?test)) "CAN't COMPILE TEST") + (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Boolean") "booleanValue" "()Z") + (.visitJumpInsn Opcodes/IFEQ else-label)) + (assert (compile-form (assoc *state* :form ?then)) "CAN't COMPILE THEN") (doto *writer* (.visitJumpInsn Opcodes/GOTO end-label) (.visitLabel else-label)) - (compile-form (assoc *state* :form ?else)) + (assert (compile-form (assoc *state* :form ?else)) "CAN't COMPILE ELSE") (.visitLabel *writer* end-label))) (defcompiler ^:private compile-def - [::&parser/def ?form ?body] + [::&analyser/def ?form ?body] (match ?form - [::&parser/fn-call [::&parser/ident ?name] ?args] + (?name :guard string?) + (let [=type (:type ?body) + _ (prn '?body ?body)] + (doto (.visitField *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name (->java-sig =type) nil nil) + (.visitEnd))) + + [?name ?args] (if (= "main" ?name) (let [=method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name "([Ljava/lang/String;)V" nil nil) (.visitCode))] - (compile-form (assoc *state* :writer =method :form ?body)) + (prn 'FN/?body ?body) + (assert (compile-form (assoc *state* :writer =method :form ?body)) (str "Body couldn't compile: " (pr-str ?body))) (doto =method (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -123,23 +142,21 @@ (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd)))) - [::&parser/ident ?name] - (doto (.visitField *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name "Ljava/lang/Object;" nil nil) - (.visitEnd)) )) (defcompiler ^:private compile-module - [::&parser/module] + [::&analyser/module ?name] (.visit *writer* Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (->class *name*) nil "java/lang/Object" nil)) + (->class ?name) nil "java/lang/Object" nil)) (defcompiler ^:private compile-defclass - [::&parser/defclass ?name ?fields] - (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + [::&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) - (->class (str *name* "." ?name)) nil "java/lang/Object" nil))] - (doseq [[class field] ?fields] - (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature class) nil nil) + (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) @@ -149,46 +166,45 @@ (.visitMaxs 0 0) (.visitEnd)) (.visitEnd =class) - (let [parent-dir (->class *name*)] - (.mkdirs (java.io.File. parent-dir)) - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))] - (.write stream (.toByteArray =class)))))) + (.mkdirs (java.io.File. parent-dir)) + (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))] + (.write stream (.toByteArray =class))))) (defcompiler ^:private compile-definterface - [::&parser/definterface ?name ?members] - (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + [::&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_ABSTRACT Opcodes/ACC_INTERFACE) - (->class (str *name* "." ?name)) nil "java/lang/Object" nil))] - (doseq [[?method [?args ?return]] ?members - :let [signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]] + (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) ?method signature nil nil)) (.visitEnd =interface) - (let [parent-dir (->class *name*)] - (.mkdirs (java.io.File. parent-dir)) - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))] - (.write stream (.toByteArray =interface)))))) - -(let [+tagged+ "test2/Tagged"] - (defcompiler ^:private compile-tagged - [::&parser/tagged ?tag ?value] - (do (prn 'compile-tagged ?tag ?value) - (doto *writer* - (.visitTypeInsn Opcodes/NEW +tagged+) - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL +tagged+ "<init>" "()V") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?tag) - (.visitFieldInsn Opcodes/PUTFIELD +tagged+ "tag" "Ljava/lang/String;") - (.visitInsn Opcodes/DUP)) - (compile-form (assoc *state* :form ?value)) - (doto *writer* - (.visitFieldInsn Opcodes/PUTFIELD +tagged+ "value" "Ljava/lang/Object;")) - ))) - -(let [+compilers+ [compile-boolean - compile-string + (.mkdirs (java.io.File. parent-dir)) + (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))] + (.write stream (.toByteArray =interface))))) + +(defcompiler ^:private compile-variant + [::&analyser/variant ?tag ?value] + (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" "Ljava/lang/String;") + (.visitInsn Opcodes/DUP)) + (assert (compile-form (assoc *state* :form ?value)) (pr-str "Can't compile value: " ?value)) + (doto *writer* + (.visitFieldInsn Opcodes/PUTFIELD variant-class* "value" "Ljava/lang/Object;")) + )) + +(let [+compilers+ [compile-literal compile-ident - compile-fn-call + compile-call compile-static-access compile-dynamic-access compile-ann-class @@ -197,10 +213,11 @@ compile-module compile-defclass compile-definterface - compile-tagged]] + compile-variant]] (defn ^:private compile-form [state] (prn 'compile-form/state state) - (some #(% state) +compilers+))) + (or (some #(% state) +compilers+) + (assert false (str "Can't compile: " (pr-str (:form state))))))) ;; [Interface] (defn compile [class-name inputs] @@ -209,8 +226,7 @@ ;; (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) ;; (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) ;; "output" nil "java/lang/Object" nil)) - state {:name class-name - :writer =class + state {:writer =class :form nil}] ;; (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil) ;; (.visitCode) @@ -223,19 +239,22 @@ (when (not (compile-form (assoc state :form input))) (assert false input))) ;; (doall (map #(compile-form (assoc state :form %)) inputs)) + (prn 'inputs inputs) (when-let [constants (seq (for [input inputs - :let [payload (match input - [::&parser/def [::&parser/ident ?name] ?body] + :let [payload (match (:form input) + [::&analyser/def (?name :guard string?) ?body] [?name ?body] _ nil)] :when payload] payload))] (let [=init (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) - (.visitCode))] + (.visitCode)) + state* (assoc state :writer =init) + class-name* (->class class-name)] (doseq [[?name ?body] constants] - (do (compile-form (assoc state :writer =init :form ?body)) - (.visitFieldInsn =init Opcodes/PUTSTATIC (->class class-name) ?name "Ljava/lang/Object;"))) + (do (assert (compile-form (assoc state* :form ?body)) (str "Couldn't compile init: " (pr-str ?body))) + (.visitFieldInsn =init Opcodes/PUTSTATIC class-name* ?name (->java-sig (:type ?body))))) (doto =init (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) diff --git a/src/lang/type.clj b/src/lang/type.clj index cab0ebeec..2f708867e 100644 --- a/src/lang/type.clj +++ b/src/lang/type.clj @@ -1,4 +1,83 @@ -(ns lang.type) +(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]])) +;; [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] + (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)])) + + [_ _] + (fail (str "Can't solve types: " (pr-str expected actual))) + )) + +(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])) + + _ + (return type))) diff --git a/src/lang/util.clj b/src/lang/util.clj index d9745e9ab..ec93ac27f 100644 --- a/src/lang/util.clj +++ b/src/lang/util.clj @@ -112,3 +112,12 @@ (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)))) |