From 93ff63219c7528074aae2d7f3e4f913b510a61bd Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 29 Jan 2015 20:10:58 -0400 Subject: [Working on] - The monadic implementation of macros is almost done. - Missing error-handling. [Fixes] - The output folder is now generated on each compiler run to avoid exceptions thrown by the class-loader. --- source/lux.lux | 259 +++++++++++++++++++++++++++++---------------------- src/lux.clj | 1 - src/lux/analyser.clj | 106 ++++++++++++++------- src/lux/compiler.clj | 43 ++++++--- 4 files changed, 248 insertions(+), 161 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index cab8a31d2..63ab93a4c 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -67,111 +67,152 @@ [java.lang.Object _7] [java.lang.Object _8]]) ## Base functions & macros -(def' id - (lambda' id x - x)) - -(def' + (lambda' + x (lambda' _ y (jvm:iadd x y)))) - -(def' fold - (lambda' fold f - (lambda' _ init - (lambda' _ values - (case values - #Nil - init - (#Cons x xs) - (fold f (f init x) xs) - ))))) - (annotate lambda Macro) (def' lambda (lambda' _ tokens (lambda' _ state - (let output (case tokens - (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))) - (#Form (#Cons (#Ident "lambda'") - (#Cons self - (#Cons arg - (case args' - #Nil - (#Cons body #Nil) - - _ - (#Cons (#Ident "lux:lambda") - (#Cons (#Tuple args') - (#Cons body #Nil)))))))) - - (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)) - (#Form (#Cons (#Ident "lambda'") - (#Cons (#Ident "_") - (#Cons arg - (case args' - #Nil - (#Cons body #Nil) - - _ - (#Cons (#Ident "lux:lambda") - (#Cons (#Tuple args') - (#Cons body #Nil))))))))) - [(#Cons output #Nil) state])))) - -(def cons - (lambda [tail head] - (#Cons head tail))) - -#( - (defmacro (lambda tokens) + (let' output (case tokens + (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))) + (#Form (#Cons (#Ident "lambda'") + (#Cons self + (#Cons arg + (#Cons (case args' + #Nil + body + + _ + (#Form (#Cons (#Ident "lux:lambda") + (#Cons (#Tuple args') + (#Cons body #Nil))))) + #Nil))))) + + (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)) + (#Form (#Cons (#Ident "lambda'") + (#Cons (#Ident "_") + (#Cons arg + (#Cons (case args' + #Nil + body + + _ + (#Form (#Cons (#Ident "lux:lambda") + (#Cons (#Tuple args') + (#Cons body #Nil))))) + #Nil)))))) + [(#Cons output #Nil) state])))) + +(annotate def Macro) +(def' def + (lambda [tokens state] + (let' output (case tokens + (#Cons (#Ident name) (#Cons body #Nil)) + (#Form (#Cons (#Ident "def'") + (#Cons (#Ident name) + (#Cons body #Nil)))) + + (#Cons (#Form (#Cons (#Ident name) args)) + (#Cons body #Nil)) + (#Form (#Cons (#Ident "def'") + (#Cons (#Ident name) + (#Cons (#Form (#Cons (#Ident "lux:lambda") + (#Cons (#Ident name) + (#Cons (#Tuple args) + (#Cons body #Nil))))) + #Nil))))) + [(#Cons output #Nil) state]))) + +(def (+ x y) + (jvm:iadd x y)) + +(def (id x) + x) + +(def (fold f init values) + (case values + #Nil + init + + (#Cons x xs) + (fold f (f init x) xs))) + +(def (reverse list) + (fold (lambda [tail head] (#Cons head tail)) + #Nil + list)) + +(annotate list Macro) +(def (list xs state) + (let' output (fold (lambda [tail head] + (#Form (#Cons (#Tag "Cons") + (#Cons head + (#Cons tail #Nil))))) + (#Tag "Nil") + (reverse xs)) + [(#Cons output #Nil) state])) + +(annotate list+ Macro) +(def (list+ xs state) + (case (reverse xs) + #Nil + [#Nil state] + + (#Cons last init') + (let' output (fold (lambda [tail head] + (#Form (#Cons (#Tag "Cons") + (#Cons head tail)))) + last + init') + [(#Cons output #Nil) state]))) + +(def (->pairs xs) + (case xs + (#Cons x (#Cons y xs')) + (#Cons [x y] (->pairs xs')) + + _ + #Nil)) + +#((annotate let Macro) + (def (let tokens state) (case tokens - (#Cons self (#Cons args (#Cons body #Nil))) - - - (#Cons args (#Cons body #Nil)) - )) - - (def' id (lambda [x] x)) - - (def' + (lambda [x y] (jvm:iadd x y))) - - (def (fold f init values) - (case values - #Nil - init - (#Cons x xs)x - (fold f (f init x) xs))) - - (def (cons tail head) - (#Cons head tail)) - - (def (reverse list) - (fold cons #Nil list)) - - (annotate list Macro) - (def (list xs) - (fold (lambda' tail - (lambda' head - (#Form (#Cons (#Tag "Cons") - (#Cons head - (#Cons tail #Nil)))))) - (#Tag "Nil") - (reverse xs))) - - (def (++ xs ys) - (case xs - #Nil - ys - - (#Cons x xs*) - (#Cons x (++ xs* ys)))) - - (def (map f xs) - (case xs - #Nil - #Nil - - (#Cons x xs*) - (#Cons (f x) (map f xs*)))) + (#Cons (#Tuple bindings) (#Cons body #Nil)) + (let' output (fold (lambda [body binding] + (case binding + [label value] + (#Form (list (#Ident "let'") label value body)))) + body + (reverse (->pairs bindings))) + [(list output) state]))))# + +(annotate let Macro) +(def (let tokens state) + (case tokens + (#Cons (#Tuple bindings) (#Cons body #Nil)) + (let' output (fold (lambda [body binding] + (case binding + [label value] + (#Form (#Cons (#Ident "let'") (#Cons label (#Cons value (#Cons body #Nil))))))) + body + (reverse (->pairs bindings))) + [(list output) state]))) + +(def (++ xs ys) + (case xs + #Nil + ys + + (#Cons x xs*) + (#Cons x (++ xs* ys)))) + +(def (map f xs) + (case xs + #Nil + #Nil + + (#Cons x xs*) + (#Cons (f x) (map f xs*)))) +#( (def (untemplate-list untemplate tokens) (case tokens #Nil @@ -265,19 +306,19 @@ (#Cons from (range (inc from) to)))) (def (text->list text) - (let length (jvm:invokevirtual String "length" [] - text []) - (map (lambda' idx - (jvm:invokevirtual String "charAt" [int] - text [idx])) - (range 0 length)))) + (let' length (jvm:invokevirtual String "length" [] + text []) + (map (lambda' idx + (jvm:invokevirtual String "charAt" [int] + text [idx])) + (range 0 length)))) (def (enumerate list) (case (fold (lambda' state - (lambda' x - (case state - [idx list'] - [(inc idx) (#Cons [idx x] list')]))) + (lambda' x + (case state + [idx list'] + [(inc idx) (#Cons [idx x] list')]))) [0 #Nil] list) [_ list'] diff --git a/src/lux.clj b/src/lux.clj index f748fd0f3..6d2374edb 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -23,7 +23,6 @@ ;; TODO: Reinplement "if" as a macro on top of case. ;; TODO: Remember to optimized calling global functions. ;; TODO: Reader macros. - ;; TODO: Automatic currying of functions. ;; TODO: ;; TODO: ;; TODO: diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index d44c333b1..8fd6dfb47 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -305,7 +305,7 @@ (reduce (fn [tail x] (doto (.newInstance (.loadClass loader "lux.Variant2")) (-> .-tag (set! "Cons")) - (-> .-_1 (set! (->lux x))) + (-> .-_1 (set! (->lux loader x))) (-> .-_2 (set! tail)))) (doto (.newInstance (.loadClass loader "lux.Variant0")) (-> .-tag (set! "Nil"))) @@ -354,6 +354,7 @@ (def ^:private ->lux+ (partial ->lux+* ->lux)) (defn ->clojure+* [->clojure xs] + (prn '->clojure+* (.-tag xs)) (case (.-tag xs) "Nil" '() "Cons" (cons (->clojure (.-_1 xs)) @@ -361,21 +362,23 @@ )) (defn ->clojure [x] + (pr '->clojure (.-tag x)) (case (.-tag x) - "Bool" [::&parser/bool (-> x .-_1)] - "Int" [::&parser/int (-> x .-_1)] - "Real" [::&parser/real (-> x .-_1)] - "Char" [::&parser/char (-> x .-_1)] - "Text" [::&parser/text (-> x .-_1)] - "Tag" [::&parser/tag (-> x .-_1)] - "Ident" [::&parser/ident (-> x .-_1)] - "Tuple" [::&parser/tuple (->> x .-_1 (->clojure+* ->clojure))] - "Form" [::&parser/form (->> x .-_1 (->clojure+* ->clojure))])) + "Bool" (do (println) [::&parser/bool (.-_1 x)]) + "Int" (do (println) [::&parser/int (.-_1 x)]) + "Real" (do (println) [::&parser/real (.-_1 x)]) + "Char" (do (println) [::&parser/char (.-_1 x)]) + "Text" (do (println) [::&parser/text (.-_1 x)]) + "Tag" (do (println " " (.-_1 x)) [::&parser/tag (.-_1 x)]) + "Ident" (do (println) [::&parser/ident (.-_1 x)]) + "Tuple" (do (println) [::&parser/tuple (->clojure+* ->clojure (.-_1 x))]) + "Form" (do (println) [::&parser/form (->clojure+* ->clojure (.-_1 x))]))) (def ^:private ->clojure+ (partial ->clojure+* ->clojure)) (defn ^:private analyse-tuple [analyse-ast ?elems] - (exec [=elems (do-all-m* (map analyse-ast ?elems))] + (exec [=elems (do-all-m* (map analyse-ast ?elems)) + :let [_ (prn 'analyse-tuple =elems)]] (return (list (annotated [::tuple =elems] [::&type/tuple (mapv :type =elems)]))))) (defn ^:private analyse-ident [analyse-ast ?ident] @@ -388,12 +391,19 @@ [::global-fn ?module ?name] (exec [macro? (is-macro? ?module ?name)] (if macro? - (let [macro-class (str ?module "$" (normalize-ident ?name))] - (-> (.loadClass loader macro-class) - .newInstance - (.apply (->lux+ loader ?args)) - ->clojure - analyse-ast)) + (let [macro-class (str ?module "$" (normalize-ident ?name)) + output (-> (.loadClass loader macro-class) + .getDeclaredConstructors + first + (.newInstance (to-array [(int 0) nil])) + (.apply (->lux+ loader ?args)) + (.apply nil)) + _ (prn 'output (str ?module ":" ?name) output (.-_1 output) (.-tag (.-_1 output))) + macro-expansion (->clojure+ (.-_1 output)) + state* (.-_2 output) + _ (prn 'macro-expansion (str ?module ":" ?name) state* macro-expansion) + ] + (do-all-m* (map analyse-ast macro-expansion))) (exec [=args (do-all-m* (map analyse-ast ?args)) :let [[needs-num =return-type] (match (:type =fn) [::&type/function ?fargs ?freturn] @@ -654,17 +664,35 @@ (exec [[=value] (analyse-ast ?value) idx next-local-idx [=body] (with-let ?label (:type =value) - (analyse-ast ?body))] + (analyse-ast ?body)) + :let [_ (prn 'analyse-let =body)]] (return (list (annotated [::let idx ?label =value =body] (:type =body)))))) -(defn ^:private raise-tree-bindings [raise-expr outer-scope ?tree] - (let [partial-f (partial raise-expr outer-scope) - tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)] +(defn ^:private raise-tree-bindings [raise-expr outer-scope offset ?tree] + (let [partial-f (partial raise-expr outer-scope offset) + tree-partial-f (partial raise-tree-bindings raise-expr outer-scope offset)] (case (:type ?tree) + ::tuple* + (-> ?tree + (update-in [:patterns] + #(into {} (for [[?tag ?unapply] %] + [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))]))) + (update-in [:default] + (fn [[tag local $branch :as total]] + ;; (prn 'total total) + (if total + [tag (-> {:form local :type ::&type/nothing} partial-f :form) $branch])))) + ::adt* - (update-in ?tree [:patterns] - #(into {} (for [[?tag ?unapply] %] - [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))]))) + (-> ?tree + (update-in [:patterns] + #(into {} (for [[?tag ?unapply] %] + [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))]))) + (update-in [:default] + (fn [[tag local $branch :as total]] + ;; (prn 'total total) + (if total + [tag (-> {:form local :type ::&type/nothing} partial-f :form) $branch])))) ::defaults (update-in ?tree [:stores] @@ -675,10 +703,10 @@ (assert false (pr-str ?tree)) ))) -(defn ^:private raise-expr [outer-scope syntax] +(defn ^:private raise-expr [outer-scope offset syntax] ;; (prn 'raise-bindings body) - (let [partial-f (partial raise-expr outer-scope) - tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)] + (let [partial-f (partial raise-expr outer-scope offset) + tree-partial-f (partial raise-tree-bindings raise-expr outer-scope offset)] (match (:form syntax) [::literal ?value] syntax @@ -702,20 +730,24 @@ {:form [::self outer-scope (mapv partial-f ?curried)] :type (:type syntax)} + [::global _ _] + syntax + [::jvm:iadd ?x ?y] {:form [::jvm:iadd (partial-f ?x) (partial-f ?y)] :type (:type syntax)} [::let ?idx ?name ?value ?body] - {:form [::let ?idx ?name (partial-f ?value) (partial-f ?body)] + {:form [::let offset ?name (partial-f ?value) + (raise-expr outer-scope (inc offset) ?body)] :type (:type syntax)} [::case ?base ?variant ?registers ?mappings ?tree] (let [=variant (partial-f ?variant) =mappings (into {} (for [[idx syntax] ?mappings] - [idx (partial-f syntax)])) + [idx (raise-expr outer-scope (+ offset ?registers) syntax)])) =tree (tree-partial-f ?tree)] - {:form [::case ?base =variant ?registers =mappings =tree] + {:form [::case offset =variant ?registers =mappings =tree] :type (:type syntax)}) [::lambda ?scope ?captured ?args ?value] @@ -748,7 +780,7 @@ :let [;; _ (prn '(:form =body) (:form =body)) =lambda (match (:form =body) [::lambda ?sub-scope ?sub-captured ?sub-args ?sub-body] - [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr =scope ?sub-body)] + [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr =scope (-> ?sub-args count (+ 2)) ?sub-body)] _ [::lambda =scope =captured (list ?arg) =body])] @@ -757,6 +789,7 @@ (return (list (annotated =lambda =function))))) (defn ^:private analyse-def [analyse-ast ?name ?value] + ;; (prn 'analyse-def ?name ?value) (exec [def?? (defined? ?name)] (if def?? (fail (str "Can't redefine function/constant: " ?name)) @@ -769,12 +802,12 @@ new-scope [$module ?name] =value (match (:form =value) [::lambda ?old-scope ?env ?args ?body] - {:form [::lambda new-scope ?env ?args (raise-expr new-scope ?body)] + {:form [::lambda new-scope ?env ?args (raise-expr new-scope (-> ?args count inc) ?body)] :type (:type =value)} _ =value)] - ;; :let [_ (prn 'DEF/POST =value)] + ;; :let [_ (prn 'DEF/POST ?name =value)] _ (if ann?? (return nil) (annotate ?name ::constant ::public false (:type =value))) @@ -886,7 +919,7 @@ (return (list (annotated [::literal ?value] [::&type/object "java.lang.String" []]))) [::&parser/tag ?tag] - (do (prn 'analyse-basic-ast/variant0 ?tag) + (do ;; (prn 'analyse-basic-ast/variant0 ?tag) (return (list (annotated [::variant ?tag '()] [::&type/variant ?tag '()])))) [::&parser/tuple ?elems] @@ -898,7 +931,7 @@ [::&parser/form ([[::&parser/ident "if"] ?test ?then ?else] :seq)] (analyse-if analyse-ast ?test ?then ?else) - [::&parser/form ([[::&parser/ident "let"] [::&parser/ident ?label] ?value ?body] :seq)] + [::&parser/form ([[::&parser/ident "let'"] [::&parser/ident ?label] ?value ?body] :seq)] (analyse-let analyse-ast ?label ?value ?body) [::&parser/form ([[::&parser/ident "case"] ?variant & ?branches] :seq)] @@ -967,7 +1000,8 @@ (match token [::&parser/form ([[::&parser/tag ?tag] & ?data] :seq)] (exec [=data (do-all-m* (map analyse-ast ?data)) - :let [_ (prn 'analyse-ast/variant+ ?tag '=data =data)]] + ;; :let [_ (prn 'analyse-ast/variant+ ?tag '=data =data)] + ] (return (list (annotated [::variant ?tag =data] [::&type/variant ?tag (map :type =data)])))) [::&parser/form ([?fn & ?args] :seq)] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index f6daaca0f..76f480a14 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -605,6 +605,7 @@ (.visitInsn Opcodes/DUP) (.visitLabel start-label)) default-label (new Label) + ;; _ (prn '?decision-tree ?decision-tree) _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))] (if (or (:default ?decision-tree) (not (empty? (:defaults ?decision-tree)))) @@ -693,7 +694,7 @@ (let [num-args (count args)] (str "(" (reduce str "" (repeat (count closed-over) clo-field-sig)) (if (> num-args 1) - (reduce str counter-sig (repeat num-args clo-field-sig))) + (reduce str counter-sig (repeat (dec num-args) clo-field-sig))) ")" -return))) @@ -728,6 +729,22 @@ (.visitMaxs 0 0) (.visitEnd)))) + (defn add-closed-over-vars [writer class-name closed-over] + (dotimes [capt_idx (count closed-over)] + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name (str "__" capt_idx) clo-field-sig)))) + + (defn add-partial-vars [writer class-name args] + (dotimes [clo_idx (count args)] + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig)))) + + (defn add-nulls [writer amount] + (dotimes [_ amount] + (.visitInsn writer Opcodes/ACONST_NULL))) + (defn add-lambda-apply [class class-name closed-over args impl-signature init-signature] (let [num-args (count args) num-captured (dec num-args) @@ -736,31 +753,24 @@ (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 class-name "_counter" counter-sig) (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels)) (-> (doto (.visitLabel branch-label) (.visitTypeInsn Opcodes/NEW class-name) (.visitInsn Opcodes/DUP) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name (str "__" capt_idx) clo-field-sig)) - (->> (dotimes [capt_idx (count closed-over)]))) + (add-closed-over-vars class-name closed-over) (.visitLdcInsn (-> current-captured inc int)) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig)) - (->> (dotimes [clo_idx current-captured]))) + (add-partial-vars class-name (take current-captured args)) (.visitVarInsn Opcodes/ALOAD 1) - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (dotimes [clo_idx (- (dec num-captured) current-captured)]))) + (add-nulls (- (dec num-captured) current-captured)) (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" init-signature) (.visitInsn Opcodes/ARETURN)) (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))]))) - (.visitLabel default-label) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig)) - (->> (dotimes [clo_idx num-captured])))) + (.visitLabel default-label)) (->> (when (> num-args 1)))) + (.visitVarInsn Opcodes/ALOAD 0) + (add-partial-vars class-name (butlast args)) (.visitVarInsn Opcodes/ALOAD 1) (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature) (.visitInsn Opcodes/ARETURN) @@ -1066,7 +1076,9 @@ )) ;; [Interface] -(let [compiler-step (exec [analysis+ &analyser/analyse] +(let [compiler-step (exec [analysis+ &analyser/analyse + ;; :let [_ (prn 'analysis+ analysis+)] + ] (map-m compile analysis+))] (defn compile-module [name] (exec [loader &util/loader] @@ -1090,6 +1102,7 @@ (fail* ?message)))))))) (defn compile-all [modules] + (.mkdir (java.io.File. "output")) (let [state {::&lexer/source nil ::&analyser/current-module nil ::&analyser/scope [] -- cgit v1.2.3