Skip to content

Commit 2e3db85

Browse files
bronsabronsa
committed
stricter validate
1 parent 263a41d commit 2e3db85

1 file changed

Lines changed: 64 additions & 60 deletions

File tree

  • src/main/clojure/clojure/tools/analyzer/passes/jvm

‎src/main/clojure/clojure/tools/analyzer/passes/jvm/validate.clj‎

Lines changed: 64 additions & 60 deletions
Original file line numberDiff line numberDiff line change
@@ -53,22 +53,41 @@
5353
:form form}
5454
(source-info env))))))))
5555

56+
(defn- resolve-method-by-param-tags [methods param-tags ^Class class desc env]
57+
(or (resolve-hinted-method methods param-tags)
58+
(throw (ex-info (str "param-tags " (pr-str param-tags)
59+
" insufficient to resolve " desc
60+
" in class " (.getName class))
61+
(merge {:class class :param-tags param-tags}
62+
(source-info env))))))
63+
64+
(defn- tag-args-from-method [ast m]
65+
(let [arg-tags (mapv u/maybe-class (:parameter-types m))]
66+
(assoc ast
67+
:args (mapv (fn [arg tag] (assoc arg :tag tag)) (:args ast) arg-tags)
68+
:validated? true)))
69+
70+
(defn- found-method [ast tag instance? m]
71+
(let [ret-tag (:return-type m)
72+
class (u/maybe-class (:declaring-class m))]
73+
(merge' (-> ast (tag-args-from-method m))
74+
{:method (:name m)
75+
:class class
76+
:o-tag ret-tag
77+
:tag (or tag ret-tag)}
78+
(when instance?
79+
{:instance (assoc (:instance ast) :tag class)}))))
80+
5681
(defmethod -validate :method-value
5782
[{:keys [class method kind param-tags methods env] :as ast}]
5883
(let [class (u/maybe-class class)]
5984
(if param-tags
60-
(if-let [m (resolve-hinted-method methods param-tags)]
85+
(let [m (resolve-method-by-param-tags methods param-tags class
86+
(str (name kind) " method " method) env)]
6187
(assoc ast
6288
:class class
6389
:methods [m]
64-
:validated? true)
65-
(throw (ex-info (str "param-tags " (pr-str param-tags)
66-
" insufficient to resolve " (name kind) " method "
67-
method " in class " (.getName ^Class class))
68-
(merge {:class class
69-
:method method
70-
:param-tags param-tags}
71-
(source-info env)))))
90+
:validated? true))
7291
(assoc ast
7392
:class class
7493
:validated? true))))
@@ -83,66 +102,51 @@
83102
ast)
84103

