From 1c0ddbcf3833ff28aa2f71bc1da74c466a23281c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 2 May 2015 18:43:03 -0400 Subject: - Implemented some new macros & functions in lux.lux. - WORKING ON DEBUGGING A COMPILER ERROR: java.lang.IncompatibleClassChangeError --- source/lux.lux | 325 +++++++++++++++++++++++++++++--------------- src/lux/analyser/lux.clj | 4 +- src/lux/base.clj | 3 +- src/lux/compiler/lambda.clj | 68 ++++----- 4 files changed, 251 insertions(+), 149 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 94f4853d8..04ffcf91f 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -949,7 +949,7 @@ (case' tokens (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) (return (:' SyntaxList - (list (` (#DataT (~ (_meta (#Text class-name)))))))) + (list (` (#;DataT (~ (_meta (#Text class-name)))))))) _ (fail "Wrong syntax for ^"))) @@ -969,7 +969,7 @@ (defmacro #export (, tokens) (return (:' SyntaxList - (list (` (#TupleT (list (~@ tokens)))))))) + (list (` (#;TupleT (;list (~@ tokens)))))))) (defmacro (do tokens) (case' tokens @@ -977,10 +977,15 @@ (let [body' (fold (:' (-> Syntax (, Syntax Syntax) Syntax) (lambda [body' binding] (let [[var value] binding] - (` (;bind (lambda' (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value)))))) + (case' var + (#Meta [_ (#Tag ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (;bind (lambda' (~ ($symbol ["" ""])) + (~ var) + (~ body')) + (~ value))))))) body (reverse (as-pairs bindings)))] (return (:' SyntaxList @@ -1180,7 +1185,7 @@ (lambda [token] (case' token (#Meta [_ (#Tag ident)]) - (;return (:' Syntax (` [(~ ($text (ident->text ident))) (,)]))) + (;return (:' Syntax (` [(~ ($text (ident->text ident))) (;,)]))) (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) (;return (:' Syntax (` [(~ ($text (ident->text ident))) (~ value)]))) @@ -1188,7 +1193,7 @@ _ (fail "Wrong syntax for |")))) tokens)] - (;return (:' SyntaxList (list (` (#VariantT (list (~@ pairs))))))))) + (;return (:' SyntaxList (list (` (#;VariantT (;list (~@ pairs))))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1204,7 +1209,7 @@ _ (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (:' SyntaxList (list (` (#RecordT (list (~@ pairs)))))))))) + (;return (:' SyntaxList (list (` (#;RecordT (;list (~@ pairs)))))))))) (def (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) @@ -1252,15 +1257,15 @@ (#Cons [harg targs]) (let [replacements (map (:' (-> Text (, Text Syntax)) - (lambda [ident] [ident (` (#BoundT (~ ($text ident))))])) + (lambda [ident] [ident (` (#;BoundT (~ ($text ident))))])) (list& self-ident idents)) body' (fold (:' (-> Syntax Text Syntax) (lambda [body' arg'] - (` (#AllT [#None "" (~ ($text arg')) (~ body')])))) + (` (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) (replace-syntax replacements body) (reverse targs))] (return (:' SyntaxList - (list (` (#AllT [#None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + (list (` (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) #None (fail "'All' arguments must be symbols.")) @@ -1303,12 +1308,64 @@ (-> ($' List ($' List a)) ($' List a))) (fold list:++ #Nil xs)) +(def #export (normalize ident state) + (-> Ident ($' Lux Ident)) + (case' ident + ["" name] + (case' state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (case' (reverse envs) + #Nil + (#Left "Can't normalize Ident without a global environment.") + + (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) + (#Right [state [prefix name]]))) + + _ + (#Right [state ident]))) + +## (def #export (macro-expand syntax) +## (-> Syntax ($' Lux ($' List Syntax))) +## (case' syntax +## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) +## (do Lux:Monad +## [macro-name' (normalize macro-name) +## ?macro (find-macro macro-name')] +## (case' (:' ($' Maybe Macro) ?macro) +## (#Some macro) +## (do Lux:Monad +## [expansion (macro args) +## expansion' (map% Lux:Monad macro-expand expansion)] +## (;return (:' SyntaxList (list:join expansion')))) + +## #None +## (do Lux:Monad +## [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] +## (;return (:' SyntaxList (list ($form (list:join parts')))))))) + +## ## (#Meta [_ (#Form (#Cons [harg targs]))]) +## ## (do Lux:Monad +## ## [harg+ (macro-expand harg) +## ## targs+ (map% Lux:Monad macro-expand targs)] +## ## (;return (:' SyntaxList (list:++ harg+ (list:join targs+))))) + +## (#Meta [_ (#Tuple members)]) +## (do Lux:Monad +## [members' (map% Lux:Monad macro-expand members)] +## (;return (:' SyntaxList (list ($tuple (list:join members')))))) + +## _ +## (return (:' SyntaxList (list syntax))))) + (def #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (case' syntax (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) (do Lux:Monad - [?macro (find-macro macro-name)] + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] (case' (:' ($' Maybe Macro) ?macro) (#Some macro) (do Lux:Monad @@ -1321,6 +1378,12 @@ [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] (;return (:' SyntaxList (list ($form (list:join parts')))))))) + ## (#Meta [_ (#Form (#Cons [harg targs]))]) + ## (do Lux:Monad + ## [harg+ (macro-expand harg) + ## targs+ (map% Lux:Monad macro-expand targs)] + ## (;return (:' SyntaxList (list:++ harg+ (list:join targs+))))) + (#Meta [_ (#Tuple members)]) (do Lux:Monad [members' (map% Lux:Monad macro-expand members)] @@ -1329,84 +1392,150 @@ _ (return (:' SyntaxList (list syntax))))) -## ## (def (walk-type type) -## ## (-> Syntax ($' Lux Syntax)) -## ## (case' type -## ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol sym)]) args]))]) -## ## (do' [macro' (find-macro sym)] -## ## (case' macro' -## ## (#Some macro) -## ## (do' [expansion (macro args)] -## ## (case' expansion -## ## (#Cons [expansion' #Nil]) -## ## (walk-type expansion') - -## ## _ -## ## (fail "Macro can't expand to more than 1 output."))) - -## ## #None -## ## (do' [args' (map% walk-type args)] -## ## (return (fold (:' (-> Syntax Syntax Syntax) -## ## (lambda [f a] -## ## (` (#AppT [(~ f) (~ a)])))) -## ## sym -## ## args'))))) - -## ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) args]))]) -## ## ... - -## ## (#Meta [_ (#Symbol _)]) -## ## (return type) - -## ## _ -## ## (fail "Wrong syntax for walk-type"))) - -## ## (defmacro (->type tokens) -## ## (case' tokens -## ## (#Cons [type #Nil]) -## ## (do' [type' (walk-type type)] -## ## (return (list type'))) +(def (walk-type type) + (-> Syntax Syntax) + (case' type + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) + ($form (#Cons [($tag tag) (map walk-type parts)])) -## ## _ -## ## (fail "Wrong syntax for ->type"))) + (#Meta [_ (#Tuple members)]) + ($tuple (map walk-type members)) + + (#Meta [_ (#Form (#Cons [type-fn args]))]) + (fold (:' (-> Syntax Syntax Syntax) + (lambda [type-fn arg] + (` (#;AppT [(~ type-fn) (~ arg)])))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) -## ## (defmacro (: tokens) -## ## (case' tokens -## ## (#Cons [type (#Cons [value #Nil])]) -## ## (return (list (` (:' (->type (~ type)) (~ value))))) +(defmacro #export (type` tokens) + (case' tokens + (#Cons [type #Nil]) + (do Lux:Monad + [type+ (macro-expand type)] + (case' (:' SyntaxList type+) + (#Cons [type' #Nil]) + (;return (:' SyntaxList (list (walk-type type')))) + + _ + (fail "type`: The expansion of the type-syntax had to yield a single element."))) -## ## _ -## ## (fail "Wrong syntax for :"))) + _ + (fail "Wrong syntax for type`"))) -## ## (defmacro (:! tokens) -## ## (case' tokens -## ## (#Cons [type (#Cons [value #Nil])]) -## ## (return (list (` (:!' (->type (~ type)) (~ value))))) +(defmacro #export (: tokens) + (case' tokens + (#Cons [type (#Cons [value #Nil])]) + (return (:' SyntaxList (list (` (:' (;type` (~ type)) (~ value)))))) -## ## _ -## ## (fail "Wrong syntax for :!"))) + _ + (fail "Wrong syntax for :"))) -## ## (deftype (IO a) -## ## (-> (,) a)) +(defmacro #export (:! tokens) + (case' tokens + (#Cons [type (#Cons [value #Nil])]) + (return (:' SyntaxList (list (` (:!' (;type` (~ type)) (~ value)))))) -## ## (defmacro (io tokens) -## ## (case' tokens -## ## (#Cons [value #Nil]) -## ## (return (list (` (lambda [_] (~ value))))))) - -## (defmacro #export (exec tokens) -## (case' (reverse tokens) -## (#Cons [value actions]) -## (let [dummy ($symbol ["" ""])] -## (return (:' SyntaxList -## (list (fold (:' (-> Syntax Syntax Syntax) -## (lambda [post pre] -## (` (case' (~ pre) (~ dummy) (~ post))))) -## value -## actions))))) + _ + (fail "Wrong syntax for :!"))) + +(defmacro #export (deftype tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case' tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + ## parts (: (Maybe (, Syntax (List Syntax) Syntax)) + ## (case' tokens' + ## (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) + ## (#Some [($symbol name) #Nil type]) + + ## (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) + ## (#Some [($symbol name) args type]) + + ## _ + ## #None)) + ] + (return (: (List Syntax) #Nil)) + ## (case' parts + ## (#Some [name args type]) + ## (let [with-export (: (List Syntax) + ## (if export? + ## (list (` (export' (~ name)))) + ## #Nil)) + ## type' (: Syntax + ## (case' args + ## #Nil + ## type + + ## _ + ## (` (;All (~ name) [(~@ args)] (~ type)))))] + ## (return (: (List Syntax) + ## (list& type' with-export)))) + + ## #None + ## (fail "Wrong syntax for deftype")) + )) -## _ -## (fail "Wrong syntax for exec"))) +(deftype #export (IO a) + (-> (,) a)) + +(defmacro #export (io tokens) + (case' tokens + (#Cons [value #Nil]) + (let [blank ($symbol ["" ""])] + (return (list (` (lambda' (~ blank) (~ blank) (~ value)))))) + + _ + (fail "Wrong syntax for io"))) + +(defmacro #export (exec tokens) + (case' (reverse tokens) + (#Cons [value actions]) + (let [dummy ($symbol ["" ""])] + (return (:' SyntaxList + (list (fold (:' (-> Syntax Syntax Syntax) + (lambda [post pre] + (` (case' (~ pre) (~ dummy) (~ post))))) + value + actions))))) + + _ + (fail "Wrong syntax for exec"))) + +(def (rejoin-pair pair) + (-> (, Syntax Syntax) (List Syntax)) + (let [[left right] pair] + (list left right))) + +(defmacro #export (case tokens) + (case' tokens + (#Cons value branches) + (do Lux:Monad + [expansions (map% Lux:Monad + (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (lambda expander [branch] + (let [[pattern body] branch] + (case' pattern + (#Cons [(#Meta [_ (#Symbol macro-name)]) macro-args]) + (do Lux:Monad + [expansion (macro-expand (list& ($symbol macro-name) body macro-args))] + (map% Lux:Monad expander (as-pairs expansion))) + + _ + (;return (: (List (, Syntax Syntax)) (list branch))))))) + (as-pairs branches))] + (;return (: (List (, Syntax Syntax)) + (list (` (case' (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join)))))))) + + _ + (fail "Wrong syntax for case"))) ## (def #export (print x) ## (-> Text (IO (,))) @@ -1486,33 +1615,3 @@ ## ## [first f] ## ## [second s]) - -## ## (defmacro (case tokens) -## ## (case' tokens -## ## (#Cons value branches) -## ## (loop [kind #Pattern -## ## pieces branches -## ## new-pieces (list)] -## ## (case' pieces -## ## #Nil -## ## (return (list (' (case' (~ value) (~@ new-pieces))))) - -## ## (#Cons piece pieces') -## ## (let [[kind' expanded more-pieces] (case' kind -## ## #Body -## ## [#Pattern (list piece) #Nil] - -## ## #Pattern -## ## (do [expansion (macro-expand piece)] -## ## (case' expansion -## ## #Nil -## ## [#Pattern #Nil #Nil] - -## ## (#Cons exp #Nil) -## ## [#Body (list exp) #Nil] - -## ## (#Cons exp exps) -## ## [#Body (list exp) exps])) -## ## )] -## ## (recur kind' (++ expanded new-pieces) (++ more-pieces pieces)))) -## ## ))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index c964058b2..59f3fbb1f 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -266,7 +266,9 @@ (matchv ::M/objects [_macro] [["lux;Some" macro]] (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))] - (&/flat-map% (partial analyse exo-type) macro-expansion)) + (do (when (= "type`" ?name) + (prn 'macro-expansion (str ?module ";" ?name) (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) + (&/flat-map% (partial analyse exo-type) macro-expansion))) [["lux;None" _]] (fail (str "[Analyser Error] Macro has yet to be compiled: " (str ?module ";" ?name)))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 306c09b19..4b8045e8c 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -645,8 +645,7 @@ (|do [closure-name (|do [top get-top-local-env] (return (->> top (get$ $INNER-CLOSURES) str)))] (fn [state] - (let [body* (with-scope closure-name - body)] + (let [body* (with-scope closure-name body)] (run-state body* (update$ $ENVS #(|cons (update$ $INNER-CLOSURES inc (|head %)) (|tail %)) state)))))) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index cfea13a73..276329a75 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -63,19 +63,19 @@ (&/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) (.visitCode)) (|do [*writer* &/get-writer - :let [num-locals (&&/total-locals impl-body) - $start (new Label) - $end (new Label) - _ (doto *writer* - (-> (.visitLocalVariable (str &&/local-prefix idx) (&host/->java-sig (&/V "lux;DataT" "java.lang.Object")) nil $start $end (+ 2 idx)) - (->> (dotimes [idx num-locals]))) - (.visitLabel $start))] - ret (compile impl-body) - :let [_ (doto *writer* - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] + :let [num-locals (&&/total-locals impl-body) + $start (new Label) + $end (new Label) + _ (doto *writer* + (-> (.visitLocalVariable (str &&/local-prefix idx) (&host/->java-sig (&/V "lux;DataT" "java.lang.Object")) nil $start $end (+ 2 idx)) + (->> (dotimes [idx num-locals]))) + (.visitLabel $start))] + ret (compile impl-body) + :let [_ (doto *writer* + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] (return ret)))) (defn ^:private instance-closure [compile lambda-class closed-over init-signature] @@ -121,7 +121,7 @@ ;; :else ;; '???)) - (compile ?source)))))) + (compile ?source)))))) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] (return nil))) @@ -129,23 +129,25 @@ (defn compile-lambda [compile ?scope ?env ?body] ;; (prn 'compile-lambda ?scope (&host/location ?scope) ?env) (|do [:let [lambda-class (&host/location ?scope) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ ?captured-id ?source]] _]]]) - (doseq [?name+?captured (&/->seq ?env) - ;; :let [_ (prn '?name+?captured (alength ?name+?captured)) - ;; _ (prn '?name+?captured (aget ?name+?captured 1 0)) - ;; _ (prn '?name+?captured (aget ?name+?captured 1 1 0 0))] - ]))) - (add-lambda-apply lambda-class ?env) - (add-lambda- lambda-class ?env) - )] - _ (add-lambda-impl =class compile lambda-impl-signature ?body) - :let [_ (.visitEnd =class)] - _ (&&/save-class! lambda-class (.toByteArray =class))] + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (matchv ::M/objects [?name+?captured] + [[?name [["captured" [_ ?captured-id ?source]] _]]]) + (doseq [?name+?captured (&/->seq ?env) + ;; :let [_ (prn '?name+?captured (alength ?name+?captured)) + ;; _ (prn '?name+?captured (aget ?name+?captured 1 0)) + ;; _ (prn '?name+?captured (aget ?name+?captured 1 1 0 0))] + ]))) + (add-lambda-apply lambda-class ?env) + (add-lambda- lambda-class ?env) + )] + _ (add-lambda-impl =class compile lambda-impl-signature ?body) + :let [_ (.visitEnd =class) + ;; _ (prn 'SAVING_LAMBDA lambda-class) + ] + _ (&&/save-class! lambda-class (.toByteArray =class))] (instance-closure compile lambda-class ?env (lambda--signature ?env)))) -- cgit v1.2.3