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