diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux/analyser.clj | 62 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 77 |
2 files changed, 74 insertions, 65 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 704e4d4c2..8de389e56 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -74,6 +74,22 @@ (|let [[file line col] meta] (str "@ " file "," line "," col "\n" msg)))) +(defn ^:private fail-with-loc [msg] + (fn [state] + (fail* (add-loc (&/get$ &/$cursor state) msg)))) + +(defn ^:private parse-generic-class [sample] + "(-> AST (Lux GenericClass))" + (|case sample + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS ?params)] + (&/$Nil))))] + (|do [=params (&/map% parse-generic-class ?params)] + (return (&/T ?name =params))) + + _ + (fail-with-loc (str "[Analyser Error] Wrong syntax for generic class: " (&/show-ast sample))))) + (defn ^:private aba10 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays @@ -123,8 +139,7 @@ (&&host/analyse-jvm-laload analyse exo-type ?array ?idx) _ - #(fail* (add-loc (&/get$ &/$cursor %) - (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T (&/T "" -1 -1) token)))))))) + (fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T (&/T "" -1 -1) token))))))) (defn ^:private aba9 [analyse eval! compile-module compile-token exo-type token] (|case token @@ -325,12 +340,13 @@ (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] - (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons ?poly-class (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))) - (|do [=classes (&/map% extract-text ?classes)] - (&&host/analyse-jvm-new analyse exo-type ?class =classes ?args)) + (|do [=generic-class (parse-generic-class ?poly-class) + =classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-new analyse exo-type =generic-class =classes ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] (&/$Cons [_ (&/$TextS ?class)] @@ -361,43 +377,47 @@ (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?value ?object) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] - (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons ?poly-class (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?arg-classes)] (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))))))) - (|do [=classes (&/map% extract-text ?classes)] - (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method =classes ?args)) + (|do [=generic-class (parse-generic-class ?poly-class) + =arg-classes (&/map% parse-generic-class ?arg-classes)] + (&&host/analyse-jvm-invokestatic analyse exo-type =generic-class ?method =arg-classes ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] - (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons ?poly-class (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?arg-classes)] (&/$Cons ?object (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) - (|do [=classes (&/map% extract-text ?classes)] - (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method =classes ?object ?args)) + (|do [=generic-class (parse-generic-class ?poly-class) + =arg-classes (&/map% parse-generic-class ?arg-classes)] + (&&host/analyse-jvm-invokevirtual analyse exo-type =generic-class ?method =arg-classes ?object ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] - (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons ?poly-class (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?arg-classes)] (&/$Cons ?object (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) - (|do [=classes (&/map% extract-text ?classes)] - (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method =classes ?object ?args)) + (|do [=generic-class (parse-generic-class ?poly-class) + =arg-classes (&/map% parse-generic-class ?arg-classes)] + (&&host/analyse-jvm-invokeinterface analyse exo-type =generic-class ?method =arg-classes ?object ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] - (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons ?poly-class (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?arg-classes)] (&/$Cons ?object (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) - (|do [=classes (&/map% extract-text ?classes)] - (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method =classes ?object ?args)) + (|do [=generic-class (parse-generic-class ?poly-class) + =arg-classes (&/map% parse-generic-class ?arg-classes)] + (&&host/analyse-jvm-invokespecial analyse exo-type =generic-class ?method =arg-classes ?object ?args)) ;; Exceptions (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 46f4b1f1c..92550f0fb 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -113,23 +113,6 @@ _ type)) -(defn ^:private clean-gtype-var [idx gtype-var] - (|let [(&/$VarT id) gtype-var] - (|do [? (&type/bound? id)] - (if ? - (|do [real-type (&type/deref id)] - (return (&/T idx real-type))) - (return (&/T (+ 2 idx) (&type/Bound$ idx))))))) - -(defn ^:private clean-gtype-vars [gtype-vars] - (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] - (|do [:let [[idx types] idx+types] - [idx* real-type] (clean-gtype-var idx gtype-var)] - (return (&/T idx* (&/Cons$ real-type types))))) - (&/T 1 (&/|list)) - gtype-vars)] - (return clean-types))) - (defn ^:private make-gtype [class-name type-args] "(-> Text (List Type) Type)" (&/fold (fn [base-type type-arg] @@ -265,7 +248,11 @@ (return (&/|list (&&/|meta output-type _cursor (&/V &&/$jvm-instanceof (&/T class =object))))))) -(defn ^:private analyse-method-call-helper [analyse gret gtype-env gtype-vars gtype-args args] +(defn ^:private instance-generic-type [desc] + (|let [[gc-name gc-params] desc] + (&type/Data$ gc-name (&/|map instance-generic-type gc-params)))) + +(defn ^:private analyse-method-call-helper [analyse gret gc-params gtype-env gtype-vars gtype-args args] (|case gtype-vars (&/$Nil) (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) @@ -274,59 +261,60 @@ (return (&/T =gret =args))) (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] - (analyse-method-call-helper analyse gret gtype-env* gtype-vars* gtype-args args)))) + (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) (->> gc-params &/|head instance-generic-type)) + gtype-env)] + (analyse-method-call-helper analyse gret (&/|tail gc-params) gtype-env* gtype-vars* gtype-args args)) )) (let [dummy-type-param (&type/Data$ "java.lang.Object" (&/|list))] (do-template [<name> <tag> <only-interface?>] - (defn <name> [analyse exo-type class method classes object args] + (defn <name> [analyse exo-type generic-class method arg-classes object args] (|do [class-loader &/loader - _ (try (assert! (let [=class (Class/forName class true class-loader)] + :let [[gc-name gc-params] generic-class] + _ (try (assert! (let [=class (Class/forName gc-name true class-loader)] (= <only-interface?> (.isInterface =class))) (if <only-interface?> (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) (catch Exception e - (fail (str "[Analyser Error] Unknown class: " class)))) + (fail (str "[Analyser Error] Unknown class: " gc-name)))) [gret exceptions parent-gvars gvars gargs] (if (= "<init>" method) (return (&/T Void/TYPE &/Nil$ &/Nil$ &/Nil$ &/Nil$)) - (&host/lookup-virtual-method class-loader class method classes)) + (&host/lookup-virtual-method class-loader gc-name method arg-classes)) _ (ensure-catching exceptions) =object (&&/analyse-1+ analyse object) [sub-class sub-params] (ensure-object (&&/expr-type* =object)) - (&/$DataT super-class* super-params*) (&host-type/->super-type &type/existential class-loader class sub-class sub-params) + (&/$DataT super-class* super-params*) (&host-type/->super-type &type/existential class-loader gc-name sub-class sub-params) :let [_ (prn '<name> sub-class '-> super-class* (&/|length parent-gvars) (&/|length super-params*)) gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/Cons$ (&/T (.getName g) t) m)) (&/|table) parent-gvars super-params*)] - [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) + [output-type =args] (analyse-method-call-helper analyse gret gc-params gtype-env gvars gargs args) _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V <tag> (&/T class method classes =object =args output-type))))))) + (&/V <tag> (&/T gc-name method arg-classes =object =args output-type))))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual false analyse-jvm-invokespecial &&/$jvm-invokespecial false analyse-jvm-invokeinterface &&/$jvm-invokeinterface true )) -(defn analyse-jvm-invokestatic [analyse exo-type class method classes args] +(defn analyse-jvm-invokestatic [analyse exo-type generic-class method arg-classes args] (|do [class-loader &/loader - [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes) + :let [[gc-name gc-params] generic-class] + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader gc-name method arg-classes) _ (ensure-catching exceptions) =args (&/map2% (fn [_class _arg] (&&/analyse-1 analyse (&host-type/class-name->type _class) _arg)) - classes + arg-classes args) :let [output-type (&host-type/class->type (cast Class gret))] _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-invokestatic (&/T class method classes =args output-type))))))) + (&/V &&/$jvm-invokestatic (&/T gc-name method arg-classes =args output-type))))))) (defn analyse-jvm-null? [analyse exo-type object] (|do [=object (&&/analyse-1+ analyse object) @@ -344,31 +332,32 @@ (return (&/|list (&&/|meta output-type _cursor (&/V &&/$jvm-null nil)))))) -(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] +(defn ^:private analyse-jvm-new-helper [analyse gc-name gc-params gtype-env gtype-vars gtype-args args] + (prn 'analyse-jvm-new-helper gc-name (&/->seq gc-params) (&/->seq (&/|map #(.getName ^TypeVariable %) gtype-vars))) (|case gtype-vars (&/$Nil) (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] - (return (&/T (make-gtype gtype gtype-vars*) + :let [gtype-vars* (->> gtype-env (&/|map &/|second))]] + (return (&/T (make-gtype gc-name gtype-vars*) =args))) (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] - (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args)))) + (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) (->> gc-params &/|head instance-generic-type)) + gtype-env)] + (analyse-jvm-new-helper analyse gc-name (&/|tail gc-params) gtype-env* gtype-vars* gtype-args args)) )) -(defn analyse-jvm-new [analyse exo-type class classes args] +(defn analyse-jvm-new [analyse exo-type generic-class arg-classes args] (|do [class-loader &/loader - [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) + :let [[gc-name gc-params] generic-class] + [exceptions gvars gargs] (&host/lookup-constructor class-loader gc-name arg-classes) _ (ensure-catching exceptions) - [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + [output-type =args] (analyse-jvm-new-helper analyse gc-name gc-params (&/|table) gvars gargs args) _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-new (&/T class classes =args))))))) + (&/V &&/$jvm-new (&/T gc-name arg-classes =args))))))) (let [length-type &type/Int idx-type &type/Int] |