85104
(defmethod -validate :new
86-
[{:keys [args] :as ast}]
105+
[{:keys [args param-tags methods] :as ast}]
87106
(if (:validated? ast)
88107
ast
89108
(if-not (= :class (-> ast :class :type))
90109
(throw (ex-info (str "Unable to resolve classname: " (:form (:class ast)))
91110
(merge {:class (:form (:class ast))
92111
:ast ast}
93112
(source-info (:env ast)))))
94-
(let [^Class class (-> ast :class :val)
95-
c-name (symbol (.getName class))
96-
argc (count args)
97-
tags (mapv :tag args)]
98-
(let [[ctor & rest] (->> (filter #(= (count (:parameter-types %)) argc)
99-
(u/members class c-name))
100-
(try-best-match tags))]
101-
(if ctor
102-
(if (empty? rest)
103-
(let [arg-tags (mapv u/maybe-class (:parameter-types ctor))
104-
args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags)]
105-
(assoc ast
106-
:args args
107-
:validated? true))
108-
ast)
109-
(throw (ex-info (str "no ctor found for ctor of class: " class " and given signature")
110-
(merge {:class class
111-
:args (mapv (fn [a] (prewalk a cleanup)) args)}
112-
(source-info (:env ast)))))))))))
113-
114-
(defn- found-method [ast args tag instance? instance m]
115-
(let [ret-tag (:return-type m)
116-
arg-tags (mapv u/maybe-class (:parameter-types m))
117-
args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags)
118-
class (u/maybe-class (:declaring-class m))]
119-
(merge' ast
120-
{:method (:name m)
121-
:validated? true
122-
:class class
123-
:o-tag ret-tag
124-
:tag (or tag ret-tag)
125-
:args args}
126-
(if instance?
127-
{:instance (assoc instance :tag class)}))))
113+
(let [^Class class (-> ast :class :val)]
114+
(if param-tags
115+
(-> ast (tag-args-from-method (resolve-method-by-param-tags methods param-tags class "constructor" (:env ast))))
116+
(let [c-name (symbol (.getName class))
117+
argc (count args)
118+
tags (mapv :tag args)
119+
[ctor & rest] (->> (filter #(= (count (:parameter-types %)) argc)
120+
(u/members class c-name))
121+
(try-best-match tags))]
122+
(if ctor
123+
(if (empty? rest)
124+
(-> ast (tag-args-from-method ctor))
125+
ast)
126+
(throw (ex-info (str "no ctor found for ctor of class: " class " and given signature")
127+
(merge {:class class
128+
:args (mapv (fn [a] (prewalk a cleanup)) args)}
129+
(source-info (:env ast))))))))))))
128130

129-
(defn validate-call [{:keys [class instance method args tag env op param-tags] :as ast}]
131+
(defn validate-call [{:keys [class instance method args tag env op param-tags methods] :as ast}]
130132
(let [argc (count args)
131133
instance? (= :instance-call op)
132-
f (if instance? u/instance-methods u/static-methods)
133134
tags (mapv :tag args)]
134-
(if-let [matching-methods (seq (f class method argc))]
135-
;; try resolving via param-tags first
136-
(if-let [hinted-method (and param-tags
137-
(resolve-hinted-method matching-methods param-tags))]
138-
(found-method ast args tag instance? instance hinted-method)
135+
(if param-tags
136+
(-> ast
137+
(found-method tag instance?
138+
(resolve-method-by-param-tags methods param-tags class
139+
(str (if instance? "instance" "static") " method " method)
140+
env)))
141+
(if-let [matching-methods (seq ((if instance? u/instance-methods u/static-methods)
142+
class method argc))]
139143
(let [[m & rest :as matching] (try-best-match tags matching-methods)]
140144
(if m
141145
(let [all-ret-equals? (apply = (mapv :return-type matching))]
142146
(if (or (empty? rest)
143147
(and all-ret-equals? ;; if the method signature is the same just pick the first one
144148
(apply = (mapv #(mapv u/maybe-class (:parameter-types %)) matching))))
145-
(found-method ast args tag instance? instance m)
149+
(-> ast (found-method tag instance? m))
146150
(if all-ret-equals?
147151
(let [ret-tag (:return-type m)]
148152
(assoc ast
@@ -155,14 +159,14 @@
155159
(merge {:method method
156160
:class class
157161
:args (mapv (fn [a] (prewalk a cleanup)) args)}
158-
(source-info env))))))))
159-
(if instance?
160-
(assoc (dissoc ast :class) :tag Object :o-tag Object)
161-
(throw (ex-info (str "No matching method: " method " for class: " class " and arity: " argc)
162-
(merge {:method method
163-
:class class
164-
:argc argc}
165-
(source-info env))))))))
162+
(source-info env)))))))
163+
(if instance?
164+
(assoc (dissoc ast :class) :tag Object :o-tag Object)
165+
(throw (ex-info (str "No matching method: " method " for class: " class " and arity: " argc)
166+
(merge {:method method
167+
:class class
168+
:argc argc}
169+
(source-info env)))))))))
166170

167171
(defmethod -validate :static-call
168172
[ast]

0 commit comments

Comments
 (0)