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 the class
  36 ;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does
  37 ;;; standard method combination directly and is defined by hand in the file
  38 ;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this
  39 ;;; file for bootstrapping reasons.
  40 ;;;
  41 ;;; A commented out copy of this definition appears in combin.lisp.
  42 ;;; If you change this definition here, be sure to change it there
  43 ;;; also.
  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* ((truename *load-truename*)
  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                                (do-short-method-combination
  99                                 type options operator ioa new-method doc))
 100                            args))
 101             :definition-source `((define-method-combination ,type) ,truename)))
 102     (when old-method
 103       (remove-method #'find-method-combination old-method))
 104     (add-method #'find-method-combination new-method)))
 105
 106 (defun do-short-method-combination (type options operator ioa method doc)
 107   (cond ((null options) (setq options '(:most-specific-first)))
 108         ((equal options '(:most-specific-first)))
 109         ((equal options '(:most-specific-last)))
 110         (t
 111          (method-combination-error
 112            "Illegal options to a short method combination type.~%~
 113             The method combination type ~S accepts one option which~%~
 114             must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
 115            type)))
 116   (make-instance 'short-method-combination
 117                  :type type
 118                  :options options
 119                  :operator operator
 120                  :identity-with-one-argument ioa
 121                  :definition-source method
 122                  :documentation doc))
 123
 124 (defmethod compute-effective-method ((generic-function generic-function)
 125                                      (combin short-method-combination)
 126                                      applicable-methods)
 127   (let ((type (method-combination-type combin))
 128         (operator (short-combination-operator combin))
 129         (ioa (short-combination-identity-with-one-argument combin))
 130         (around ())
 131         (primary ()))
 132     (dolist (m applicable-methods)
 133       (let ((qualifiers (method-qualifiers m)))
 134         (flet ((lose (method why)
 135                  (invalid-method-error
 136                    method
 137                    "The method ~S ~A.~%~
 138                     The method combination type ~S was defined with the~%~
 139                     short form of DEFINE-METHOD-COMBINATION and so requires~%~
 140                     all methods have either the single qualifier ~S or the~%~
 141                     single qualifier :AROUND."
 142                    method why type type)))
 143           (cond ((null qualifiers)
 144                  (lose m "has no qualifiers"))
 145                 ((cdr qualifiers)
 146                  (lose m "has more than one qualifier"))
 147                 ((eq (car qualifiers) :around)
 148                  (push m around))
 149                 ((eq (car qualifiers) type)
 150                  (push m primary))
 151                 (t
 152                  (lose m "has an illegal qualifier"))))))
 153     (setq around (nreverse around)
 154           primary (nreverse primary))
 155     (let ((main-method
 156             (if (and (null (cdr primary))
 157                      (not (null ioa)))
 158                 `(call-method ,(car primary) ())
 159                 `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
 160                                       primary)))))
 161       (cond ((null primary)
 162              `(error "No ~S methods for the generic function ~S."
 163                      ',type ',generic-function))
 164             ((null around) main-method)
 165             (t
 166              `(call-method ,(car around)
 167                            (,@(cdr around) (make-method ,main-method))))))))
 168 \f
 169 ;;;; long method combinations
 170
 171 (defclass long-method-combination (standard-method-combination)
 172      ((function :initarg :function
 173                 :reader long-method-combination-function)))
 174
 175 (defun expand-long-defcombin (form)
 176   (let ((type (cadr form))
 177         (lambda-list (caddr form))
 178         (method-group-specifiers (cadddr form))
 179         (body (cddddr form))
 180         (arguments-option ())
 181         (gf-var nil))
 182     (when (and (consp (car body)) (eq (caar body) :arguments))
 183       (setq arguments-option (cdr (pop body))))
 184     (when (and (consp (car body)) (eq (caar body) :generic-function))
 185       (setq gf-var (cadr (pop body))))
 186     (multiple-value-bind (documentation function)
 187         (make-long-method-combination-function
 188           type lambda-list method-group-specifiers arguments-option gf-var
 189           body)
 190       `(load-long-defcombin ',type ',documentation #',function))))
 191
 192 (defvar *long-method-combination-functions* (make-hash-table :test 'eq))
 193
 194 (defun load-long-defcombin (type doc function)
 195   (let* ((specializers
 196            (list (find-class 'generic-function)
 197                  (intern-eql-specializer type)
 198                  *the-class-t*))
 199          (old-method
 200            (get-method #'find-method-combination () specializers nil))
 201          (new-method
 202            (make-instance 'standard-method
 203              :qualifiers ()
 204              :specializers specializers
 205              :lambda-list '(generic-function type options)
 206              :function #'(lambda (args nms &rest cm-args)
 207                            (declare (ignore nms cm-args))
 208                            (apply
 209                             #'(lambda (generic-function type options)
 210                                 (declare (ignore generic-function options))
 211                                 (make-instance 'long-method-combination
 212                                                :type type
 213                                                :documentation doc))
 214                             args))
 215          :definition-source `((define-method-combination ,type)
 216                               ,*load-truename*))))
 217     (setf (gethash type *long-method-combination-functions*) function)
 218     (when old-method (remove-method #'find-method-combination old-method))
 219     (add-method #'find-method-combination new-method)))
 220
 221 (defmethod compute-effective-method ((generic-function generic-function)
 222                                      (combin long-method-combination)
 223                                      applicable-methods)
 224   (funcall (gethash (method-combination-type combin)
 225                     *long-method-combination-functions*)
 226            generic-function
 227            combin
 228            applicable-methods))
 229
 230 (defun make-long-method-combination-function
 231        (type ll method-group-specifiers arguments-option gf-var body)
 232   ;;(declare (values documentation function))
 233   (declare (ignore type))
 234   (multiple-value-bind (documentation declarations real-body)
 235       (extract-declarations body)
 236
 237     (let ((wrapped-body
 238             (wrap-method-group-specifier-bindings method-group-specifiers
 239                                                   declarations
 240                                                   real-body)))
 241       (when gf-var
 242         (push `(,gf-var .generic-function.) (cadr wrapped-body)))
 243
 244       (when arguments-option
 245         (setq wrapped-body (deal-with-arguments-option wrapped-body
 246                                                        arguments-option)))
 247
 248       (when ll
 249         (setq wrapped-body
 250               `(apply #'(lambda ,ll ,wrapped-body)
 251                       (method-combination-options .method-combination.))))
 252
 253       (values
 254         documentation
 255         `(lambda (.generic-function. .method-combination. .applicable-methods.)
 256            (progn .generic-function. .method-combination. .applicable-methods.)
 257            (block .long-method-combination-function. ,wrapped-body))))))
 258
 259 ;; parse-method-group-specifiers parse the method-group-specifiers
 260
 261 (defun wrap-method-group-specifier-bindings
 262        (method-group-specifiers declarations real-body)
 263   (with-gathering ((names (collecting))
 264                    (specializer-caches (collecting))
 265                    (cond-clauses (collecting))
 266                    (required-checks (collecting))
 267                    (order-cleanups (collecting)))
 268       (dolist (method-group-specifier method-group-specifiers)
 269         (multiple-value-bind (name tests description order required)
 270             (parse-method-group-specifier method-group-specifier)
 271           (declare (ignore description))
 272           (let ((specializer-cache (gensym)))
 273             (gather name names)
 274             (gather specializer-cache specializer-caches)
 275             (gather `((or ,@tests)
 276                       (if  (equal ,specializer-cache .specializers.)
 277                            (return-from .long-method-combination-function.
 278                              '(error "More than one method of type ~S ~
 279                                       with the same specializers."
 280                                      ',name))
 281                            (setq ,specializer-cache .specializers.))
 282                       (push .method. ,name))
 283                     cond-clauses)
 284             (when required
 285               (gather `(when (null ,name)
 286                          (return-from .long-method-combination-function.
 287                            '(error "No ~S methods." ',name)))
 288                       required-checks))
 289             (loop (unless (and (constantp order)
 290                                (neq order (setq order (eval order))))
 291                     (return t)))
 292             (gather (cond ((eq order :most-specific-first)
 293                            `(setq ,name (nreverse ,name)))
 294                           ((eq order :most-specific-last) ())
 295                           (t
 296                            `(ecase ,order
 297                               (:most-specific-first
 298                                 (setq ,name (nreverse ,name)))
 299                               (:most-specific-last))))
 300                     order-cleanups))))
 301    `(let (,@names ,@specializer-caches)
 302       ,@declarations
 303       (dolist (.method. .applicable-methods.)
 304         (let ((.qualifiers. (method-qualifiers .method.))
 305               (.specializers. (method-specializers .method.)))
 306           (progn .qualifiers. .specializers.)
 307           (cond ,@cond-clauses)))
 308       ,@required-checks
 309       ,@order-cleanups
 310       ,@real-body)))
 311
 312 (defun parse-method-group-specifier (method-group-specifier)
 313   ;;(declare (values name tests description order required))
 314   (let* ((name (pop method-group-specifier))
 315          (patterns ())
 316          (tests
 317            (gathering1 (collecting)
 318              (block collect-tests
 319                (loop
 320                  (if (or (null method-group-specifier)
 321                          (memq (car method-group-specifier)
 322                                '(:description :order :required)))
 323                      (return-from collect-tests t)
 324                      (let ((pattern (pop method-group-specifier)))
 325                        (push pattern patterns)
 326                        (gather1 (parse-qualifier-pattern name pattern)))))))))
 327     (values name
 328             tests
 329             (getf method-group-specifier :description
 330                   (make-default-method-group-description patterns))
 331             (getf method-group-specifier :order :most-specific-first)
 332             (getf method-group-specifier :required nil))))
 333
 334 (defun parse-qualifier-pattern (name pattern)
 335   (cond ((eq pattern '()) `(null .qualifiers.))
 336         ((eq pattern '*) t)
 337         ((symbolp pattern) `(,pattern .qualifiers.))
 338         ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
 339         (t (error "In the method group specifier ~S,~%~
 340                    ~S isn't a valid qualifier pattern."
 341                   name pattern))))
 342
 343 (defun qualifier-check-runtime (pattern qualifiers)
 344   (loop (cond ((and (null pattern) (null qualifiers))
 345                (return t))
 346               ((eq pattern '*) (return t))
 347               ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
 348                (pop pattern)
 349                (pop qualifiers))
 350               (t (return nil)))))
 351
 352 (defun make-default-method-group-description (patterns)
 353   (if (cdr patterns)
 354       (format nil
 355               "methods matching one of the patterns: ~{~S, ~} ~S"
 356               (butlast patterns) (car (last patterns)))
 357       (format nil
 358               "methods matching the pattern: ~S"
 359               (car patterns))))
 360
 361 ;;; This baby is a complete mess. I can't believe we put it in this
 362 ;;; way. No doubt this is a large part of what drives MLY crazy.
 363 ;;;
 364 ;;; At runtime (when the effective-method is run), we bind an intercept
 365 ;;; lambda-list to the arguments to the generic function.
 366 ;;;
 367 ;;; At compute-effective-method time, the symbols in the :arguments
 368 ;;; option are bound to the symbols in the intercept lambda list.
 369 (defun deal-with-arguments-option (wrapped-body arguments-option)
 370   (let* ((intercept-lambda-list
 371            (gathering1 (collecting)
 372              (dolist (arg arguments-option)
 373                (if (memq arg lambda-list-keywords)
 374                    (gather1 arg)
 375                    (gather1 (gensym))))))
 376          (intercept-rebindings
 377            (gathering1 (collecting)
 378              (iterate ((arg (list-elements arguments-option))
 379                        (int (list-elements intercept-lambda-list)))
 380                (unless (memq arg lambda-list-keywords)
 381                  (gather1 `(,arg ',int)))))))
 382
 383     (setf (cadr wrapped-body)
 384           (append intercept-rebindings (cadr wrapped-body)))
 385
 386     ;; Be sure to fill out the intercept lambda list so that it can
 387     ;; be too short if it wants to.
 388     (cond ((memq '&rest intercept-lambda-list))
 389           ((memq '&allow-other-keys intercept-lambda-list))
 390           ((memq '&key intercept-lambda-list)
 391            (setq intercept-lambda-list
 392                  (append intercept-lambda-list '(&allow-other-keys))))
 393           (t
 394            (setq intercept-lambda-list
 395                  (append intercept-lambda-list '(&rest .ignore.)))))
 396
 397     `(let ((inner-result. ,wrapped-body))
 398        `(apply #'(lambda ,',intercept-lambda-list
 399                    ,,(when (memq '.ignore. intercept-lambda-list)
 400                        ''(declare (ignore .ignore.)))
 401                    ,inner-result.)
 402                .combined-method-args.))))