src/pcl/defcombin.lisp

   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 \f
  26 (defmacro define-method-combination (&whole form &rest args)
  27   (declare (ignore args))
  28   `(progn
  29      (with-single-package-locked-error
  30          (:symbol ',(second form) "defining ~A as a method combination"))
  31      ,(if (and (cddr form)
  32                (listp (caddr form)))
  33           (expand-long-defcombin form)
  34           (expand-short-defcombin form))))
  35 \f
  36 ;;;; standard method combination
  37
  38 ;;; The STANDARD method combination type is implemented directly by
  39 ;;; the class STANDARD-METHOD-COMBINATION. The method on
  40 ;;; COMPUTE-EFFECTIVE-METHOD does standard method combination directly
  41 ;;; and is defined by hand in the file combin.lisp. The method for
  42 ;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping
  43 ;;; reasons.
  44 (defmethod find-method-combination ((generic-function generic-function)
  45                                     (type (eql 'standard))
  46                                     options)
  47   (when options
  48     (method-combination-error
  49       "The method combination type STANDARD accepts no options."))
  50   *standard-method-combination*)
  51 \f
  52 ;;;; short method combinations
  53 ;;;;
  54 ;;;; Short method combinations all follow the same rule for computing the
  55 ;;;; effective method. So, we just implement that rule once. Each short
  56 ;;;; method combination object just reads the parameters out of the object
  57 ;;;; and runs the same rule.
  58
  59 (defun expand-short-defcombin (whole)
  60   (let* ((type (cadr whole))
  61          (documentation
  62            (getf (cddr whole) :documentation))
  63          (identity-with-one-arg
  64            (getf (cddr whole) :identity-with-one-argument nil))
  65          (operator
  66            (getf (cddr whole) :operator type)))
  67     `(load-short-defcombin
  68      ',type ',operator ',identity-with-one-arg ',documentation
  69       (sb-c:source-location))))
  70
  71 (defun load-short-defcombin (type operator ioa doc source-location)
  72   (let* ((specializers
  73            (list (find-class 'generic-function)
  74                  (intern-eql-specializer type)
  75                  *the-class-t*))
  76          (old-method
  77            (get-method #'find-method-combination () specializers nil))
  78          (new-method nil))
  79     (setq new-method
  80           (make-instance 'standard-method
  81             :qualifiers ()
  82             :specializers specializers
  83             :lambda-list '(generic-function type options)
  84             :function (lambda (args nms &rest cm-args)
  85                         (declare (ignore nms cm-args))
  86                         (apply
  87                          (lambda (gf type options)
  88                            (declare (ignore gf))
  89                            (short-combine-methods
  90                             type options operator ioa new-method doc))
  91                          args))
  92             :definition-source source-location))
  93     (when old-method
  94       (remove-method #'find-method-combination old-method))
  95     (add-method #'find-method-combination new-method)
  96     (setf (random-documentation type 'method-combination) doc)
  97     type))
  98
  99 (defun short-combine-methods (type options operator ioa method doc)
 100   (cond ((null options) (setq options '(:most-specific-first)))
 101         ((equal options '(:most-specific-first)))
 102         ((equal options '(:most-specific-last)))
 103         (t
 104          (method-combination-error
 105           "Illegal options to a short method combination type.~%~
 106            The method combination type ~S accepts one option which~%~
 107            must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
 108           type)))
 109   (make-instance 'short-method-combination
 110                  :type type
 111                  :options options
 112                  :operator operator
 113                  :identity-with-one-argument ioa
 114                  :definition-source method
 115                  :documentation doc))
 116
 117 (defmethod compute-effective-method ((generic-function generic-function)
 118                                      (combin short-method-combination)
 119                                      applicable-methods)
 120   (let ((type (method-combination-type combin))
 121         (operator (short-combination-operator combin))
 122         (ioa (short-combination-identity-with-one-argument combin))
 123         (order (car (method-combination-options combin)))
 124         (around ())
 125         (primary ()))
 126     (flet ((invalid (gf combin m)
 127              (return-from compute-effective-method
 128                `(%invalid-qualifiers ',gf ',combin ',m))))
 129       (dolist (m applicable-methods)
 130         (let ((qualifiers (method-qualifiers m)))
 131           (cond ((null qualifiers) (invalid generic-function combin m))
 132                 ((cdr qualifiers) (invalid generic-function combin m))
 133                 ((eq (car qualifiers) :around)
 134                  (push m around))
 135                 ((eq (car qualifiers) type)
 136                  (push m primary))
 137                 (t (invalid generic-function combin m))))))
 138     (setq around (nreverse around))
 139     (ecase order
 140       (:most-specific-last) ; nothing to be done, already in correct order
 141       (:most-specific-first
 142        (setq primary (nreverse primary))))
 143     (let ((main-method
 144             (if (and (null (cdr primary))
 145                      (not (null ioa)))
 146                 `(call-method ,(car primary) ())
 147                 `(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
 148                                       primary)))))
 149       (cond ((null primary)
 150              ;; As of sbcl-0.8.0.80 we don't seem to need to need
 151              ;; to do anything messy like
 152              ;;        `(APPLY (FUNCTION (IF AROUND
 153              ;;                              'NO-PRIMARY-METHOD
 154              ;;                              'NO-APPLICABLE-METHOD)
 155              ;;                           ',GENERIC-FUNCTION
 156              ;;                           .ARGS.)
 157              ;; here because (for reasons I don't understand at the
 158              ;; moment -- WHN) control will never reach here if there
 159              ;; are no applicable methods, but instead end up
 160              ;; in NO-APPLICABLE-METHODS first.
 161              ;;
 162              ;; FIXME: The way that we arrange for .ARGS. to be bound
 163              ;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION
 164              ;; recognizing any form whose operator is %NO-PRIMARY-METHOD
 165              ;; as magical, and carefully surrounding it with a
 166              ;; LAMBDA form which binds .ARGS. But...
 167              ;;   1. That seems fragile, because the magicalness of
 168              ;;      %NO-PRIMARY-METHOD forms is scattered around
 169              ;;      the system. So it could easily be broken by
 170              ;;      locally-plausible maintenance changes like,
 171              ;;      e.g., using the APPLY expression above.
 172              ;;   2. That seems buggy w.r.t. to MOPpish tricks in
 173              ;;      user code, e.g.
 174              ;;         (DEFMETHOD COMPUTE-EFFECTIVE-METHOD :AROUND (...)
 175              ;;           `(PROGN ,(CALL-NEXT-METHOD) (INCF *MY-CTR*)))
 176              `(%no-primary-method ',generic-function .args.))
 177             ((null around) main-method)
 178             (t
 179              `(call-method ,(car around)
 180                            (,@(cdr around) (make-method ,main-method))))))))
 181
 182 (defmethod invalid-qualifiers ((gf generic-function)
 183                                (combin short-method-combination)
 184                                method)
 185   (let ((qualifiers (method-qualifiers method))
 186         (type (method-combination-type combin)))
 187     (let ((why (cond
 188                  ((null qualifiers) "has no qualifiers")
 189                  ((cdr qualifiers) "has too many qualifiers")
 190                  (t (aver (and (neq (car qualifiers) type)
 191                                (neq (car qualifiers) :around)))
 192                     "has an invalid qualifier"))))
 193       (invalid-method-error
 194        method
 195        "The method ~S on ~S ~A.~%~
 196         The method combination type ~S was defined with the~%~
 197         short form of DEFINE-METHOD-COMBINATION and so requires~%~
 198         all methods have either the single qualifier ~S or the~%~
 199         single qualifier :AROUND."
 200        method gf why type type))))
 201 \f
 202 ;;;; long method combinations
 203
 204 (defun expand-long-defcombin (form)
 205   (let ((type (cadr form))
 206         (lambda-list (caddr form))
 207         (method-group-specifiers (cadddr form))
 208         (body (cddddr form))
 209         (args-option ())
 210         (gf-var nil))
 211     (when (and (consp (car body)) (eq (caar body) :arguments))
 212       (setq args-option (cdr (pop body))))
 213     (when (and (consp (car body)) (eq (caar body) :generic-function))
 214       (setq gf-var (cadr (pop body))))
 215     (multiple-value-bind (documentation function)
 216         (make-long-method-combination-function
 217           type lambda-list method-group-specifiers args-option gf-var
 218           body)
 219       `(load-long-defcombin ',type ',documentation #',function
 220                             ',args-option (sb-c:source-location)))))
 221
 222 (defvar *long-method-combination-functions* (make-hash-table :test 'eq))
 223
 224 (defun load-long-defcombin (type doc function args-lambda-list source-location)
 225   (let* ((specializers
 226            (list (find-class 'generic-function)
 227                  (intern-eql-specializer type)
 228                  *the-class-t*))
 229          (old-method
 230            (get-method #'find-method-combination () specializers nil))
 231          (new-method
 232            (make-instance 'standard-method
 233              :qualifiers ()
 234              :specializers specializers
 235              :lambda-list '(generic-function type options)
 236              :function (lambda (args nms &rest cm-args)
 237                          (declare (ignore nms cm-args))
 238                          (apply
 239                           (lambda (generic-function type options)
 240                             (declare (ignore generic-function))
 241                             (make-instance 'long-method-combination
 242                                            :type type
 243                                            :options options
 244                                            :args-lambda-list args-lambda-list
 245                                            :documentation doc))
 246                           args))
 247              :definition-source source-location)))
 248     (setf (gethash type *long-method-combination-functions*) function)
 249     (when old-method (remove-method #'find-method-combination old-method))
 250     (add-method #'find-method-combination new-method)
 251     (setf (random-documentation type 'method-combination) doc)
 252     type))
 253
 254 (defmethod compute-effective-method ((generic-function generic-function)
 255                                      (combin long-method-combination)
 256                                      applicable-methods)
 257   (funcall (gethash (method-combination-type combin)
 258                     *long-method-combination-functions*)
 259            generic-function
 260            combin
 261            applicable-methods))
 262
 263 (defun make-long-method-combination-function
 264        (type ll method-group-specifiers args-option gf-var body)
 265   (declare (ignore type))
 266   (multiple-value-bind (real-body declarations documentation)
 267       (parse-body body)
 268     (let ((wrapped-body
 269             (wrap-method-group-specifier-bindings method-group-specifiers
 270                                                   declarations
 271                                                   real-body)))
 272       (when gf-var
 273         (push `(,gf-var .generic-function.) (cadr wrapped-body)))
 274
 275       (when args-option
 276         (setq wrapped-body (deal-with-args-option wrapped-body args-option)))
 277
 278       (when ll
 279         (setq wrapped-body
 280               `(apply #'(lambda ,ll ,wrapped-body)
 281                       (method-combination-options .method-combination.))))
 282
 283       (values
 284         documentation
 285         `(lambda (.generic-function. .method-combination. .applicable-methods.)
 286            (declare (ignorable .generic-function.
 287                      .method-combination. .applicable-methods.))
 288            (block .long-method-combination-function. ,wrapped-body))))))
 289
 290 (define-condition long-method-combination-error
 291     (reference-condition simple-error)
 292   ()
 293   (:default-initargs
 294       :references (list '(:ansi-cl :macro define-method-combination))))
 295
 296 ;;; NOTE:
 297 ;;;
 298 ;;; The semantics of long form method combination in the presence of
 299 ;;; multiple methods with the same specializers in the same method
 300 ;;; group are unclear by the spec: a portion of the standard implies
 301 ;;; that an error should be signalled, and another is more lenient.
 302 ;;;
 303 ;;; It is reasonable to allow a single method group of * to bypass all
 304 ;;; rules, as this is explicitly stated in the standard.
 305
 306 (defun group-cond-clause (name tests specializer-cache star-only)
 307   (let ((maybe-error-clause
 308          (if star-only
 309              `(setq ,specializer-cache .specializers.)
 310              `(if (and (equal ,specializer-cache .specializers.)
 311                        (not (null .specializers.)))
 312                   (return-from .long-method-combination-function.
 313                     '(error 'long-method-combination-error
 314                       :format-control "More than one method of type ~S ~
 315                                        with the same specializers."
 316                       :format-arguments (list ',name)))
 317                   (setq ,specializer-cache .specializers.)))))
 318     `((or ,@tests)
 319       ,maybe-error-clause
 320       (push .method. ,name))))
 321
 322 (defun wrap-method-group-specifier-bindings
 323     (method-group-specifiers declarations real-body)
 324   (let (names specializer-caches cond-clauses required-checks order-cleanups)
 325     (let ((nspecifiers (length method-group-specifiers)))
 326       (dolist (method-group-specifier method-group-specifiers)
 327         (multiple-value-bind (name tests description order required)
 328             (parse-method-group-specifier method-group-specifier)
 329           (declare (ignore description))
 330           (let ((specializer-cache (gensym)))
 331             (push name names)
 332             (push specializer-cache specializer-caches)
 333             (push (group-cond-clause name tests specializer-cache
 334                                      (and (eq (cadr method-group-specifier) '*)
 335                                           (= nspecifiers 1)))
 336                   cond-clauses)
 337             (when required
 338               (push `(when (null ,name)
 339                       (return-from .long-method-combination-function.
 340                         '(error 'long-method-combination-error
 341                           :format-control "No ~S methods."
 342                           :format-arguments (list ',name))))
 343                     required-checks))
 344             (loop (unless (and (constantp order)
 345                                (neq order (setq order (eval order))))
 346                     (return t)))
 347             (push (cond ((eq order :most-specific-first)
 348                          `(setq ,name (nreverse ,name)))
 349                         ((eq order :most-specific-last) ())
 350                         (t
 351                          `(ecase ,order
 352                            (:most-specific-first
 353                             (setq ,name (nreverse ,name)))
 354                            (:most-specific-last))))
 355                   order-cleanups))))
 356       `(let (,@(nreverse names) ,@(nreverse specializer-caches))
 357         ,@declarations
 358         (dolist (.method. .applicable-methods.)
 359           (let ((.qualifiers. (method-qualifiers .method.))
 360                 (.specializers. (method-specializers .method.)))
 361             (declare (ignorable .qualifiers. .specializers.))
 362             (cond ,@(nreverse cond-clauses))))
 363         ,@(nreverse required-checks)
 364         ,@(nreverse order-cleanups)
 365         ,@real-body))))
 366
 367 (defun parse-method-group-specifier (method-group-specifier)
 368   ;;(declare (values name tests description order required))
 369   (let* ((name (pop method-group-specifier))
 370          (patterns ())
 371          (tests
 372            (let (collect)
 373              (block collect-tests
 374                (loop
 375                  (if (or (null method-group-specifier)
 376                          (memq (car method-group-specifier)
 377                                '(:description :order :required)))
 378                      (return-from collect-tests t)
 379                      (let ((pattern (pop method-group-specifier)))
 380                        (push pattern patterns)
 381                        (push (parse-qualifier-pattern name pattern)
 382                              collect)))))
 383              (nreverse collect))))
 384     (values name
 385             tests
 386             (getf method-group-specifier :description
 387                   (make-default-method-group-description patterns))
 388             (getf method-group-specifier :order :most-specific-first)
 389             (getf method-group-specifier :required nil))))
 390
 391 (defun parse-qualifier-pattern (name pattern)
 392   (cond ((eq pattern '()) `(null .qualifiers.))
 393         ((eq pattern '*) t)
 394         ((symbolp pattern) `(,pattern .qualifiers.))
 395         ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
 396         (t (error "In the method group specifier ~S,~%~
 397                    ~S isn't a valid qualifier pattern."
 398                   name pattern))))
 399
 400 (defun qualifier-check-runtime (pattern qualifiers)
 401   (loop (cond ((and (null pattern) (null qualifiers))
 402                (return t))
 403               ((eq pattern '*) (return t))
 404               ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
 405                (pop pattern)
 406                (pop qualifiers))
 407               (t (return nil)))))
 408
 409 (defun make-default-method-group-description (patterns)
 410   (if (cdr patterns)
 411       (format nil
 412               "methods matching one of the patterns: ~{~S, ~} ~S"
 413               (butlast patterns) (car (last patterns)))
 414       (format nil
 415               "methods matching the pattern: ~S"
 416               (car patterns))))
 417
 418 ;;; This baby is a complete mess. I can't believe we put it in this
 419 ;;; way. No doubt this is a large part of what drives MLY crazy.
 420 ;;;
 421 ;;; At runtime (when the effective-method is run), we bind an intercept
 422 ;;; lambda-list to the arguments to the generic function.
 423 ;;;
 424 ;;; At compute-effective-method time, the symbols in the :arguments
 425 ;;; option are bound to the symbols in the intercept lambda list.
 426 ;;;
 427 ;;; FIXME: in here we have not one but two mini-copies of a weird
 428 ;;; hybrid of PARSE-LAMBDA-LIST and PARSE-DEFMACRO-LAMBDA-LIST.
 429 (defun deal-with-args-option (wrapped-body args-lambda-list)
 430   (let ((intercept-rebindings
 431          (let (rebindings)
 432            (dolist (arg args-lambda-list (nreverse rebindings))
 433              (unless (member arg lambda-list-keywords)
 434                (typecase arg
 435                  (symbol (push `(,arg ',arg) rebindings))
 436                  (cons
 437                   (unless (symbolp (car arg))
 438                     (error "invalid lambda-list specifier: ~S." arg))
 439                   (push `(,(car arg) ',(car arg)) rebindings))
 440                  (t (error "invalid lambda-list-specifier: ~S." arg)))))))
 441         (nreq 0)
 442         (nopt 0)
 443         (whole nil))
 444     ;; Count the number of required and optional parameters in
 445     ;; ARGS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the
 446     ;; name of a &WHOLE parameter, if any.
 447     (when (member '&whole (rest args-lambda-list))
 448       (error 'simple-program-error
 449              :format-control "~@<The value of the :ARGUMENTS option of ~
 450                 DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may ~
 451                 only appear first in the lambda list.~:>"
 452              :format-arguments (list args-lambda-list)))
 453     (loop with state = 'required
 454           for arg in args-lambda-list do
 455             (if (memq arg lambda-list-keywords)
 456                 (setq state arg)
 457                 (case state
 458                   (required (incf nreq))
 459                   (&optional (incf nopt))
 460                   (&whole (setq whole arg state 'required)))))
 461     ;; This assumes that the head of WRAPPED-BODY is a let, and it
 462     ;; injects let-bindings of the form (ARG 'SYM) for all variables
 463     ;; of the argument-lambda-list; SYM is a gensym.
 464     (aver (memq (first wrapped-body) '(let let*)))
 465     (setf (second wrapped-body)
 466           (append intercept-rebindings (second wrapped-body)))
 467     ;; Be sure to fill out the args lambda list so that it can be too
 468     ;; short if it wants to.
 469     (unless (or (memq '&rest args-lambda-list)
 470                 (memq '&allow-other-keys args-lambda-list))
 471       (let ((aux (memq '&aux args-lambda-list)))
 472         (setq args-lambda-list
 473               (append (ldiff args-lambda-list aux)
 474                       (if (memq '&key args-lambda-list)
 475                           '(&allow-other-keys)
 476                           '(&rest .ignore.))
 477                       aux))))
 478     ;; .GENERIC-FUNCTION. is bound to the generic function in the
 479     ;; method combination function, and .GF-ARGS* is bound to the
 480     ;; generic function arguments in effective method functions
 481     ;; created for generic functions having a method combination that
 482     ;; uses :ARGUMENTS.
 483     ;;
 484     ;; The DESTRUCTURING-BIND binds the parameters of the
 485     ;; ARGS-LAMBDA-LIST to actual generic function arguments.  Because
 486     ;; ARGS-LAMBDA-LIST may be shorter or longer than the generic
 487     ;; function's lambda list, which is only known at run time, this
 488     ;; destructuring has to be done on a slighly modified list of
 489     ;; actual arguments, from which values might be stripped or added.
 490     ;;
 491     ;; Using one of the variable names in the body inserts a symbol
 492     ;; into the effective method, and running the effective method
 493     ;; produces the value of actual argument that is bound to the
 494     ;; symbol.
 495     `(let ((inner-result. ,wrapped-body)
 496            (gf-lambda-list (generic-function-lambda-list .generic-function.)))
 497        `(destructuring-bind ,',args-lambda-list
 498             (frob-combined-method-args
 499              .gf-args. ',gf-lambda-list
 500              ,',nreq ,',nopt)
 501           ,,(when (memq '.ignore. args-lambda-list)
 502               ''(declare (ignore .ignore.)))
 503           ;; If there is a &WHOLE in the args-lambda-list, let
 504           ;; it result in the actual arguments of the generic-function
 505           ;; not the frobbed list.
 506           ,,(when whole
 507               ``(setq ,',whole .gf-args.))
 508           ,inner-result.))))
 509
 510 ;;; Partition VALUES into three sections: required, optional, and the
 511 ;;; rest, according to required, optional, and other parameters in
 512 ;;; LAMBDA-LIST.  Make the required and optional sections NREQ and
 513 ;;; NOPT elements long by discarding values or adding NILs.  Value is
 514 ;;; the concatenated list of required and optional sections, and what
 515 ;;; is left as rest from VALUES.
 516 (defun frob-combined-method-args (values lambda-list nreq nopt)
 517   (loop with section = 'required
 518         for arg in lambda-list
 519         if (memq arg lambda-list-keywords) do
 520           (setq section arg)
 521           (unless (eq section '&optional)
 522             (loop-finish))
 523         else if (eq section 'required)
 524           count t into nr
 525           and collect (pop values) into required
 526         else if (eq section '&optional)
 527           count t into no
 528           and collect (pop values) into optional
 529         finally
 530           (flet ((frob (list n m)
 531                    (cond ((> n m) (butlast list (- n m)))
 532                          ((< n m) (nconc list (make-list (- m n))))
 533                          (t list))))
 534             (return (nconc (frob required nr nreq)
 535                            (frob optional no nopt)
 536                            values)))))
 537