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