1;;;; This software is part of the SBCL system. See the README file for 2;;;; more information. 3 4;;;; This software is derived from software originally released by Xerox 5;;;; Corporation. Copyright and release statements follow. Later modifications 6;;;; to the software are in the public domain and are provided with 7;;;; absolutely no warranty. See the COPYING and CREDITS files for more 8;;;; information. 9 10;;;; copyright information from original PCL sources: 11;;;; 12;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. 13;;;; All rights reserved. 14;;;; 15;;;; Use and copying of this software and preparation of derivative works based 16;;;; upon this software are permitted. Any distribution of this software or 17;;;; derivative works must comply with all applicable United States export 18;;;; control laws. 19;;;; 20;;;; This software is made available AS IS, and Xerox Corporation makes no 21;;;; warranty about the software, its performance or its conformity to any 22;;;; specification. 23 24(in-package "SB-PCL") 25 26;;; FIXME: according to ANSI 3.4.10 this is supposed to allow &WHOLE 27;;; in the long syntax. But it clearly does not, because if you write 28;;; (&WHOLE v) then you get (LAMBDA (&WHOLE V ...) ...) which is illegal 29;;; 30(defmacro define-method-combination (&whole form &rest args) 31 (declare (ignore args)) 32 `(progn 33 (with-single-package-locked-error 34 (:symbol ',(second form) "defining ~A as a method combination")) 35 ,(if (and (cddr form) 36 (listp (caddr form))) 37 (expand-long-defcombin form) 38 (expand-short-defcombin form)))) 39 40;;;; standard method combination 41 42;;; The STANDARD method combination type is implemented directly by 43;;; the class STANDARD-METHOD-COMBINATION. The method on 44;;; COMPUTE-EFFECTIVE-METHOD does standard method combination directly 45;;; and is defined by hand in the file combin.lisp. The method for 46;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping 47;;; reasons. 48(defmethod find-method-combination ((generic-function generic-function) 49 (type-name (eql 'standard)) 50 options) 51 (when options 52 (method-combination-error 53 "STANDARD method combination accepts no options.")) 54 *standard-method-combination*) 55 56;;;; short method combinations 57;;;; 58;;;; Short method combinations all follow the same rule for computing the 59;;;; effective method. So, we just implement that rule once. Each short 60;;;; method combination object just reads the parameters out of the object 61;;;; and runs the same rule. 62 63(defun expand-short-defcombin (whole) 64 (let* ((type-name (cadr whole)) 65 (documentation 66 (getf (cddr whole) :documentation)) 67 (identity-with-one-arg 68 (getf (cddr whole) :identity-with-one-argument nil)) 69 (operator 70 (getf (cddr whole) :operator type-name))) 71 `(load-short-defcombin 72 ',type-name ',operator ',identity-with-one-arg ',documentation 73 (sb-c:source-location)))) 74 75(defun load-short-defcombin (type-name operator ioa doc source-location) 76 (let* ((specializers 77 (list (find-class 'generic-function) 78 (intern-eql-specializer type-name) 79 *the-class-t*)) 80 (old-method 81 (get-method #'find-method-combination () specializers nil)) 82 (new-method nil)) 83 (setq new-method 84 (make-instance 'standard-method 85 :qualifiers () 86 :specializers specializers 87 :lambda-list '(generic-function type-name options) 88 :function (lambda (args nms &rest cm-args) 89 (declare (ignore nms cm-args)) 90 (apply 91 (lambda (gf type-name options) 92 (declare (ignore gf)) 93 (short-combine-methods 94 type-name options operator ioa new-method doc)) 95 args)) 96 :definition-source source-location)) 97 (when old-method 98 (remove-method #'find-method-combination old-method)) 99 (add-method #'find-method-combination new-method) 100 (setf (random-documentation type-name 'method-combination) doc) 101 type-name)) 102 103(defun short-combine-methods (type-name options operator ioa method doc) 104 (cond ((null options) (setq options '(:most-specific-first))) 105 ((equal options '(:most-specific-first))) 106 ((equal options '(:most-specific-last))) 107 (t 108 (method-combination-error 109 "Illegal options to a short method combination type.~%~ 110 The method combination type ~S accepts one option which~%~ 111 must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." 112 type-name))) 113 (make-instance 'short-method-combination 114 :type-name type-name 115 :options options 116 :operator operator 117 :identity-with-one-argument ioa 118 :definition-source method 119 :documentation doc)) 120 121(defmethod invalid-qualifiers ((gf generic-function) 122 (combin short-method-combination) 123 method) 124 (let* ((qualifiers (method-qualifiers method)) 125 (qualifier (first qualifiers)) 126 (type-name (method-combination-type-name combin)) 127 (why (cond 128 ((null qualifiers) 129 "has no qualifiers") 130 ((cdr qualifiers) 131 "has too many qualifiers") 132 (t 133 (aver (not (short-method-combination-qualifier-p 134 type-name qualifier))) 135 "has an invalid qualifier")))) 136 (invalid-method-error 137 method 138 "~@<The method ~S on ~S ~A.~ 139 ~@:_~@:_~ 140 The method combination type ~S was defined with the short form ~ 141 of DEFINE-METHOD-COMBINATION and so requires all methods have ~ 142 either ~{the single qualifier ~S~^ or ~}.~@:>" 143 method gf why type-name (short-method-combination-qualifiers type-name)))) 144 145;;;; long method combinations 146 147(defun expand-long-defcombin (form) 148 (let ((type-name (cadr form)) 149 (lambda-list (caddr form)) 150 (method-group-specifiers (cadddr form)) 151 (body (cddddr form)) 152 (args-option ()) 153 (gf-var nil)) 154 (when (and (consp (car body)) (eq (caar body) :arguments)) 155 (setq args-option (cdr (pop body)))) 156 (when (and (consp (car body)) (eq (caar body) :generic-function)) 157 (setq gf-var (cadr (pop body)))) 158 (multiple-value-bind (documentation function) 159 (make-long-method-combination-function 160 type-name lambda-list method-group-specifiers args-option gf-var 161 body) 162 `(load-long-defcombin ',type-name ',documentation #',function 163 ',args-option (sb-c:source-location))))) 164 165(defvar *long-method-combination-functions* (make-hash-table :test 'eq)) 166 167(defun load-long-defcombin 168 (type-name doc function args-lambda-list source-location) 169 (let* ((specializers 170 (list (find-class 'generic-function) 171 (intern-eql-specializer type-name) 172 *the-class-t*)) 173 (old-method 174 (get-method #'find-method-combination () specializers nil)) 175 (new-method 176 (make-instance 'standard-method 177 :qualifiers () 178 :specializers specializers 179 :lambda-list '(generic-function type-name options) 180 :function (lambda (args nms &rest cm-args) 181 (declare (ignore nms cm-args)) 182 (apply 183 (lambda (generic-function type-name options) 184 (declare (ignore generic-function)) 185 (make-instance 'long-method-combination 186 :type-name type-name 187 :options options 188 :args-lambda-list args-lambda-list 189 :documentation doc)) 190 args)) 191 :definition-source source-location))) 192 (setf (gethash type-name *long-method-combination-functions*) function) 193 (when old-method (remove-method #'find-method-combination old-method)) 194 (add-method #'find-method-combination new-method) 195 (setf (random-documentation type-name 'method-combination) doc) 196 type-name)) 197 198(defmethod compute-effective-method ((generic-function generic-function) 199 (combin long-method-combination) 200 applicable-methods) 201 (funcall (gethash (method-combination-type-name combin) 202 *long-method-combination-functions*) 203 generic-function 204 combin 205 applicable-methods)) 206 207(defun make-long-method-combination-function 208 (type-name ll method-group-specifiers args-option gf-var body) 209 (declare (ignore type-name)) 210 (multiple-value-bind (real-body declarations documentation) 211 (parse-body body t) 212 (let ((wrapped-body 213 (wrap-method-group-specifier-bindings method-group-specifiers 214 declarations 215 real-body))) 216 (when gf-var 217 (push `(,gf-var .generic-function.) (cadr wrapped-body))) 218 219 (when args-option 220 (setq wrapped-body (deal-with-args-option wrapped-body args-option))) 221 222 (when ll 223 (setq wrapped-body 224 `(apply #'(lambda ,ll ,wrapped-body) 225 (method-combination-options .method-combination.)))) 226 227 (values 228 documentation 229 `(lambda (.generic-function. .method-combination. .applicable-methods.) 230 (declare (ignorable .generic-function. 231 .method-combination. .applicable-methods.)) 232 (block .long-method-combination-function. ,wrapped-body)))))) 233 234(define-condition long-method-combination-error 235 (reference-condition simple-error) 236 () 237 (:default-initargs 238 :references (list '(:ansi-cl :macro define-method-combination)))) 239 240;;; NOTE: 241;;; 242;;; The semantics of long form method combination in the presence of 243;;; multiple methods with the same specializers in the same method 244;;; group are unclear by the spec: a portion of the standard implies 245;;; that an error should be signalled, and another is more lenient. 246;;; 247;;; It is reasonable to allow a single method group of * to bypass all 248;;; rules, as this is explicitly stated in the standard. 249 250(defun group-cond-clause (name tests specializer-cache star-only) 251 (let ((maybe-error-clause 252 (if star-only 253 `(setq ,specializer-cache .specializers.) 254 `(if (and (equal ,specializer-cache .specializers.) 255 (not (null .specializers.))) 256 (return-from .long-method-combination-function. 257 '(error 'long-method-combination-error 258 :format-control "More than one method of type ~S ~ 259 with the same specializers." 260 :format-arguments (list ',name))) 261 (setq ,specializer-cache .specializers.))))) 262 `((or ,@tests) 263 ,maybe-error-clause 264 (push .method. ,name)))) 265 266(defun wrap-method-group-specifier-bindings 267 (method-group-specifiers declarations real-body) 268 (let (names specializer-caches cond-clauses required-checks order-cleanups) 269 (let ((nspecifiers (length method-group-specifiers))) 270 (dolist (method-group-specifier method-group-specifiers 271 (push `(t (return-from .long-method-combination-function. 272 `(invalid-method-error , .method. 273 "~@<is applicable, but does not belong ~ 274 to any method group~@:>"))) 275 cond-clauses)) 276 (multiple-value-bind (name tests description order required) 277 (parse-method-group-specifier method-group-specifier) 278 (declare (ignore description)) 279 (let ((specializer-cache (gensym))) 280 (push name names) 281 (push specializer-cache specializer-caches) 282 (push (group-cond-clause name tests specializer-cache 283 (and (eq (cadr method-group-specifier) '*) 284 (= nspecifiers 1))) 285 cond-clauses) 286 (when required 287 (push `(when (null ,name) 288 (return-from .long-method-combination-function. 289 '(error 'long-method-combination-error 290 :format-control "No ~S methods." 291 :format-arguments (list ',name)))) 292 required-checks)) 293 (loop (unless (and (constantp order) 294 (neq order (setq order 295 (constant-form-value order)))) 296 (return t))) 297 (push (cond ((eq order :most-specific-first) 298 `(setq ,name (nreverse ,name))) 299 ((eq order :most-specific-last) ()) 300 (t 301 `(ecase ,order 302 (:most-specific-first 303 (setq ,name (nreverse ,name))) 304 (:most-specific-last)))) 305 order-cleanups)))) 306 `(let (,@(nreverse names) ,@(nreverse specializer-caches)) 307 ,@declarations 308 (dolist (.method. .applicable-methods.) 309 (let ((.qualifiers. (method-qualifiers .method.)) 310 (.specializers. (method-specializers .method.))) 311 (declare (ignorable .qualifiers. .specializers.)) 312 (cond ,@(nreverse cond-clauses)))) 313 ,@(nreverse required-checks) 314 ,@(nreverse order-cleanups) 315 ,@real-body)))) 316 317(defun parse-method-group-specifier (method-group-specifier) 318 ;;(declare (values name tests description order required)) 319 (let* ((name (pop method-group-specifier)) 320 (patterns ()) 321 (tests 322 (let (collect) 323 (block collect-tests 324 (loop 325 (if (or (null method-group-specifier) 326 (memq (car method-group-specifier) 327 '(:description :order :required))) 328 (return-from collect-tests t) 329 (let ((pattern (pop method-group-specifier))) 330 (push pattern patterns) 331 (push (parse-qualifier-pattern name pattern) 332 collect))))) 333 (nreverse collect)))) 334 (values name 335 tests 336 (getf method-group-specifier :description 337 (make-default-method-group-description patterns)) 338 (getf method-group-specifier :order :most-specific-first) 339 (getf method-group-specifier :required nil)))) 340 341(defun parse-qualifier-pattern (name pattern) 342 (cond ((eq pattern '()) `(null .qualifiers.)) 343 ((eq pattern '*) t) 344 ((symbolp pattern) `(,pattern .qualifiers.)) 345 ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) 346 (t (error "In the method group specifier ~S,~%~ 347 ~S isn't a valid qualifier pattern." 348 name pattern)))) 349 350(defun qualifier-check-runtime (pattern qualifiers) 351 (loop (cond ((and (null pattern) (null qualifiers)) 352 (return t)) 353 ((eq pattern '*) (return t)) 354 ((and pattern qualifiers (eq (car pattern) (car qualifiers))) 355 (pop pattern) 356 (pop qualifiers)) 357 (t (return nil))))) 358 359(defun make-default-method-group-description (patterns) 360 (if (cdr patterns) 361 (format nil 362 "methods matching one of the patterns: ~{~S, ~} ~S" 363 (butlast patterns) (car (last patterns))) 364 (format nil 365 "methods matching the pattern: ~S" 366 (car patterns)))) 367 368;;; This baby is a complete mess. I can't believe we put it in this 369;;; way. No doubt this is a large part of what drives MLY crazy. 370;;; 371;;; At runtime (when the effective-method is run), we bind an intercept 372;;; lambda-list to the arguments to the generic function. 373;;; 374;;; At compute-effective-method time, the symbols in the :arguments 375;;; option are bound to the symbols in the intercept lambda list. 376;;; 377;;; FIXME: in here we have not one but two mini-copies of a weird 378;;; hybrid of PARSE-LAMBDA-LIST and (obsolete) PARSE-DEFMACRO-LAMBDA-LIST. 379(defun deal-with-args-option (wrapped-body args-lambda-list) 380 (let ((intercept-rebindings 381 (let (rebindings) 382 (dolist (arg args-lambda-list (nreverse rebindings)) 383 (unless (member arg lambda-list-keywords :test #'eq) 384 (typecase arg 385 (symbol (push `(,arg ',arg) rebindings)) 386 (cons 387 (unless (symbolp (car arg)) 388 (error "invalid lambda-list specifier: ~S." arg)) 389 (push `(,(car arg) ',(car arg)) rebindings)) 390 (t (error "invalid lambda-list-specifier: ~S." arg))))))) 391 (nreq 0) 392 (nopt 0) 393 (whole nil)) 394 ;; Count the number of required and optional parameters in 395 ;; ARGS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the 396 ;; name of a &WHOLE parameter, if any. 397 (when (member '&whole (rest args-lambda-list)) 398 (error 'simple-program-error 399 :format-control "~@<The value of the :ARGUMENTS option of ~ 400 DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may ~ 401 only appear first in the lambda list.~:>" 402 :format-arguments (list args-lambda-list))) 403 (loop with state = 'required 404 for arg in args-lambda-list do 405 (if (memq arg lambda-list-keywords) 406 (setq state arg) 407 (case state 408 (required (incf nreq)) 409 (&optional (incf nopt)) 410 (&whole (setq whole arg state 'required))))) 411 ;; This assumes that the head of WRAPPED-BODY is a let, and it 412 ;; injects let-bindings of the form (ARG 'SYM) for all variables 413 ;; of the argument-lambda-list; SYM is a gensym. 414 (aver (memq (first wrapped-body) '(let let*))) 415 (setf (second wrapped-body) 416 (append intercept-rebindings (second wrapped-body))) 417 ;; Be sure to fill out the args lambda list so that it can be too 418 ;; short if it wants to. 419 (unless (or (memq '&rest args-lambda-list) 420 (memq '&allow-other-keys args-lambda-list)) 421 (let ((aux (memq '&aux args-lambda-list))) 422 (setq args-lambda-list 423 (append (ldiff args-lambda-list aux) 424 (if (memq '&key args-lambda-list) 425 '(&allow-other-keys) 426 '(&rest .ignore.)) 427 aux)))) 428 ;; .GENERIC-FUNCTION. is bound to the generic function in the 429 ;; method combination function, and .GF-ARGS* is bound to the 430 ;; generic function arguments in effective method functions 431 ;; created for generic functions having a method combination that 432 ;; uses :ARGUMENTS. 433 ;; 434 ;; The DESTRUCTURING-BIND binds the parameters of the 435 ;; ARGS-LAMBDA-LIST to actual generic function arguments. Because 436 ;; ARGS-LAMBDA-LIST may be shorter or longer than the generic 437 ;; function's lambda list, which is only known at run time, this 438 ;; destructuring has to be done on a slighly modified list of 439 ;; actual arguments, from which values might be stripped or added. 440 ;; 441 ;; Using one of the variable names in the body inserts a symbol 442 ;; into the effective method, and running the effective method 443 ;; produces the value of actual argument that is bound to the 444 ;; symbol. 445 `(let ((inner-result. ,wrapped-body) 446 (gf-lambda-list (generic-function-lambda-list .generic-function.))) 447 `(destructuring-bind ,',args-lambda-list 448 (frob-combined-method-args 449 .gf-args. ',gf-lambda-list 450 ,',nreq ,',nopt) 451 ,,(when (memq '.ignore. args-lambda-list) 452 ''(declare (ignore .ignore.))) 453 ;; If there is a &WHOLE in the args-lambda-list, let 454 ;; it result in the actual arguments of the generic-function 455 ;; not the frobbed list. 456 ,,(when whole 457 ``(setq ,',whole .gf-args.)) 458 ,inner-result.)))) 459 460;;; Partition VALUES into three sections: required, optional, and the 461;;; rest, according to required, optional, and other parameters in 462;;; LAMBDA-LIST. Make the required and optional sections NREQ and 463;;; NOPT elements long by discarding values or adding NILs. Value is 464;;; the concatenated list of required and optional sections, and what 465;;; is left as rest from VALUES. 466(defun frob-combined-method-args (values lambda-list nreq nopt) 467 (loop with section = 'required 468 for arg in lambda-list 469 if (memq arg lambda-list-keywords) do 470 (setq section arg) 471 (unless (eq section '&optional) 472 (loop-finish)) 473 else if (eq section 'required) 474 count t into nr 475 and collect (pop values) into required 476 else if (eq section '&optional) 477 count t into no 478 and collect (pop values) into optional 479 finally 480 (flet ((frob (list n m) 481 (cond ((> n m) (butlast list (- n m))) 482 ((< n m) (nconc list (make-list (- m n)))) 483 (t list)))) 484 (return (nconc (frob required nr nreq) 485 (frob optional no nopt) 486 values))))) 487