From d389e983ff4f5d5b01219220ee50f52090816d43 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 16 Dec 2014 02:31:44 -0400 Subject: Added some pseudo pattern-matching (only extracting simple data, without exploring inner structure or doing any testing). --- src/lang.clj | 3 +- src/lang/analyser.clj | 83 +++++++++++++++++++++++++----------- src/lang/compiler.clj | 116 ++++++++++++++++++++++++++++++++------------------ src/lang/lexer.clj | 11 ++--- 4 files changed, 140 insertions(+), 73 deletions(-) (limited to 'src') diff --git a/src/lang.clj b/src/lang.clj index 0aaba1b81..f12ffc8d5 100644 --- a/src/lang.clj +++ b/src/lang.clj @@ -11,7 +11,6 @@ (.write stream data))) (comment - ;; TODO: Add pattern-matching. ;; 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) @@ -28,7 +27,7 @@ ;; TODO: Adding metadata to global vars. ;; TODO: Add records. ;; TODO: throw, try, catch, finally - ;; TODO: + ;; TODO: Finish implementing pattern matching. ;; TODO: (let [source-code (slurp "test2.lang") diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj index 0cab85f66..bc48a0c81 100644 --- a/src/lang/analyser.clj +++ b/src/lang/analyser.clj @@ -55,7 +55,7 @@ _ true)] [k v]))] - (prn 'ms ms 'ms* ms*) + ;; (prn 'ms ms 'ms* ms*) ms*))))))] (match =return [::&util/ok [?state ?value]] @@ -80,7 +80,7 @@ (fn [state] (if-let [[_ ?alias ?binding] (re-find #"^(.*)/(.*)$" ident)] (let [?module (get-in state [:deps ?alias])] - (prn 'resolve ?module ?alias ?binding) + ;; (prn 'resolve ?module ?alias ?binding) [::&util/ok [state (annotated [::global ?module ?binding] ::&type/nothing)]]) (if-let [resolved (get-in state [:env :mappings ident])] [::&util/ok [state resolved]] @@ -96,10 +96,12 @@ (fail* (str "Unmatched token: " token#)))))) (defn analyse-form* [form] - (prn 'analyse-form* form) + ;; (prn 'analyse-form* form) (fn [state] (let [old-forms (:forms state) - =return (analyse-form (assoc state :forms (list form)))] + =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]] @@ -121,7 +123,10 @@ (defanalyser analyse-variant [::&parser/tagged ?tag ?value] - (exec [=value (analyse-form* ?value)] + (exec [;; :let [_ (prn 'analyse-variant [?tag ?value])] + =value (analyse-form* ?value) + ;; :let [_ (prn '=value =value)] + ] (return (annotated [::variant ?tag =value] [::&type/variant ?tag (:type =value)])))) (defanalyser analyse-tuple @@ -132,7 +137,8 @@ (defanalyser analyse-ident [::&parser/ident ?ident] (exec [_env (fn [state] [::&util/ok [state (:env state)]]) - :let [_ (prn 'analyse-ident ?ident _env)]] + ;; :let [_ (prn 'analyse-ident ?ident _env)] + ] (resolve ?ident))) (defanalyser analyse-ann-class @@ -142,7 +148,8 @@ (defanalyser analyse-static-access [::&parser/static-access ?target ?member] (exec [=target (resolve ?target) - :let [_ (prn '=target ?target (:form =target))]] + ;; :let [_ (prn '=target ?target (:form =target))] + ] (match (:form =target) [::class ?class] (return (annotated [::static-access ?class ?member] ::&type/nothing))))) @@ -157,22 +164,24 @@ (defanalyser analyse-fn-call [::&parser/fn-call ?fn ?args] - (exec [:let [_ (prn 'PRE '?fn ?fn)] + (exec [;; :let [_ (prn 'PRE '?fn ?fn)] =fn (analyse-form* ?fn) - :let [_ (prn '=fn =fn)] + ;; :let [_ (prn '=fn =fn)] =args (map-m analyse-form* ?args) - :let [_ (prn '=args =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)] + ;; :let [_ (prn '=test =test)] + ;; :let [_ (prn 'PRE '?then ?then)] =then (analyse-form* ?then) - :let [_ (prn '=then =then)] + ;; :let [_ (prn '=then =then)] =else (analyse-form* ?else) - :let [_ (prn '=else =else)]] + ;; :let [_ (prn '=else =else)] + ] (return (annotated [::if =test =then =else] ::&type/nothing)))) (defanalyser analyse-do @@ -180,6 +189,27 @@ (exec [=exprs (map-m analyse-form* ?exprs)] (return (annotated [::do =exprs] (-> =exprs last :type))))) +(defanalyser analyse-case + [::&parser/case ?variant ?branches] + (exec [;; :let [_ (prn '?variant ?variant)] + =variant (analyse-form* ?variant) + ;; :let [_ (prn '=variant =variant)] + =branches (map-m (fn [branch] + ;; (prn 'branch branch) + (match branch + [::&parser/case-branch [::&parser/tagged ?tag [::&parser/ident ?label]] ?body] + (exec [;; :let [_ (prn ?tag ?label '?body ?body)] + idx next-local-idx + =body (with-local ?label [::&type/object "java.lang.Object" []] + (analyse-form* ?body)) + ;; :let [_ (prn ?tag ?label '=body =body)] + ] + (return [?tag ?label idx =body])))) + ?branches) + ;; :let [_ (prn '=branches =branches)] + ] + (return (annotated [::case =variant =branches] ::&type/nothing)))) + (defanalyser analyse-let [::&parser/let ?label ?value ?body] (exec [=value (analyse-form* ?value) @@ -222,7 +252,7 @@ [::&parser/ident ?ident] ?ident))] (exec [[=function =args =return] (within :types (&type/fresh-function (count args))) - :let [_ (prn '[=function =args =return] [=function =args =return])] + ;; :let [_ (prn '[=function =args =return] [=function =args =return])] ;; :let [env (-> {} ;; (assoc ?name =function) ;; (into (map vector args =args))) @@ -231,10 +261,10 @@ (with-local label type inner)) (analyse-form* ?value) (reverse (map vector args =args))) - :let [_ (prn '=value =value)] + ;; :let [_ (prn '=value =value)] =function (within :types (exec [_ (&type/solve =return (:type =value))] (&type/clean =function))) - :let [_ (prn '=function =function)] + ;; :let [_ (prn '=function =function)] _ (define ?name {:mode ::function :access ::public :type =function})] @@ -243,21 +273,22 @@ (defanalyser analyse-lambda [::&parser/lambda ?args ?body] - (exec [:let [_ (prn 'analyse-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)] + ;; :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)] + ;; :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)] + ;; :let [_ (prn '=body =body)] =function (within :types (exec [_ (&type/solve =return (:type =body))] (&type/clean =function))) - :let [_ (prn '=function =function)]] + ;; :let [_ (prn '=function =function)] + ] (return (annotated [::lambda ?args =body] =function)))) (defanalyser analyse-import @@ -267,9 +298,10 @@ (defanalyser analyse-require [::&parser/require ?file ?alias] - (let [_ (prn `[require ~?file ~?alias]) + (let [;; _ (prn `[require ~?file ~?alias]) module-name (re-find #"[^/]+$" ?file) - _ (prn 'module-name module-name)] + ;; _ (prn 'module-name module-name) + ] (exec [_ (require-module module-name ?alias)] (return (annotated [::require ?file ?alias] ::&type/nothing))))) @@ -289,6 +321,7 @@ analyse-fn-call analyse-if analyse-do + analyse-case analyse-let analyse-defclass analyse-definterface diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj index b29bc38d1..48cbe3999 100644 --- a/src/lang/compiler.clj +++ b/src/lang/compiler.clj @@ -142,7 +142,7 @@ (defcompiler ^:private compile-call [::&analyser/call ?fn ?args] - (do (prn 'compile-call (:form ?fn) ?fn ?args) + (do ;; (prn 'compile-call (:form ?fn) ?fn ?args) (match (:form ?fn) [::&analyser/local _] (do (compile-form (assoc *state* :form ?fn)) @@ -198,7 +198,7 @@ (doto *writer* (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Boolean") "booleanValue" "()Z") (.visitJumpInsn Opcodes/IFEQ else-label)) - (prn 'compile-if/?then (:form ?then)) + ;; (prn 'compile-if/?then (:form ?then)) (assert (compile-form (assoc *state* :form ?then)) "CAN't COMPILE THEN") (doto *writer* (.visitJumpInsn Opcodes/GOTO end-label) @@ -213,12 +213,45 @@ (.visitInsn *writer* Opcodes/POP)) (compile-form (assoc *state* :form (last ?exprs))))) +(let [oclass (->class "java.lang.Object") + equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] + (defcompiler ^:private compile-case + [::&analyser/case ?variant ?branches] + (do (compile-form (assoc *state* :form ?variant)) + (let [end-label (new Label)] + (doseq [[?tag ?label ?idx ?body] ?branches] + ;; (prn '[?tag ?label ?idx ?body] [?tag ?label ?idx ?body]) + (let [else-label (new Label)] + (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "tag" "Ljava/lang/String;") + (.visitLdcInsn ?tag) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) + (.visitJumpInsn Opcodes/IFEQ else-label)) + (let [start-label (new Label) + end-label (new Label)] + (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitFieldInsn Opcodes/GETFIELD (->class +variant-class+) "value" (->type-signature "java.lang.Object"))) + (.visitLocalVariable *writer* ?label (->type-signature "java.lang.Object") nil start-label end-label ?idx) + (doto *writer* + (.visitVarInsn Opcodes/ASTORE ?idx) + (.visitLabel start-label) + (.visitInsn Opcodes/POP)) + (compile-form (assoc *state* :form ?body)) + (.visitLabel *writer* end-label)) + (doto *writer* + (.visitJumpInsn Opcodes/GOTO end-label) + (.visitLabel else-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))) + ;; (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* @@ -282,38 +315,38 @@ (defcompiler ^:private compile-def [::&analyser/def ?form ?body] - (do (prn 'compile-def ?form) - (match ?form - (?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] - (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) - (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) - (.visitEnd))) - (let [signature (str "(" (apply str (repeat (count ?args) "Ljava/lang/Object;")) ")" "Ljava/lang/Object;") - _ (prn 'signature signature) - =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil) - (.visitCode))] - (compile-form (assoc *state* :parent *writer* :writer =method :form ?body)) - (doto =method - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (compile-method-function *writer* *class-name* ?name (count ?args))))) - ))) + (do ;; (prn 'compile-def ?form) + (match ?form + (?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] + (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) + (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) + (.visitEnd))) + (let [signature (str "(" (apply str (repeat (count ?args) "Ljava/lang/Object;")) ")" "Ljava/lang/Object;") + ;; _ (prn 'signature signature) + =method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil) + (.visitCode))] + (compile-form (assoc *state* :parent *writer* :writer =method :form ?body)) + (doto =method + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (compile-method-function *writer* *class-name* ?name (count ?args))))) + ))) (defcompiler ^:private compile-lambda [::&analyser/lambda ?args ?body] @@ -371,7 +404,7 @@ (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)) + ;; (prn '(:form ?body) (:form ?body)) (compile-form (assoc *state* :parent *parent* :writer =method :form ?body)) (doto =method (.visitInsn Opcodes/ARETURN) @@ -448,15 +481,15 @@ (defcompiler compile-require [::&analyser/require ?file ?alias] (let [module-name (re-find #"[^/]+$" ?file) - _ (prn 'module-name module-name) + ;; _ (prn 'module-name module-name) source-code (slurp (str module-name ".lang")) - _ (prn 'source-code source-code) + ;; _ (prn 'source-code source-code) tokens (&lexer/lex source-code) - _ (prn 'tokens tokens) + ;; _ (prn 'tokens tokens) syntax (&parser/parse tokens) - _ (prn 'syntax syntax) + ;; _ (prn 'syntax syntax) ann-syntax (&analyser/analyse module-name syntax) - _ (prn 'ann-syntax ann-syntax) + ;; _ (prn 'ann-syntax ann-syntax) class-data (compile module-name ann-syntax)] (write-file (str module-name ".class") class-data) nil)) @@ -472,6 +505,7 @@ compile-ann-class compile-if compile-do + compile-case compile-let compile-lambda compile-def diff --git a/src/lang/lexer.clj b/src/lang/lexer.clj index 93bdf51aa..870209503 100644 --- a/src/lang/lexer.clj +++ b/src/lang/lexer.clj @@ -74,12 +74,13 @@ (def ^:private lex-string (exec [_ (lex-str "\"") - state &util/get-state - :let [_ (prn 'PRE state)] + ;; state &util/get-state + ;; :let [_ (prn 'PRE state)] token lex-string-body _ (lex-str "\"") - state &util/get-state - :let [_ (prn 'POST state)]] + ;; state &util/get-state + ;; :let [_ (prn 'POST state)] + ] (return [::string token]))) (def ^:private lex-single-line-comment @@ -106,7 +107,7 @@ ;; :let [_ (prn 'COMMENT comment)] _ (lex-str ")#") ;; :let [_ (prn 'CLOSE)] - :let [_ (prn 'multi-comment comment)] + ;; :let [_ (prn 'multi-comment comment)] ] (return [::comment comment]))) -- cgit v1.2.3