aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2015-10-29 11:24:17 -0400
committerEduardo Julian2015-10-29 11:24:17 -0400
commit9bb3887176488a06cd61d246ece556be3bd1d16a (patch)
tree69779098c1a1310732f13493b7795a5e1223a1f8
parent637c60c384de3299415d1c3fe9633c7c4bc82273 (diff)
- Now requiring parameterized classes everywhere when invoking methods.
-rw-r--r--src/lux/analyser.clj62
-rw-r--r--src/lux/analyser/host.clj77
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]