Changeset 13992
 Timestamp:
 07/04/12 21:13:59 (8 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13991 r13992 1622 1622 (when mcp 1623 1623 (error "Preliminary ensuremethod does not support :methodcombination argument.")) 1624 (setf gf (apply (if (eq genericfunctionclass +thestandardgenericfunctionclass+) 1624 (setf gf (apply (if (eq genericfunctionclass 1625 +thestandardgenericfunctionclass+) 1625 1626 #'makeinstancestandardgenericfunction 1626 1627 #'makeinstance) … … 2223 2224 (defun methodapplicableusingclassesp (method classes) 2224 2225 (do* ((specializers (methodspecializers method) (cdr specializers)) 2225 2226 2226 (classes classes (cdr classes)) 2227 (knownp t)) 2227 2228 ((null specializers) 2228 2229 (if knownp (values t t) (values nil nil))) 2229 2230 (let ((specializer (car specializers))) 2230 2231 (if (typep specializer 'eqlspecializer) 2231 2232 2233 2234 2235 2236 2232 (if (eql (classof (eqlspecializerobject specializer)) 2233 (car classes)) 2234 (setf knownp nil) 2235 (return (values nil t))) 2236 (unless (subclassp (car classes) specializer) 2237 (return (values nil t))))))) 2237 2238 2238 2239 (defun checkapplicablemethodkeywordargs (gf args … … 2280 2281 (if (eq (classof gf) +thestandardgenericfunctionclass+) 2281 2282 (stdcomputeapplicablemethods gf args) 2282 (computeapplicablemethods gf args)))) 2283 (or (computeapplicablemethodsusingclasses gf (mapcar #'classof args)) 2284 (computeapplicablemethods gf args))))) 2283 2285 (if applicablemethods 2284 (let* ((emfun (funcall (if (eq (classof gf) +thestandardgenericfunctionclass+) 2286 (let* ((emfun (funcall (if (eq (classof gf) 2287 +thestandardgenericfunctionclass+) 2285 2288 #'stdcomputeeffectivemethod 2286 2289 #'computeeffectivemethod) 2287 2290 gf (genericfunctionmethodcombination gf) 2288 2291 applicablemethods)) 2289 (nonkeywordargs 2290 (+ (length (gfrequiredargs gf)) 2291 (length (gfoptionalargs gf)))) 2292 (nonkeywordargs (+ (length (gfrequiredargs gf)) 2293 (length (gfoptionalargs gf)))) 2292 2294 (gflambdalist (genericfunctionlambdalist gf)) 2293 2295 (checksrequired (and (member '&key gflambdalist) 2294 2296 (not (member '&allowotherkeys 2295 gflambdalist))) 2296 ) 2297 gflambdalist)))) 2297 2298 (applicablekeywords 2298 2299 (when checksrequired … … 2314 2315 (if (eq (classof gf) +thestandardgenericfunctionclass+) 2315 2316 (stdcomputeapplicablemethods gf (list arg)) 2316 (computeapplicablemethods gf (list arg))))) 2317 (or (computeapplicablemethodsusingclasses gf (list (classof arg))) 2318 (computeapplicablemethods gf (list arg)))))) 2317 2319 (if applicablemethods 2318 (let ((emfun (funcall (if (eq (classof gf) +thestandardgenericfunctionclass+) 2320 (let ((emfun (funcall (if (eq (classof gf) 2321 +thestandardgenericfunctionclass+) 2319 2322 #'stdcomputeeffectivemethod 2320 2323 #'computeeffectivemethod) … … 3403 3406 initargs)) 3404 3407 (mapcan #'(lambda (gf) 3405 (if (eq (classof gf) +thestandardgenericfunctionclass+) 3408 (if (eq (classof gf) 3409 +thestandardgenericfunctionclass+) 3406 3410 (stdcomputeapplicablemethods gf args) 3407 3411 (computeapplicablemethods gf args)))
Note: See TracChangeset
for help on using the changeset viewer.