From a37f958774bd0f7b1800a68a44492e4f95d26e8c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 15 Dec 2014 20:07:05 -0400 Subject: Added lambdas! (not yet real closures, but coming soon...) --- src/lang.clj | 26 +++++++------ src/lang/analyser.clj | 72 +++++++++++++++++++++++++++++----- src/lang/compiler.clj | 106 +++++++++++++++++++++++++++++++++++++++++++++++--- src/lang/parser.clj | 6 +++ src/lang/type.clj | 3 ++ 5 files changed, 186 insertions(+), 27 deletions(-) (limited to 'src') diff --git a/src/lang.clj b/src/lang.clj index c497c9923..0bbd74bf6 100644 --- a/src/lang.clj +++ b/src/lang.clj @@ -11,25 +11,29 @@ (.write stream data))) (comment - ;; TODO: Add lambdas. ;; TODO: Add pattern-matching. - ;; TODO: Add thunks. - ;; TODO: Add Java-interop. - ;; TODO: Do tail-call optimization. - ;; TODO: Add macros. - ;; TODO: Add signatures & structures OR type-classes. - ;; TODO: Add type-level computations. - ;; TODO: Add interpreter. - ;; TODO: Re-implement compiler in language. + ;; TODO: Add "do" expressions. ;; TODO: Add all the missing literal types. ;; TODO: Allow strings to have escape characters. - ;; TODO: Add "do" expressions. ;; TODO: Fold all closure classes into one. ;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly. ;; TODO: Add extra arities (apply2, apply3, ..., apply16) + ;; TODO: Tuple8 and Tuple8X (for arbitrary-size tuples). + ;; TODO: Allow "lambdas" to be closures. + ;; TODO: Add Java-interop. + ;; TODO: Add interpreter. + ;; TODO: Add macros. + ;; TODO: Re-implement compiler in language. + ;; TODO: Add signatures & structures OR type-classes. + ;; TODO: Add type-level computations. + ;; TODO: Add thunks. + ;; TODO: Do tail-call optimization. + ;; TODO: Adding metadata to global vars. + ;; TODO: Add records. ;; TODO: ;; TODO: - + ;; TODO: + (let [source-code (slurp "test2.lang") tokens (&lexer/lex source-code) ;; _ (prn 'tokens tokens) diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj index 122d6353d..d00fb7319 100644 --- a/src/lang/analyser.clj +++ b/src/lang/analyser.clj @@ -41,6 +41,28 @@ _ =return)))) +(defn ^:private with-fresh-env [body] + (fn [state] + (let [=return (body (update-in state [:env] + #(-> % + (assoc :counter 0) + (update-in [:mappings] (fn [ms] + (let [ms* (into {} (for [[k v] ms + :when (match (:form v) + [::local _] + false + _ + true)] + [k v]))] + (prn 'ms ms 'ms* ms*) + ms*))))))] + (match =return + [::&util/ok [?state ?value]] + [::&util/ok [(assoc ?state :env (:env state)) ?value]] + + _ + =return)))) + (defn ^:private import-class [long-name short-name] (fn [state] (let [=class (annotated [::class long-name] ::&type/nothing)] @@ -73,6 +95,7 @@ (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)))] @@ -103,7 +126,9 @@ (defanalyser analyse-ident [::&parser/ident ?ident] - (resolve ?ident)) + (exec [_env (fn [state] [::&util/ok [state (:env state)]]) + :let [_ (prn 'analyse-ident ?ident _env)]] + (resolve ?ident))) (defanalyser analyse-ann-class [::&parser/ann-class ?class ?members] @@ -127,15 +152,22 @@ (defanalyser analyse-fn-call [::&parser/fn-call ?fn ?args] - (exec [=fn (analyse-form* ?fn) - =args (map-m analyse-form* ?args)] - (return (annotated [::call =fn =args] ::&type/nothing)))) + (exec [:let [_ (prn 'PRE '?fn ?fn)] + =fn (analyse-form* ?fn) + :let [_ (prn '=fn =fn)] + =args (map-m analyse-form* ?args) + :let [_ (prn '=args =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) - =else (analyse-form* ?else)] + :let [_ (prn '=then =then)] + =else (analyse-form* ?else) + :let [_ (prn '=else =else)]] (return (annotated [::if =test =then =else] ::&type/nothing)))) (defanalyser analyse-let @@ -181,14 +213,14 @@ ?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)] + ;; :let [env (-> {} + ;; (assoc ?name =function) + ;; (into (map vector args =args))) + ;; _ (prn 'env env)] =value (reduce (fn [inner [label type]] (with-local label type inner)) (analyse-form* ?value) - (map vector args =args)) + (reverse (map vector args =args))) :let [_ (prn '=value =value)] =function (within :types (exec [_ (&type/solve =return (:type =value))] (&type/clean =function))) @@ -199,6 +231,25 @@ (return (annotated [::def [?name args] =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)] + =body (with-fresh-env + (reduce (fn [inner [label type]] + (with-local label type inner)) + (analyse-form* ?body) + (reverse (map vector ?args =args)))) + :let [_ (prn '=body =body)] + =function (within :types (exec [_ (&type/solve =return (:type =body))] + (&type/clean =function))) + :let [_ (prn '=function =function)]] + (return (annotated [::lambda ?args =body] =function)))) + (defanalyser analyse-import [::&parser/import ?class] (exec [_ (import-class ?class (last (string/split ?class #"\.")))] @@ -217,6 +268,7 @@ analyse-string analyse-variant analyse-tuple + analyse-lambda analyse-ident analyse-ann-class analyse-static-access diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj index e8f0207b3..b7079fecf 100644 --- a/src/lang/compiler.clj +++ b/src/lang/compiler.clj @@ -26,6 +26,7 @@ `(defn ~name [~'*state*] (let [~'*class-name* (:class-name ~'*state*) ~'*writer* (:writer ~'*state*) + ~'*parent* (:parent ~'*state*) ~'*type* (:type (:form ~'*state*))] (match (:form (:form ~'*state*)) ~match @@ -61,7 +62,10 @@ (->type-signature ?name) [::&type/variant ?tag ?value] - (->type-signature +variant-class+))) + (->type-signature +variant-class+) + + [::&type/function ?args ?return] + (->java-sig [::&type/object "test2/Function" []]))) ;; [Utils/Compilers] (defcompiler ^:private compile-literal @@ -119,6 +123,20 @@ [::&analyser/call ?fn ?args] (do (prn 'compile-call (:form ?fn) ?fn ?args) (match (:form ?fn) + [::&analyser/local _] + (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)))) + + [::&analyser/lambda _ ?body] + (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)))) + [::&analyser/global ?owner-class ?fn-name] (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;" signature "()V" @@ -127,7 +145,7 @@ (.visitTypeInsn Opcodes/NEW call-class) (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "" signature)) - (doseq [arg (reverse ?args)] + (doseq [arg ?args] (compile-form (assoc *state* :form arg)) (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature)) )))) @@ -143,7 +161,8 @@ (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") + (.visitInsn Opcodes/ACONST_NULL)))) (defcompiler ^:private compile-ann-class [::&analyser/ann-class ?class ?members] @@ -170,6 +189,7 @@ (let [start-label (new Label) end-label (new Label) ?idx (int ?idx)] + (prn '(:type ?value) (:type ?value) (->java-sig (:type ?value))) (.visitLocalVariable *writer* ?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* @@ -249,7 +269,7 @@ =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil) (.visitCode))] ;; (prn 'FN/?body ?body) - (assert (compile-form (assoc *state* :writer =method :form ?body)) (str "Body couldn't compile: " (pr-str ?body))) + (assert (compile-form (assoc *state* :parent *writer* :writer =method :form ?body)) (str "Body couldn't compile: " (pr-str ?body))) (doto =method (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -258,7 +278,7 @@ _ (prn 'signature signature) =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil) (.visitCode))] - (compile-form (assoc *state* :writer =method :form ?body)) + (compile-form (assoc *state* :parent *writer* :writer =method :form ?body)) (doto =method (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) @@ -266,6 +286,78 @@ (compile-method-function *writer* *class-name* ?name (count ?args))))) ))) +(defcompiler ^:private compile-lambda + [::&analyser/lambda ?args ?body] + (let [num-args (count ?args) + signature (str "(" (apply str (repeat num-args "Ljava/lang/Object;")) ")" "Ljava/lang/Object;") + outer-class (->class *class-name*) + clo-field-sig (->type-signature "java.lang.Object") + apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;" + real-signature (str "(" (apply str (repeat num-args "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")] + (doseq [idx (range num-args) + :let [has-next? (not= idx (dec num-args)) + local-name (str "lambda_" idx) + current-class (str outer-class "$" local-name) + next-class (str outer-class "$" "lambda_" (inc idx)) + current-signature (str "(" (apply str (repeat idx "Ljava/lang/Object;")) ")" "V") + next-signature (str "(" (apply str (repeat (inc idx) "Ljava/lang/Object;")) ")" "V")]] + (.visitInnerClass *parent* current-class outer-class local-name (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) + (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + current-class nil "java/lang/Object" (into-array ["test2/Function"]))) + _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC "" current-signature nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc clo_idx)) + (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig)) + (->> (let [field-name (str "_" clo_idx)] + (doto (.visitField =class Opcodes/ACC_PUBLIC field-name clo-field-sig nil nil) + (.visitEnd))) + (dotimes [clo_idx idx]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + =method (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil) + (.visitCode)) + _ (do (when has-next? + (doto =method + (.visitTypeInsn Opcodes/NEW next-class) + (.visitInsn Opcodes/DUP))) + (doto =method + (-> (doto (.visitVarInsn Opcodes/ALOAD (int 0)) + (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig)) + (->> (dotimes [clo_idx idx]))) + (.visitVarInsn Opcodes/ALOAD (int 1))) + (if has-next? + (.visitMethodInsn =method Opcodes/INVOKESPECIAL next-class "" next-signature) + (.visitMethodInsn =method Opcodes/INVOKESTATIC outer-class "lambda_impl" real-signature)) + (doto =method + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (.visitEnd =class))] + (println "OUTPUT LAMBDA:" (str current-class ".class")) + (write-file (str current-class ".class") (.toByteArray =class)))) + (let [=method (doto (.visitMethod *parent* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "lambda_impl" real-signature nil nil) + (.visitCode))] + (prn '(:form ?body) (:form ?body)) + (compile-form (assoc *state* :parent *parent* :writer =method :form ?body)) + (doto =method + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + ;; (compile-form (assoc *state* :writer =method :form ?body)) + ;; (compile-method-function *writer* *class-name* ?name (count ?args)) + ) + (let [init-class (str outer-class "$" "lambda_0")] + (doto *writer* + (.visitTypeInsn Opcodes/NEW init-class) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL init-class "" "()V"))) + )) + (defcompiler ^:private compile-defclass [::&analyser/defclass [?package ?name] ?members] (let [parent-dir (->package ?package) @@ -351,6 +443,7 @@ compile-ann-class compile-if compile-let + compile-lambda compile-def compile-defclass compile-definterface @@ -372,7 +465,8 @@ ;; "output" nil "java/lang/Object" nil)) state {:class-name class-name :writer =class - :form nil}] + :form nil + :parent nil}] ;; (doto (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) ;; (.visitCode) ;; (.visitVarInsn Opcodes/ALOAD 0) diff --git a/src/lang/parser.clj b/src/lang/parser.clj index 3149cf5d4..2f9a26c66 100644 --- a/src/lang/parser.clj +++ b/src/lang/parser.clj @@ -56,6 +56,11 @@ (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)) @@ -192,6 +197,7 @@ parse-ident parse-tuple parse-record + parse-lambda parse-def parse-defdata parse-if diff --git a/src/lang/type.clj b/src/lang/type.clj index 2f708867e..465f6e9fc 100644 --- a/src/lang/type.clj +++ b/src/lang/type.clj @@ -79,5 +79,8 @@ =return (clean ?return)] (return [::function =args =return])) + ;; ::any + ;; (return [::object "java.lang.Object" []]) + _ (return type))) -- cgit v1.2.3