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