diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/lux/analyser.clj | 54 | ||||
| -rw-r--r-- | src/lux/analyser/base.clj | 3 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 427 | ||||
| -rw-r--r-- | src/lux/analyser/parser.clj | 813 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 19 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 4 | ||||
| -rw-r--r-- | src/lux/lexer.clj | 10 | ||||
| -rw-r--r-- | src/lux/optimizer.clj | 65 | ||||
| -rw-r--r-- | src/lux/reader.clj | 10 | ||||
| -rw-r--r-- | src/lux/repl.clj | 2 |
10 files changed, 732 insertions, 675 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 1b5c24bc3..c5fabb409 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -54,56 +54,8 @@ (fn [state] (fail* (add-loc (&/get$ &/$cursor state) msg)))) -(defn ^:private aba2 [analyse eval! compile-module compilers exo-type token] - (|let [[compile-statement compile-def compile-program] compilers] - (|case token - ;; Classes & interfaces - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] - (&/$Cons ?class-decl - (&/$Cons ?super-class - (&/$Cons [_ (&/$TupleS ?interfaces)] - (&/$Cons ?inheritance-modifier - (&/$Cons [_ (&/$TupleS ?anns)] - (&/$Cons [_ (&/$TupleS ?fields)] - (&/$Cons [_ (&/$TupleS ?methods)] - (&/$Nil)))))))))) - (|do [=gclass-decl (&&a-parser/parse-gclass-decl ?class-decl) - =super-class (&&a-parser/parse-gclass-super ?super-class) - =interfaces (&/map% &&a-parser/parse-gclass-super ?interfaces) - =inheritance-modifier (&&a-parser/parse-inheritance-modifier ?inheritance-modifier) - =anns (&/map% &&a-parser/parse-ann ?anns) - =fields (&/map% &&a-parser/parse-field ?fields) - =methods (&/map% &&a-parser/parse-method-def ?methods)] - (&&host/analyse-jvm-class analyse compile-statement =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods)) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] - (&/$Cons ?class-decl - (&/$Cons [_ (&/$TupleS ?supers)] - (&/$Cons [_ (&/$TupleS ?anns)] - ?methods))))) - (|do [=gclass-decl (&&a-parser/parse-gclass-decl ?class-decl) - =supers (&/map% &&a-parser/parse-gclass-super ?supers) - =anns (&/map% &&a-parser/parse-ann ?anns) - =methods (&/map% &&a-parser/parse-method-decl ?methods)] - (&&host/analyse-jvm-interface analyse compile-statement =gclass-decl =supers =anns =methods)) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] - (&/$Cons ?super-class - (&/$Cons [_ (&/$TupleS ?interfaces)] - (&/$Cons [_ (&/$TupleS ?ctor-args)] - (&/$Cons [_ (&/$TupleS ?methods)] - (&/$Nil))))))) - (|do [=super-class (&&a-parser/parse-gclass-super ?super-class) - =interfaces (&/map% &&a-parser/parse-gclass-super ?interfaces) - =ctor-args (&/map% &&a-parser/parse-ctor-arg ?ctor-args) - =methods (&/map% &&a-parser/parse-method-def ?methods)] - (&&host/analyse-jvm-anon-class analyse compile-statement exo-type =super-class =interfaces =ctor-args =methods)) - - _ - (fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token])))))))) - (defn ^:private aba1 [analyse eval! compile-module compilers exo-type token] - (|let [[compile-statement compile-def compile-program] compilers] + (|let [[compile-def compile-program compile-class compile-interface] compilers] (|case token ;; Standard special forms (&/$BoolS ?value) @@ -191,7 +143,7 @@ (&/$Nil))))] (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))))) - (&&host/analyse-host analyse exo-type ?category ?proc ?args) + (&&host/analyse-host analyse exo-type compilers ?category ?proc ?args) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_program")] (&/$Cons [_ (&/$SymbolS "" ?args)] @@ -200,7 +152,7 @@ (&&lux/analyse-program analyse compile-program ?args ?body) _ - (aba2 analyse eval! compile-module compilers exo-type token) + (fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token]))))) ))) (defn ^:private analyse-basic-ast [analyse eval! compile-module compilers exo-type token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 7674f4503..5ee60d4cf 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -25,9 +25,6 @@ ("var" 1) ("captured" 1) ("proc" 2) - - ("jvm-class" 1) ;; Eliminate - ("jvm-interface" 1) ;; Eliminate ) ;; [Exports] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index bb70bf0e2..dd3172dab 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -10,7 +10,10 @@ clojure.core.match.array (lux [base :as & :refer [|let |do return* return fail |case assert!]] [type :as &type] - [host :as &host]) + [host :as &host] + [lexer :as &lexer] + [parser :as &parser] + [reader :as &reader]) [lux.type.host :as &host-type] [lux.host.generics :as &host-generics] (lux.analyser [base :as &&] @@ -423,80 +426,6 @@ (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) )) -(defn analyse-jvm-class [analyse compile-statement class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] - (&/with-closure - (|do [module &/get-module-name - :let [[?name ?params] class-decl - full-name (str (string/replace module "/" ".") "." ?name) - class-decl* (&/T [full-name ?params]) - all-supers (&/$Cons super-class interfaces)] - class-env (make-type-env ?params) - =fields (&/map% (partial analyse-field analyse class-env) ?fields) - _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) - =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - _ (compile-statement (&&/$jvm-class (&/T [class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None]))) - :let [_ (println 'DEF full-name)]] - (return &/$Nil)))) - -(defn analyse-jvm-interface [analyse compile-statement interface-decl supers =anns =methods] - (|do [module &/get-module-name - _ (compile-statement (&&/$jvm-interface (&/T [interface-decl supers =anns =methods]))) - :let [_ (println 'DEF (str module "." (&/|first interface-decl)))]] - (return &/$Nil))) - -(defn ^:private captured-source [env-entry] - (|case env-entry - [name [_ (&&/$captured _ _ source)]] - source)) - -(let [default-<init> (&/$ConstructorMethodSyntax (&/T [&/$PublicPM - false - &/$Nil - &/$Nil - &/$Nil - &/$Nil - &/$Nil - (&/$TupleS &/$Nil)])) - captured-slot-class "java.lang.Object" - captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] - (defn analyse-jvm-anon-class [analyse compile-statement exo-type super-class interfaces ctor-args methods] - (&/with-closure - (|do [module &/get-module-name - scope &/get-scope-name - :let [name (&host/location (&/|tail scope)) - class-decl (&/T [name &/$Nil]) - anon-class (str (string/replace module "/" ".") "." name) - anon-class-type (&/$HostT anon-class &/$Nil)] - =ctor-args (&/map% (fn [ctor-arg] - (|let [[arg-type arg-term] ctor-arg] - (|do [=arg-term (&&/analyse-1+ analyse arg-term)] - (return (&/T [arg-type =arg-term]))))) - ctor-args) - _ (->> methods - (&/$Cons default-<init>) - (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) - :let [all-supers (&/$Cons super-class interfaces) - class-env &/$Nil] - =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - =captured &&env/captured-vars - :let [=fields (&/|map (fn [^objects idx+capt] - (|let [[idx _] idx+capt] - (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) - &/$PublicPM - &/$FinalSM - &/$Nil - captured-slot-type))) - (&/enumerate =captured))] - :let [sources (&/|map captured-source =captured)] - _ (compile-statement (&&/$jvm-class (&/T [class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)]))) - _cursor &/cursor] - (return (&/|list (&&/|meta anon-class-type _cursor - (&&/$proc (&/T ["jvm" "new"]) (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class) sources)) - ))) - )))) - (do-template [<name> <proc> <from-class> <to-class>] (let [output-type (&/$HostT <to-class> &/$Nil)] (defn <name> [analyse exo-type _?value] @@ -662,8 +591,9 @@ (let [length-type &type/Int idx-type &type/Int] (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] - (|do [:let [(&/$Cons _gclass (&/$Cons length (&/$Nil))) ?values] - gclass (&&a-parser/parse-gclass _gclass) + (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] + gclass (&reader/with-source "jvm-anewarray" _gclass + &&a-parser/parse-gclass) gtype-env &/get-type-env =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] @@ -958,124 +888,227 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem)))))))) -(defn analyse-host [analyse exo-type category proc ?values] - (case category - "array" - (case proc - "new" (analyse-array-new analyse exo-type ?values) - "get" (analyse-array-get analyse exo-type ?values) - "put" (analyse-jvm-aastore analyse exo-type ?values) - "remove" (analyse-array-remove analyse exo-type ?values) - "size" (analyse-jvm-arraylength analyse exo-type ?values)) - - "jvm" - (case proc - "try" (analyse-jvm-try analyse exo-type ?values) - "throw" (analyse-jvm-throw analyse exo-type ?values) - "monitorenter" (analyse-jvm-monitorenter analyse exo-type ?values) - "monitorexit" (analyse-jvm-monitorexit analyse exo-type ?values) - "null?" (analyse-jvm-null? analyse exo-type ?values) - "null" (analyse-jvm-null analyse exo-type ?values) - "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) - "aaload" (analyse-jvm-aaload analyse exo-type ?values) - "aastore" (analyse-jvm-aastore analyse exo-type ?values) - "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) - "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) - "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) - "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) - "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) - "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) - "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) - "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) - "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) - "iadd" (analyse-jvm-iadd analyse exo-type ?values) - "isub" (analyse-jvm-isub analyse exo-type ?values) - "imul" (analyse-jvm-imul analyse exo-type ?values) - "idiv" (analyse-jvm-idiv analyse exo-type ?values) - "irem" (analyse-jvm-irem analyse exo-type ?values) - "ieq" (analyse-jvm-ieq analyse exo-type ?values) - "ilt" (analyse-jvm-ilt analyse exo-type ?values) - "igt" (analyse-jvm-igt analyse exo-type ?values) - "ceq" (analyse-jvm-ceq analyse exo-type ?values) - "clt" (analyse-jvm-clt analyse exo-type ?values) - "cgt" (analyse-jvm-cgt analyse exo-type ?values) - "ladd" (analyse-jvm-ladd analyse exo-type ?values) - "lsub" (analyse-jvm-lsub analyse exo-type ?values) - "lmul" (analyse-jvm-lmul analyse exo-type ?values) - "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) - "lrem" (analyse-jvm-lrem analyse exo-type ?values) - "leq" (analyse-jvm-leq analyse exo-type ?values) - "llt" (analyse-jvm-llt analyse exo-type ?values) - "lgt" (analyse-jvm-lgt analyse exo-type ?values) - "fadd" (analyse-jvm-fadd analyse exo-type ?values) - "fsub" (analyse-jvm-fsub analyse exo-type ?values) - "fmul" (analyse-jvm-fmul analyse exo-type ?values) - "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) - "frem" (analyse-jvm-frem analyse exo-type ?values) - "feq" (analyse-jvm-feq analyse exo-type ?values) - "flt" (analyse-jvm-flt analyse exo-type ?values) - "fgt" (analyse-jvm-fgt analyse exo-type ?values) - "dadd" (analyse-jvm-dadd analyse exo-type ?values) - "dsub" (analyse-jvm-dsub analyse exo-type ?values) - "dmul" (analyse-jvm-dmul analyse exo-type ?values) - "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) - "drem" (analyse-jvm-drem analyse exo-type ?values) - "deq" (analyse-jvm-deq analyse exo-type ?values) - "dlt" (analyse-jvm-dlt analyse exo-type ?values) - "dgt" (analyse-jvm-dgt analyse exo-type ?values) - "iand" (analyse-jvm-iand analyse exo-type ?values) - "ior" (analyse-jvm-ior analyse exo-type ?values) - "ixor" (analyse-jvm-ixor analyse exo-type ?values) - "ishl" (analyse-jvm-ishl analyse exo-type ?values) - "ishr" (analyse-jvm-ishr analyse exo-type ?values) - "iushr" (analyse-jvm-iushr analyse exo-type ?values) - "land" (analyse-jvm-land analyse exo-type ?values) - "lor" (analyse-jvm-lor analyse exo-type ?values) - "lxor" (analyse-jvm-lxor analyse exo-type ?values) - "lshl" (analyse-jvm-lshl analyse exo-type ?values) - "lshr" (analyse-jvm-lshr analyse exo-type ?values) - "lushr" (analyse-jvm-lushr analyse exo-type ?values) - "d2f" (analyse-jvm-d2f analyse exo-type ?values) - "d2i" (analyse-jvm-d2i analyse exo-type ?values) - "d2l" (analyse-jvm-d2l analyse exo-type ?values) - "f2d" (analyse-jvm-f2d analyse exo-type ?values) - "f2i" (analyse-jvm-f2i analyse exo-type ?values) - "f2l" (analyse-jvm-f2l analyse exo-type ?values) - "i2b" (analyse-jvm-i2b analyse exo-type ?values) - "i2c" (analyse-jvm-i2c analyse exo-type ?values) - "i2d" (analyse-jvm-i2d analyse exo-type ?values) - "i2f" (analyse-jvm-i2f analyse exo-type ?values) - "i2l" (analyse-jvm-i2l analyse exo-type ?values) - "i2s" (analyse-jvm-i2s analyse exo-type ?values) - "l2d" (analyse-jvm-l2d analyse exo-type ?values) - "l2f" (analyse-jvm-l2f analyse exo-type ?values) - "l2i" (analyse-jvm-l2i analyse exo-type ?values) - "c2b" (analyse-jvm-c2b analyse exo-type ?values) - "c2s" (analyse-jvm-c2s analyse exo-type ?values) - "c2i" (analyse-jvm-c2i analyse exo-type ?values) - "c2l" (analyse-jvm-c2l analyse exo-type ?values) - ;; else - (->> (fail (str "[Analyser Error] Unknown host procedure: " [category proc])) - (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] - (analyse-jvm-instanceof analyse exo-type _class ?values)) - (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] - (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getstatic analyse exo-type _class _field ?values)) - (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getfield analyse exo-type _class _field ?values)) - (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putstatic analyse exo-type _class _field ?values)) - (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putfield analyse exo-type _class _field ?values)))) +(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] + (|do [module &/get-module-name + _ (compile-interface interface-decl supers =anns =methods) + :let [_ (println 'DEF (str module "." (&/|first interface-decl)))] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list))))))) - ;; else - (fail (str "[Analyser Error] Unknown host procedure: " [category proc])))) +(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] + (&/with-closure + (|do [module &/get-module-name + :let [[?name ?params] class-decl + full-name (str (string/replace module "/" ".") "." ?name) + class-decl* (&/T [full-name ?params]) + all-supers (&/$Cons super-class interfaces)] + class-env (make-type-env ?params) + =fields (&/map% (partial analyse-field analyse class-env) ?fields) + _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) + =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) + :let [_ (println 'DEF full-name)] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list)))))))) + +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [_ (&&/$captured _ _ source)]] + source)) + +(let [default-<init> (&/$ConstructorMethodSyntax (&/T [&/$PublicPM + false + &/$Nil + &/$Nil + &/$Nil + &/$Nil + &/$Nil + (&/$TupleS &/$Nil)])) + captured-slot-class "java.lang.Object" + captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] + (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] + (&/with-closure + (|do [module &/get-module-name + scope &/get-scope-name + :let [name (&host/location (&/|tail scope)) + class-decl (&/T [name &/$Nil]) + anon-class (str (string/replace module "/" ".") "." name) + anon-class-type (&/$HostT anon-class &/$Nil)] + =ctor-args (&/map% (fn [ctor-arg] + (|let [[arg-type arg-term] ctor-arg] + (|do [=arg-term (&&/analyse-1+ analyse arg-term)] + (return (&/T [arg-type =arg-term]))))) + ctor-args) + _ (->> methods + (&/$Cons default-<init>) + (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) + :let [all-supers (&/$Cons super-class interfaces) + class-env &/$Nil] + =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + =captured &&env/captured-vars + :let [=fields (&/|map (fn [^objects idx+capt] + (|let [[idx _] idx+capt] + (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) + &/$PublicPM + &/$FinalSM + &/$Nil + captured-slot-type))) + (&/enumerate =captured))] + :let [sources (&/|map captured-source =captured)] + _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) + _cursor &/cursor] + (return (&/|list (&&/|meta anon-class-type _cursor + (&&/$proc (&/T ["jvm" "new"]) (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class) sources)) + ))) + )))) + +(defn analyse-host [analyse exo-type compilers category proc ?values] + (|let [[_ _ compile-class compile-interface] compilers] + (case category + "array" + (case proc + "new" (analyse-array-new analyse exo-type ?values) + "get" (analyse-array-get analyse exo-type ?values) + "put" (analyse-jvm-aastore analyse exo-type ?values) + "remove" (analyse-array-remove analyse exo-type ?values) + "size" (analyse-jvm-arraylength analyse exo-type ?values)) + + "jvm" + (case proc + "try" (analyse-jvm-try analyse exo-type ?values) + "throw" (analyse-jvm-throw analyse exo-type ?values) + "monitorenter" (analyse-jvm-monitorenter analyse exo-type ?values) + "monitorexit" (analyse-jvm-monitorexit analyse exo-type ?values) + "null?" (analyse-jvm-null? analyse exo-type ?values) + "null" (analyse-jvm-null analyse exo-type ?values) + "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) + "aaload" (analyse-jvm-aaload analyse exo-type ?values) + "aastore" (analyse-jvm-aastore analyse exo-type ?values) + "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) + "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) + "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) + "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) + "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) + "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) + "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) + "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) + "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) + "iadd" (analyse-jvm-iadd analyse exo-type ?values) + "isub" (analyse-jvm-isub analyse exo-type ?values) + "imul" (analyse-jvm-imul analyse exo-type ?values) + "idiv" (analyse-jvm-idiv analyse exo-type ?values) + "irem" (analyse-jvm-irem analyse exo-type ?values) + "ieq" (analyse-jvm-ieq analyse exo-type ?values) + "ilt" (analyse-jvm-ilt analyse exo-type ?values) + "igt" (analyse-jvm-igt analyse exo-type ?values) + "ceq" (analyse-jvm-ceq analyse exo-type ?values) + "clt" (analyse-jvm-clt analyse exo-type ?values) + "cgt" (analyse-jvm-cgt analyse exo-type ?values) + "ladd" (analyse-jvm-ladd analyse exo-type ?values) + "lsub" (analyse-jvm-lsub analyse exo-type ?values) + "lmul" (analyse-jvm-lmul analyse exo-type ?values) + "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) + "lrem" (analyse-jvm-lrem analyse exo-type ?values) + "leq" (analyse-jvm-leq analyse exo-type ?values) + "llt" (analyse-jvm-llt analyse exo-type ?values) + "lgt" (analyse-jvm-lgt analyse exo-type ?values) + "fadd" (analyse-jvm-fadd analyse exo-type ?values) + "fsub" (analyse-jvm-fsub analyse exo-type ?values) + "fmul" (analyse-jvm-fmul analyse exo-type ?values) + "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) + "frem" (analyse-jvm-frem analyse exo-type ?values) + "feq" (analyse-jvm-feq analyse exo-type ?values) + "flt" (analyse-jvm-flt analyse exo-type ?values) + "fgt" (analyse-jvm-fgt analyse exo-type ?values) + "dadd" (analyse-jvm-dadd analyse exo-type ?values) + "dsub" (analyse-jvm-dsub analyse exo-type ?values) + "dmul" (analyse-jvm-dmul analyse exo-type ?values) + "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) + "drem" (analyse-jvm-drem analyse exo-type ?values) + "deq" (analyse-jvm-deq analyse exo-type ?values) + "dlt" (analyse-jvm-dlt analyse exo-type ?values) + "dgt" (analyse-jvm-dgt analyse exo-type ?values) + "iand" (analyse-jvm-iand analyse exo-type ?values) + "ior" (analyse-jvm-ior analyse exo-type ?values) + "ixor" (analyse-jvm-ixor analyse exo-type ?values) + "ishl" (analyse-jvm-ishl analyse exo-type ?values) + "ishr" (analyse-jvm-ishr analyse exo-type ?values) + "iushr" (analyse-jvm-iushr analyse exo-type ?values) + "land" (analyse-jvm-land analyse exo-type ?values) + "lor" (analyse-jvm-lor analyse exo-type ?values) + "lxor" (analyse-jvm-lxor analyse exo-type ?values) + "lshl" (analyse-jvm-lshl analyse exo-type ?values) + "lshr" (analyse-jvm-lshr analyse exo-type ?values) + "lushr" (analyse-jvm-lushr analyse exo-type ?values) + "d2f" (analyse-jvm-d2f analyse exo-type ?values) + "d2i" (analyse-jvm-d2i analyse exo-type ?values) + "d2l" (analyse-jvm-d2l analyse exo-type ?values) + "f2d" (analyse-jvm-f2d analyse exo-type ?values) + "f2i" (analyse-jvm-f2i analyse exo-type ?values) + "f2l" (analyse-jvm-f2l analyse exo-type ?values) + "i2b" (analyse-jvm-i2b analyse exo-type ?values) + "i2c" (analyse-jvm-i2c analyse exo-type ?values) + "i2d" (analyse-jvm-i2d analyse exo-type ?values) + "i2f" (analyse-jvm-i2f analyse exo-type ?values) + "i2l" (analyse-jvm-i2l analyse exo-type ?values) + "i2s" (analyse-jvm-i2s analyse exo-type ?values) + "l2d" (analyse-jvm-l2d analyse exo-type ?values) + "l2f" (analyse-jvm-l2f analyse exo-type ?values) + "l2i" (analyse-jvm-l2i analyse exo-type ?values) + "c2b" (analyse-jvm-c2b analyse exo-type ?values) + "c2s" (analyse-jvm-c2s analyse exo-type ?values) + "c2i" (analyse-jvm-c2i analyse exo-type ?values) + "c2l" (analyse-jvm-c2l analyse exo-type ?values) + ;; else + (->> (fail (str "[Analyser Error] Unknown host procedure: " [category proc])) + (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] + (&reader/with-source "interface" _def-code + (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] + (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods)))) + + (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] + (&reader/with-source "class" _def-code + (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] + (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods)))) + + (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] + (&reader/with-source "anon-class" _def-code + (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] + (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods)))) + + (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] + (analyse-jvm-instanceof analyse exo-type _class ?values)) + + (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] + (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getfield analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putfield analyse exo-type _class _field ?values)))) + + ;; else + (fail (str "[Analyser Error] Unknown host procedure: " [category proc]))))) diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj index db41b5edb..e0851100d 100644 --- a/src/lux/analyser/parser.clj +++ b/src/lux/analyser/parser.clj @@ -7,375 +7,454 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]]))) + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [reader :as &reader] + [lexer :as &lexer] + [parser :as &parser]))) (declare parse-gclass) ;; [Parsers] -(defn parse-tag [ast] - (|case ast - [_ (&/$TagS "" name)] - (return name) - - _ - (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) - -(defn parse-text [ast] - (|case ast - [_ (&/$TextS text)] - (return text) - - _ - (fail (str "[Analyser Error] Not text: " (&/show-ast ast))))) - -(defn parse-type-param [ast] - (|case ast - [_ (&/$TupleS (&/$Cons [_ (&/$TextS tname)] (&/$Cons [_ (&/$TupleS ?bounds)] (&/$Nil))))] - (|do [=bounds (&/map% parse-gclass ?bounds)] - (return (&/T [tname =bounds]))) - - _ - (fail (str "[Analyser Error] Not a type-param: " (&/show-ast ast))))) - -(defn parse-gclass-decl [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS class-name)] (&/$Cons [_ (&/$TupleS args)] (&/$Nil))))] - (|do [=args (&/map% parse-type-param args)] - (return (&/T [class-name =args]))) - - _ - (fail (str "[Analyser Error] Not generic class declaration: " (&/show-ast ast))))) - -(defn parse-bound-kind [ast] - (|case ast - [_ (&/$TextS "<")] - (return &/$UpperBound) - - [_ (&/$TextS ">")] - (return &/$LowerBound) - - _ - (fail (str "[Analyser Error] Not a bound kind: " (&/show-ast ast))))) - -(defn parse-gclass [ast] - (|case ast - [_ (&/$TupleS (&/$Cons [_ (&/$TextS "*")] (&/$Nil)))] - (return (&/$GenericWildcard &/$None)) - - [_ (&/$TupleS (&/$Cons [_ (&/$TextS "*")] (&/$Cons ?bound-kind (&/$Cons ?bound (&/$Nil)))))] - (|do [=bound-kind (parse-bound-kind ?bound-kind) - =bound (parse-gclass ?bound)] - (return (&/$GenericWildcard (&/$Some (&/T [=bound-kind =bound]))))) - - [_ (&/$TextS var-name)] - (return (&/$GenericTypeVar var-name)) - - [_ (&/$FormS (&/$Cons [_ (&/$TextS class-name)] (&/$Cons [_ (&/$TupleS params)] (&/$Nil))))] - (|do [=params (&/map% parse-gclass params)] - (return (&/$GenericClass class-name =params))) - - [_ (&/$FormS (&/$Cons [_ (&/$TextS "Array")] (&/$Cons param (&/$Nil))))] - (|do [=param (parse-gclass param)] - (return (&/$GenericArray =param))) - - _ - (fail (str "[Analyser Error] Not generic class: " (&/show-ast ast))))) - -(defn parse-gclass-super [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS class-name)] (&/$Cons [_ (&/$TupleS params)] (&/$Nil))))] - (|do [=params (&/map% parse-gclass params)] - (return (&/T [class-name =params]))) - - _ - (fail (str "[Analyser Error] Not generic super-class: " (&/show-ast ast))))) - -(defn parse-ctor-arg [ast] - (|case ast - [_ (&/$TupleS (&/$Cons ?class (&/$Cons ?term (&/$Nil))))] - (|do [=class (parse-gclass ?class)] - (return (&/T [=class ?term]))) - - _ - (fail (str "[Analyser Error] Not constructor argument: " (&/show-ast ast))))) - -(let [failure (fail (str "[Analyser Error] Invalid annotation parameter."))] - (defn ^:private parse-ann-param [param] - (|case param - [[_ (&/$TextS param-name)] param-value] - (|case param-value - [_ (&/$BoolS param-value*)] (return (&/T [param-name (boolean param-value*)])) - [_ (&/$IntS param-value*)] (return (&/T [param-name (int param-value*)])) - [_ (&/$RealS param-value*)] (return (&/T [param-name (float param-value*)])) - [_ (&/$CharS param-value*)] (return (&/T [param-name (char param-value*)])) - [_ (&/$TextS param-value*)] (return (&/T [param-name param-value*])) - - _ - failure) - - _ - failure))) - -(defn parse-ann [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS ann-name)] (&/$Cons [_ (&/$RecordS ann-params)] (&/$Nil))))] - (|do [=ann-params (&/map% parse-ann-param ann-params)] +(def ^:private _space_ (&reader/read-text " ")) + +(defn ^:private repeat% [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (&/$Right (&/T [state &/$Nil])) + + (&/$Right state* head) + ((|do [tail (repeat% action)] + (return (&/$Cons head tail))) + state*)))) + +(defn ^:private spaced [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (&/$Right (&/T [state &/$Nil])) + + (&/$Right state* head) + ((&/try-all% (&/|list (|do [_ _space_ + tail (spaced action)] + (return (&/$Cons head tail))) + (return (&/|list head)))) + state*)))) + +(def ^:private parse-name + (|do [[_ _ =name] (&reader/read-regex #"^([a-zA-Z0-9_\.]+)")] + (return =name))) + +(defn ^:private with-parens [body] + (|do [_ (&reader/read-text "(") + output body + _ (&reader/read-text ")")] + (return output))) + +(defn ^:private with-brackets [body] + (|do [_ (&reader/read-text "[") + output body + _ (&reader/read-text "]")] + (return output))) + +(defn ^:private with-braces [body] + (|do [_ (&reader/read-text "{") + output body + _ (&reader/read-text "}")] + (return output))) + +(def ^:private parse-type-param + (with-parens + (|do [=name parse-name + _ _space_ + =bounds (spaced parse-gclass)] + (return (&/T [=name =bounds]))))) + +(def ^:private parse-gclass-decl + (with-parens + (|do [=class-name parse-name + _ _space_ + =params (spaced parse-type-param)] + (return (&/T [=class-name =params]))))) + +(def ^:private parse-bound-kind + (&/try-all% (&/|list (|do [_ (&reader/read-text "<")] + (return &/$UpperBound)) + + (|do [_ (&reader/read-text ">")] + (return &/$LowerBound)) + ))) + +(def parse-gclass + (&/try-all% (&/|list (|do [=bound-kind parse-bound-kind + =bound parse-gclass] + (return (&/$GenericWildcard (&/$Some (&/T [=bound-kind =bound]))))) + + (|do [_ (&reader/read-text "?")] + (return (&/$GenericWildcard &/$None))) + + (|do [var-name parse-name] + (return (&/$GenericTypeVar var-name))) + + (with-parens + (|do [class-name parse-name + _ _space_ + =params (spaced parse-gclass)] + (return (&/$GenericClass class-name =params)))) + + (with-parens + (|do [_ (&reader/read-text "Array") + _ _space_ + =param parse-gclass] + (return (&/$GenericArray =param)))) + ))) + +(def ^:private parse-gclass-super + (with-parens + (|do [class-name parse-name + _ _space_ + =params (spaced parse-gclass)] + (return (&/T [class-name =params]))))) + +(def ^:private parse-ctor-arg + (with-brackets + (|do [=class parse-gclass + (&/$Cons =term (&/$Nil)) &parser/parse] + (return (&/T [=class =term]))))) + +(def ^:private parse-ann-param + (|do [param-name parse-name + _ (&reader/read-text "=") + param-value (&/try-all% (&/|list (|do [[_ (&lexer/$Bool param-value*)] &lexer/lex-bool] + (return (boolean param-value*))) + + (|do [[_ (&lexer/$Int param-value*)] &lexer/lex-int] + (return (int param-value*))) + + (|do [_ (&reader/read-text "l") + [_ (&lexer/$Int param-value*)] &lexer/lex-int] + (return (long param-value*))) + + (|do [[_ (&lexer/$Real param-value*)] &lexer/lex-real] + (return (float param-value*))) + + (|do [_ (&reader/read-text "d") + [_ (&lexer/$Real param-value*)] &lexer/lex-real] + (return (double param-value*))) + + (|do [[_ (&lexer/$Char param-value*)] &lexer/lex-char] + (return (char param-value*))) + + (|do [[_ (&lexer/$Text param-value*)] &lexer/lex-text] + (return param-value*)) + ))] + (return (&/T [param-name param-value])))) + +(def ^:private parse-ann + (with-parens + (|do [ann-name parse-name + _ _space_ + =ann-params (with-braces + (spaced parse-ann-param))] (return {:name ann-name - :params =ann-params})) - - _ - (fail (str "[Analyser Error] Invalid annotation: " (&/show-ast ast))))) - -(defn ^:private parse-arg-decl [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS ["" arg-name])] - (&/$Cons gclass - (&/$Nil))))] - (|do [=gclass (parse-gclass gclass)] - (return (&/T [arg-name =gclass]))) - - _ - (fail (str "[Analyser Error] Invalid argument declaration: " (&/show-ast ast))))) - -(defn parse-method-decl [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS exceptions)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons output - (&/$Nil))))))))] - (|do [=anns (&/map% parse-ann anns) - =gvars (&/map% parse-text gvars) - =exceptions (&/map% parse-gclass exceptions) - =inputs (&/map% parse-gclass inputs) - =output (parse-gclass output)] - (return (&/T [method-name =anns =gvars =exceptions =inputs =output]))) - - _ - (fail (str "[Analyser Error] Invalid method declaration: " (&/show-ast ast))))) - -(defn parse-privacy-modifier [ast] - (|case ast - [_ (&/$TextS "default")] - (return &/$DefaultPM) - - [_ (&/$TextS "public")] - (return &/$PublicPM) - - [_ (&/$TextS "protected")] - (return &/$ProtectedPM) - - [_ (&/$TextS "private")] - (return &/$PrivatePM) - - _ - (fail (str "[Analyser Error] Invalid privacy modifier: " (&/show-ast ast))))) - -(defn parse-state-modifier [ast] - (|case ast - [_ (&/$TextS "default")] - (return &/$DefaultSM) - - [_ (&/$TextS "volatile")] - (return &/$VolatileSM) - - [_ (&/$TextS "final")] - (return &/$FinalSM) - - _ - (fail (str "[Analyser Error] Invalid state modifier: " (&/show-ast ast))))) - -(defn parse-inheritance-modifier [ast] - (|case ast - [_ (&/$TextS "default")] - (return &/$DefaultIM) - - [_ (&/$TextS "abstract")] - (return &/$AbstractIM) - - [_ (&/$TextS "final")] - (return &/$FinalIM) - - _ - (fail (str "[Analyser Error] Invalid inheritance modifier: " (&/show-ast ast))))) - -(defn ^:private parse-method-init-def [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS "init")] - (&/$Cons ?privacy-modifier - (&/$Cons [_ (&/$BoolS ?strict)] - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS exceptions)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TupleS ?ctor-args)] - (&/$Cons body - (&/$Nil)))))))))))] - (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) - =anns (&/map% parse-ann anns) - =gvars (&/map% parse-type-param gvars) - =exceptions (&/map% parse-gclass exceptions) - =inputs (&/map% parse-arg-decl inputs) - =ctor-args (&/map% parse-ctor-arg ?ctor-args)] - (return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier ?strict =anns =gvars =exceptions =inputs =ctor-args body])))) - - _ - (fail ""))) - -(defn ^:private parse-method-virtual-def [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS "virtual")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons ?privacy-modifier - (&/$Cons [_ (&/$BoolS =final?)] - (&/$Cons [_ (&/$BoolS ?strict)] - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS exceptions)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons output - (&/$Cons body - (&/$Nil)))))))))))))] - (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) - =anns (&/map% parse-ann anns) - =gvars (&/map% parse-type-param gvars) - =exceptions (&/map% parse-gclass exceptions) - =inputs (&/map% parse-arg-decl inputs) - =output (parse-gclass output)] - (return (&/$VirtualMethodSyntax (&/T [?name =privacy-modifier =final? ?strict =anns =gvars =exceptions =inputs =output body])))) - - _ - (fail ""))) - -(defn ^:private parse-method-override-def [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS "override")] - (&/$Cons ?class-decl - (&/$Cons ?name - (&/$Cons [_ (&/$BoolS ?strict)] - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS exceptions)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons output - (&/$Cons body - (&/$Nil))))))))))))] - (|do [=name (parse-text ?name) - =class-decl (parse-gclass-decl ?class-decl) - =anns (&/map% parse-ann anns) - =gvars (&/map% parse-type-param gvars) - =exceptions (&/map% parse-gclass exceptions) - =inputs (&/map% parse-arg-decl inputs) - =output (parse-gclass output)] - (return (&/$OverridenMethodSyntax (&/T [=class-decl =name ?strict =anns =gvars =exceptions =inputs =output body])))) - - _ - (fail ""))) - -(defn ^:private parse-method-static-def [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS "static")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons ?privacy-modifier - (&/$Cons [_ (&/$BoolS ?strict)] - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS exceptions)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons output - (&/$Cons body - (&/$Nil))))))))))))] - (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) - =anns (&/map% parse-ann anns) - =gvars (&/map% parse-type-param gvars) - =exceptions (&/map% parse-gclass exceptions) - =inputs (&/map% parse-arg-decl inputs) - =output (parse-gclass output)] - (return (&/$StaticMethodSyntax (&/T [?name =privacy-modifier ?strict =anns =gvars =exceptions =inputs =output body])))) - - _ - (fail ""))) - -(defn ^:private parse-method-abstract-def [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS "abstract")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons ?privacy-modifier - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS exceptions)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons output - (&/$Nil))))))))))] - (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) - =anns (&/map% parse-ann anns) - =gvars (&/map% parse-type-param gvars) - =exceptions (&/map% parse-gclass exceptions) - =inputs (&/map% parse-arg-decl inputs) - =output (parse-gclass output)] - (return (&/$AbstractMethodSyntax (&/T [?name =privacy-modifier =anns =gvars =exceptions =inputs =output])))) - - _ - (fail ""))) - -(defn ^:private parse-method-native-def [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS "native")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons ?privacy-modifier - (&/$Cons [_ (&/$TupleS anns)] - (&/$Cons [_ (&/$TupleS gvars)] - (&/$Cons [_ (&/$TupleS exceptions)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons output - (&/$Nil))))))))))] - (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) - =anns (&/map% parse-ann anns) - =gvars (&/map% parse-type-param gvars) - =exceptions (&/map% parse-gclass exceptions) - =inputs (&/map% parse-arg-decl inputs) - =output (parse-gclass output)] - (return (&/$NativeMethodSyntax (&/T [?name =privacy-modifier =anns =gvars =exceptions =inputs =output])))) - - _ - (fail ""))) - -(defn parse-method-def [ast] - (&/try-all% (&/|list #((parse-method-init-def ast) %) - #((parse-method-virtual-def ast) %) - #((parse-method-override-def ast) %) - #((parse-method-static-def ast) %) - #((parse-method-abstract-def ast) %) - #((parse-method-native-def ast) %) - (fn [state] - (fail* (str "[Analyser Error] Invalid method definition: " (&/show-ast ast))))))) - -(defn parse-field [ast] - (|case ast - [_ (&/$FormS (&/$Cons [_ (&/$TextS "constant")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TupleS ?anns)] - (&/$Cons ?type - (&/$Cons ?value - (&/$Nil)))))))] - (|do [=anns (&/map% parse-ann ?anns) - =type (parse-gclass ?type)] - (return (&/$ConstantFieldSyntax ?name =anns =type ?value))) - - [_ (&/$FormS (&/$Cons [_ (&/$TextS "variable")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons ?privacy-modifier - (&/$Cons ?state-modifier - (&/$Cons [_ (&/$TupleS ?anns)] - (&/$Cons ?type - (&/$Nil))))))))] - (|do [=privacy-modifier (parse-privacy-modifier ?privacy-modifier) - =state-modifier (parse-state-modifier ?state-modifier) - =anns (&/map% parse-ann ?anns) - =type (parse-gclass ?type)] - (return (&/$VariableFieldSyntax ?name =privacy-modifier =state-modifier =anns =type))) - - _ - (fail (str "[Analyser Error] Invalid field declaration: " (&/show-ast ast))))) + :params =ann-params})))) + +(def ^:private parse-arg-decl + (with-parens + (|do [=arg-name parse-name + _ (&reader/read-text " ") + =gclass parse-gclass] + (return (&/T [=arg-name =gclass]))))) + +(def ^:private parse-gvars + (|do [=head parse-name + [_ _ ?] (&reader/read-text? " ")] + (if ? + (|do [=tail parse-gvars] + (return (&/$Cons =head =tail))) + (return (&/|list =head))))) + +(def ^:private parse-method-decl + (with-parens + (|do [=method-name parse-name + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + parse-gvars) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-gclass)) + _ _space_ + =output parse-gclass] + (return (&/T [=method-name =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-privacy-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultPM)) + + (|do [_ (&reader/read-text "public")] + (return &/$PublicPM)) + + (|do [_ (&reader/read-text "protected")] + (return &/$ProtectedPM)) + + (|do [_ (&reader/read-text "private")] + (return &/$PrivatePM)) + ))) + +(def ^:private parse-state-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultSM)) + + (|do [_ (&reader/read-text "volatile")] + (return &/$VolatileSM)) + + (|do [_ (&reader/read-text "final")] + (return &/$FinalSM)) + ))) + +(def ^:private parse-inheritance-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultIM)) + + (|do [_ (&reader/read-text "abstract")] + (return &/$AbstractIM)) + + (|do [_ (&reader/read-text "final")] + (return &/$FinalIM)) + ))) + +(def ^:private parse-method-init-def + (|do [_ (&reader/read-text "init") + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + [_ (&lexer/$Bool =strict)] &lexer/lex-bool + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =ctor-args (with-brackets + (spaced parse-ctor-arg)) + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier =strict =anns =gvars =exceptions =inputs =ctor-args =body]))))) + +(def ^:private parse-method-virtual-def + (|do [_ (&reader/read-text "virtual") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + [_ (&lexer/$Bool =final?)] &lexer/lex-bool + _ _space_ + [_ (&lexer/$Bool =strict)] &lexer/lex-bool + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$VirtualMethodSyntax (&/T [=name =privacy-modifier =final? =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-override-def + (|do [_ (&reader/read-text "override") + _ _space_ + =class-decl parse-gclass-decl + _ _space_ + =name parse-name + _ _space_ + [_ (&lexer/$Bool =strict)] &lexer/lex-bool + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$OverridenMethodSyntax (&/T [=class-decl =name =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-static-def + (|do [_ (&reader/read-text "static") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + [_ (&lexer/$Bool =strict)] &lexer/lex-bool + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass + _ _space_ + (&/$Cons =body (&/$Nil)) &parser/parse] + (return (&/$StaticMethodSyntax (&/T [=name =privacy-modifier =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-abstract-def + (|do [_ (&reader/read-text "abstract") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass] + (return (&/$AbstractMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-method-native-def + (|do [_ (&reader/read-text "native") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =gvars (with-brackets + (spaced parse-type-param)) + _ _space_ + =exceptions (with-brackets + (spaced parse-gclass)) + _ _space_ + =inputs (with-brackets + (spaced parse-arg-decl)) + _ _space_ + =output parse-gclass] + (return (&/$NativeMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-method-def + (with-parens + (&/try-all% (&/|list parse-method-init-def + parse-method-virtual-def + parse-method-override-def + parse-method-static-def + parse-method-abstract-def + parse-method-native-def + )))) + +(def ^:private parse-field + (with-parens + (&/try-all% (&/|list (|do [_ (&reader/read-text "constant") + _ _space_ + =name parse-name + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =type parse-gclass + _ _space_ + (&/$Cons =value (&/$Nil)) &parser/parse] + (return (&/$ConstantFieldSyntax =name =anns =type =value))) + + (|do [_ (&reader/read-text "variable") + _ _space_ + =name parse-name + _ _space_ + =privacy-modifier parse-privacy-modifier + _ _space_ + =state-modifier parse-state-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =type parse-gclass] + (return (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type))) + )))) + +(def parse-interface-def + (|do [=gclass-decl parse-gclass-decl + =supers (with-brackets + (spaced parse-gclass-super)) + =anns (with-brackets + (spaced parse-ann)) + =methods (spaced parse-method-decl)] + (return (&/T [=gclass-decl =supers =anns =methods])))) + +(def parse-class-def + (|do [=gclass-decl parse-gclass-decl + _ _space_ + =super-class parse-gclass-super + _ _space_ + =interfaces (with-brackets + (spaced parse-gclass-super)) + _ _space_ + =inheritance-modifier parse-inheritance-modifier + _ _space_ + =anns (with-brackets + (spaced parse-ann)) + _ _space_ + =fields (with-brackets + (spaced parse-field)) + _ _space_ + =methods (with-brackets + (spaced parse-method-def))] + (return (&/T [=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods])))) + +(def parse-anon-class-def + (|do [=super-class parse-gclass-super + _ _space_ + =interfaces (with-brackets + (spaced parse-gclass-super)) + _ _space_ + =ctor-args (with-brackets + (spaced parse-ctor-arg)) + _ _space_ + =methods (with-brackets + (spaced parse-method-def))] + (return (&/T [=super-class =interfaces =ctor-args =methods])))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 124796788..713d5ea9a 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -99,15 +99,6 @@ )) )) -(defn compile-statement [syntax] - (|case syntax - (&o/$jvm-interface ?name ?supers ?anns ?methods) - (&&host/compile-jvm-interface compile-expression ?name ?supers ?anns ?methods) - - (&o/$jvm-class ?name ?super-class ?interfaces ?anns ?inheritance-modifier ?fields ?methods ??env ??ctor-args) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?anns ?inheritance-modifier ?fields ?methods ??env ??ctor-args) - )) - (defn init! [] (reset! !source->last-line {}) (.mkdirs (java.io.File. &&/output-dir)) @@ -146,15 +137,19 @@ (.get nil) return)))) +(def all-compilers + (&/T [(partial &&lux/compile-def compile-expression) + (partial &&lux/compile-program compile-expression) + (partial &&host/compile-jvm-class compile-expression) + &&host/compile-jvm-interface])) + (defn compile-module [source-dirs name] (let [file-name (str name ".lux")] (|do [file-content (&&io/read-file source-dirs file-name) :let [file-hash (hash file-content)]] (if (&&cache/cached? name) (&&cache/load source-dirs name file-hash compile-module) - (let [compiler-step (&optimizer/optimize eval! (partial compile-module source-dirs) (&/T [compile-statement - (partial &&lux/compile-def compile-expression) - (partial &&lux/compile-program compile-expression)]))] + (let [compiler-step (&optimizer/optimize eval! (partial compile-module source-dirs) all-compilers)] (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 198e77254..cb2777124 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -502,7 +502,7 @@ (return nil)))] (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) -(defn compile-jvm-interface [compile interface-decl ?supers ?anns ?methods] +(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] (|do [:let [[interface-name interface-vars] interface-decl] module &/get-module-name [file-name _ _] &/cursor @@ -530,7 +530,7 @@ (&/|list) (&/|list object-class) object-class]))] - (compile-jvm-interface nil interface-decl ?supers ?anns ?methods))) + (compile-jvm-interface interface-decl ?supers ?anns ?methods))) (def compile-LuxUtils-class (|do [_ (return nil) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index f6113cc7c..8262e5be0 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -116,7 +116,7 @@ (return (&/T [pre-quotes* ""]))))] (return (str (clean-line pre-quotes) post-quotes)))) -(def ^:private lex-text +(def lex-text (|do [[meta _ _] (&reader/read-text "\"") :let [[_ _ _column] meta] token (lex-text-body false (inc _column)) @@ -156,12 +156,12 @@ (|do [[meta _ token] (&reader/read-regex <regex>)] (return (&/T [meta (<tag> token)])))) - ^:private lex-bool $Bool #"^(true|false)" - ^:private lex-int $Int #"^-?(0|[1-9][0-9]*)" - ^:private lex-real $Real #"^-?(0\.[0-9]+|[1-9][0-9]*\.[0-9]+)(e-?[1-9][0-9]*)?" + lex-bool $Bool #"^(true|false)" + lex-int $Int #"^-?(0|[1-9][0-9]*)" + lex-real $Real #"^-?(0\.[0-9]+|[1-9][0-9]*\.[0-9]+)(e-?[1-9][0-9]*)?" ) -(def ^:private lex-char +(def lex-char (|do [[meta _ _] (&reader/read-text "#\"") token (&/try-all% (&/|list (|do [[_ _ escaped] (&reader/read-regex #"^(\\.)")] (escape-char escaped)) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 704473935..f996587b5 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -24,62 +24,53 @@ ("var" 1) ("captured" 1) ("proc" 2) - - ("jvm-class" 1) - ("jvm-interface" 1) ) ;; [Exports] (defn optimize-token [analysis] "(-> Analysis Optimized)" (|case analysis - (&-base/$bool value) - (return ($bool value)) + [meta (&-base/$bool value)] + (return (&/T [meta ($bool value)])) - (&-base/$int value) - (return ($int value)) + [meta (&-base/$int value)] + (return (&/T [meta ($int value)])) - (&-base/$real value) - (return ($real value)) + [meta (&-base/$real value)] + (return (&/T [meta ($real value)])) - (&-base/$char value) - (return ($char value)) + [meta (&-base/$char value)] + (return (&/T [meta ($char value)])) - (&-base/$text value) - (return ($text value)) + [meta (&-base/$text value)] + (return (&/T [meta ($text value)])) - (&-base/$variant value) - (return ($variant value)) + [meta (&-base/$variant value)] + (return (&/T [meta ($variant value)])) - (&-base/$tuple value) - (return ($tuple value)) + [meta (&-base/$tuple value)] + (return (&/T [meta ($tuple value)])) - (&-base/$apply value) - (return ($apply value)) + [meta (&-base/$apply value)] + (return (&/T [meta ($apply value)])) - (&-base/$case value) - (return ($case value)) + [meta (&-base/$case value)] + (return (&/T [meta ($case value)])) - (&-base/$lambda value) - (return ($lambda value)) + [meta (&-base/$lambda value)] + (return (&/T [meta ($lambda value)])) - (&-base/$ann value) - (return ($ann value)) + [meta (&-base/$ann value)] + (return (&/T [meta ($ann value)])) - (&-base/$var value) - (return ($var value)) + [meta (&-base/$var value)] + (return (&/T [meta ($var value)])) - (&-base/$captured value) - (return ($captured value)) + [meta (&-base/$captured value)] + (return (&/T [meta ($captured value)])) - (&-base/$proc ?proc-ident ?args) - (return ($proc ?proc-ident ?args)) - - (&-base/$jvm-class value) - (return ($jvm-class value)) - - (&-base/$jvm-interface value) - (return ($jvm-interface value)) + [meta (&-base/$proc ?proc-ident ?args)] + (return (&/T [meta ($proc ?proc-ident ?args)])) _ (assert false (prn-str 'optimize-token (&/adt->text analysis))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 571a6c5dc..b81b7c826 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -129,3 +129,13 @@ (reduce (fn [tail head] (&/$Cons head tail)) &/$Nil (reverse indexed-lines)))) + +(defn with-source [name content body] + (fn [state] + (|let [old-source (&/get$ &/$source state)] + (|case (body (&/set$ &/$source (from name content) state)) + (&/$Left error) + (&/$Left error) + + (&/$Right state* output) + (&/$Right (&/T [(&/set$ &/$source old-source state*) output])))))) diff --git a/src/lux/repl.clj b/src/lux/repl.clj index 134aacafe..3861806ed 100644 --- a/src/lux/repl.clj +++ b/src/lux/repl.clj @@ -51,7 +51,7 @@ state* (&/update$ &/$source (fn [_source] (&/|++ _source line*)) state)] - (|case ((|do [analysed-tokens (&analyser/repl-analyse &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/compile-statement) + (|case ((|do [analysed-tokens (&analyser/repl-analyse &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) optimized-tokens (->> analysed-tokens (&/|map &a-base/expr-term) (&/map% &optimizer/optimize-token)) |