src/pcl/combin.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 (defun get-method-function (method &optional method-alist wrappers)
  27   (let ((fn (cadr (assoc method method-alist))))
  28     (if fn
  29         (values fn nil nil nil)
  30         (multiple-value-bind (mf fmf)
  31             (if (listp method)
  32                 (early-method-function method)
  33                 (values nil (method-fast-function method)))
  34           (let* ((pv-table (and fmf (method-function-pv-table fmf))))
  35             (if (and fmf (or (null pv-table) wrappers))
  36                 (let* ((pv-wrappers (when pv-table
  37                                       (pv-wrappers-from-all-wrappers
  38                                        pv-table wrappers)))
  39                        (pv-cell (when (and pv-table pv-wrappers)
  40                                   (pv-table-lookup pv-table pv-wrappers))))
  41                   (values mf t fmf pv-cell))
  42                 (values
  43                  (or mf (if (listp method)
  44                             (setf (cadr method)
  45                                   (method-function-from-fast-function fmf))
  46                             (method-function method)))
  47                  t nil nil)))))))
  48
  49 (defun make-effective-method-function (generic-function form &optional
  50                                        method-alist wrappers)
  51   (funcall (make-effective-method-function1 generic-function form
  52                                             (not (null method-alist))
  53                                             (not (null wrappers)))
  54            method-alist wrappers))
  55
  56 (defun make-effective-method-function1 (generic-function form
  57                                         method-alist-p wrappers-p)
  58   (if (and (listp form)
  59            (eq (car form) 'call-method))
  60       (make-effective-method-function-simple generic-function form)
  61       ;; We have some sort of `real' effective method. Go off and get a
  62       ;; compiled function for it. Most of the real hair here is done by
  63       ;; the GET-FUNCTION mechanism.
  64       (make-effective-method-function-internal generic-function form
  65                                                method-alist-p wrappers-p)))
  66
  67 (defun make-effective-method-function-type (generic-function form
  68                                             method-alist-p wrappers-p)
  69   (if (and (listp form)
  70            (eq (car form) 'call-method))
  71       (let* ((cm-args (cdr form))
  72              (method (car cm-args)))
  73         (when method
  74           (if (if (listp method)
  75                   (eq (car method) ':early-method)
  76                   (method-p method))
  77               (if method-alist-p
  78                   t
  79                   (multiple-value-bind (mf fmf)
  80                       (if (listp method)
  81                           (early-method-function method)
  82                           (values nil (method-fast-function method)))
  83                     (declare (ignore mf))
  84                     (let* ((pv-table (and fmf (method-function-pv-table fmf))))
  85                       (if (and fmf (or (null pv-table) wrappers-p))
  86                           'fast-method-call
  87                           'method-call))))
  88               (if (and (consp method) (eq (car method) 'make-method))
  89                   (make-effective-method-function-type
  90                    generic-function (cadr method) method-alist-p wrappers-p)
  91                   (type-of method)))))
  92       'fast-method-call))
  93
  94 (defun make-effective-method-function-simple
  95     (generic-function form &optional no-fmf-p)
  96   ;; The effective method is just a call to call-method. This opens up
  97   ;; the possibility of just using the method function of the method as
  98   ;; the effective method function.
  99   ;;
 100   ;; But we have to be careful. If that method function will ask for
 101   ;; the next methods we have to provide them. We do not look to see
 102   ;; if there are next methods, we look at whether the method function
 103   ;; asks about them. If it does, we must tell it whether there are
 104   ;; or aren't to prevent the leaky next methods bug.
 105   (let* ((cm-args (cdr form))
 106          (fmf-p (and (null no-fmf-p)
 107                      (or (not (eq *boot-state* 'complete))
 108                          (gf-fast-method-function-p generic-function))
 109                      (null (cddr cm-args))))
 110          (method (car cm-args))
 111          (cm-args1 (cdr cm-args)))
 112     #'(lambda (method-alist wrappers)
 113         (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
 114                                                 method-alist wrappers))))
 115
 116 (defun make-emf-from-method
 117     (method cm-args &optional gf fmf-p method-alist wrappers)
 118   (multiple-value-bind (mf real-mf-p fmf pv-cell)
 119       (get-method-function method method-alist wrappers)
 120     (if fmf
 121         (let* ((next-methods (car cm-args))
 122                (next (make-effective-method-function-simple1
 123                       gf (car next-methods)
 124                       (list* (cdr next-methods) (cdr cm-args))
 125                       fmf-p method-alist wrappers))
 126                (arg-info (method-function-get fmf ':arg-info)))
 127           (make-fast-method-call :function fmf
 128                                  :pv-cell pv-cell
 129                                  :next-method-call next
 130                                  :arg-info arg-info))
 131         (if real-mf-p
 132             (make-method-call :function mf
 133                               :call-method-args cm-args)
 134             mf))))
 135
 136 (defun make-effective-method-function-simple1
 137     (gf method cm-args fmf-p &optional method-alist wrappers)
 138   (when method
 139     (if (if (listp method)
 140             (eq (car method) ':early-method)
 141             (method-p method))
 142         (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
 143         (if (and (consp method) (eq (car method) 'make-method))
 144             (make-effective-method-function gf
 145                                             (cadr method)
 146                                             method-alist wrappers)
 147             method))))
 148
 149 (defvar *global-effective-method-gensyms* ())
 150 (defvar *rebound-effective-method-gensyms*)
 151
 152 (defun get-effective-method-gensym ()
 153   (or (pop *rebound-effective-method-gensyms*)
 154       (let ((new (intern (format nil
 155                                  "EFFECTIVE-METHOD-GENSYM-~D"
 156                                  (length *global-effective-method-gensyms*))
 157                          *pcl-package*)))
 158         (setq *global-effective-method-gensyms*
 159               (append *global-effective-method-gensyms* (list new)))
 160         new)))
 161
 162 (let ((*rebound-effective-method-gensyms* ()))
 163   (dotimes-fixnum (i 10) (get-effective-method-gensym)))
 164
 165 (defun expand-effective-method-function (gf effective-method &optional env)
 166   (declare (ignore env))
 167   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
 168       (get-generic-function-info gf)
 169     (declare (ignore nreq nkeys arg-info))
 170     (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
 171           ;; When there are no primary methods and a next-method call occurs
 172           ;; effective-method is (error "No mumble..") and the defined
 173           ;; args are not used giving a compiler warning.
 174           (error-p (eq (first effective-method) 'error)))
 175       `(lambda ,ll
 176          (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
 177          ,effective-method))))
 178
 179 (defun expand-emf-call-method (gf form metatypes applyp env)
 180   (declare (ignore gf metatypes applyp env))
 181   `(call-method ,(cdr form)))
 182
 183 (defmacro call-method (&rest args)
 184   (declare (ignore args))
 185   `(error "~S outside of a effective method form" 'call-method))
 186
 187 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
 188   (cond ((and (consp form) (eq (car form) 'call-method))
 189          (case (make-effective-method-function-type
 190                 generic-function form method-alist-p wrappers-p)
 191            (fast-method-call
 192             '.fast-call-method.)
 193            (t
 194             '.call-method.)))
 195         ((and (consp form) (eq (car form) 'call-method-list))
 196          (case (if (every #'(lambda (form)
 197                               (eq 'fast-method-call
 198                                   (make-effective-method-function-type
 199                                    generic-function form
 200                                    method-alist-p wrappers-p)))
 201                           (cdr form))
 202                    'fast-method-call
 203                    t)
 204            (fast-method-call
 205             '.fast-call-method-list.)
 206            (t
 207             '.call-method-list.)))
 208         (t
 209          (default-test-converter form))))
 210
 211 (defun memf-code-converter
 212     (form generic-function metatypes applyp method-alist-p wrappers-p)
 213   (cond ((and (consp form) (eq (car form) 'call-method))
 214          (let ((gensym (get-effective-method-gensym)))
 215            (values (make-emf-call metatypes applyp gensym
 216                                   (make-effective-method-function-type
 217                                    generic-function form method-alist-p wrappers-p))
 218                    (list gensym))))
 219         ((and (consp form) (eq (car form) 'call-method-list))
 220          (let ((gensym (get-effective-method-gensym))
 221                (type (if (every #'(lambda (form)
 222                                     (eq 'fast-method-call
 223                                         (make-effective-method-function-type
 224                                          generic-function form
 225                                          method-alist-p wrappers-p)))
 226                                 (cdr form))
 227                          'fast-method-call
 228                          t)))
 229            (values `(dolist (emf ,gensym nil)
 230                       ,(make-emf-call metatypes applyp 'emf type))
 231                    (list gensym))))
 232         (t
 233          (default-code-converter form))))
 234
 235 (defun memf-constant-converter (form generic-function)
 236   (cond ((and (consp form) (eq (car form) 'call-method))
 237          (list (cons '.meth.
 238                      (make-effective-method-function-simple
 239                       generic-function form))))
 240         ((and (consp form) (eq (car form) 'call-method-list))
 241          (list (cons '.meth-list.
 242                      (mapcar #'(lambda (form)
 243                                  (make-effective-method-function-simple
 244                                   generic-function form))
 245                              (cdr form)))))
 246         (t
 247          (default-constant-converter form))))
 248
 249 (defun make-effective-method-function-internal
 250     (generic-function effective-method method-alist-p wrappers-p)
 251   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
 252       (get-generic-function-info generic-function)
 253     (declare (ignore nkeys arg-info))
 254     (let* ((*rebound-effective-method-gensyms*
 255             *global-effective-method-gensyms*)
 256            (name (if (early-gf-p generic-function)
 257                      (!early-gf-name generic-function)
 258                      (generic-function-name generic-function)))
 259            (arg-info (cons nreq applyp))
 260            (effective-method-lambda (expand-effective-method-function
 261                                      generic-function effective-method)))
 262       (multiple-value-bind (cfunction constants)
 263           (get-function1 effective-method-lambda
 264                          #'(lambda (form)
 265                              (memf-test-converter form generic-function
 266                                                   method-alist-p wrappers-p))
 267                          #'(lambda (form)
 268                              (memf-code-converter form generic-function
 269                                                   metatypes applyp
 270                                                   method-alist-p wrappers-p))
 271                          #'(lambda (form)
 272                              (memf-constant-converter form generic-function)))
 273         #'(lambda (method-alist wrappers)
 274             (let* ((constants
 275                     (mapcar #'(lambda (constant)
 276                                 (if (consp constant)
 277                                     (case (car constant)
 278                                       (.meth.
 279                                        (funcall (cdr constant)
 280                                                 method-alist wrappers))
 281                                       (.meth-list.
 282                                        (mapcar #'(lambda (fn)
 283                                                    (funcall fn
 284                                                             method-alist
 285                                                             wrappers))
 286                                                (cdr constant)))
 287                                       (t constant))
 288                                     constant))
 289                             constants))
 290                    (function (set-function-name
 291                               (apply cfunction constants)
 292                               `(combined-method ,name))))
 293               (make-fast-method-call :function function
 294                                      :arg-info arg-info)))))))
 295
 296 (defmacro call-method-list (&rest calls)
 297   `(progn ,@calls))
 298
 299 (defun make-call-methods (methods)
 300   `(call-method-list
 301     ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
 302
 303 (defun standard-compute-effective-method (generic-function combin applicable-methods)
 304   (declare (ignore combin))
 305   (let ((before ())
 306         (primary ())
 307         (after ())
 308         (around ()))
 309     (flet ((lose (method why)
 310              (invalid-method-error
 311               method
 312               "The method ~S ~A.~%~
 313                Standard method combination requires all methods to have one~%~
 314                of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
 315                have no qualifier at all."
 316               method why)))
 317       (dolist (m applicable-methods)
 318         (let ((qualifiers (if (listp m)
 319                             (early-method-qualifiers m)
 320                             (method-qualifiers m))))
 321           (cond
 322             ((null qualifiers) (push m primary))
 323             ((cdr qualifiers)
 324               (lose m "has more than one qualifier"))
 325             ((eq (car qualifiers) :around)
 326               (push m around))
 327             ((eq (car qualifiers) :before)
 328               (push m before))
 329             ((eq (car qualifiers) :after)
 330               (push m after))
 331             (t
 332               (lose m "has an illegal qualifier"))))))
 333     (setq before  (reverse before)
 334           after   (reverse after)
 335           primary (reverse primary)
 336           around  (reverse around))
 337     (cond ((null primary)
 338            `(error "There is no primary method for the generic function ~S."
 339                    ',generic-function))
 340           ((and (null before) (null after) (null around))
 341            ;; By returning a single call-method `form' here we enable an
 342            ;; important implementation-specific optimization.
 343            `(call-method ,(first primary) ,(rest primary)))
 344           (t
 345            (let ((main-effective-method
 346                    (if (or before after)
 347                        `(multiple-value-prog1
 348                           (progn ,(make-call-methods before)
 349                                  (call-method ,(first primary)
 350                                               ,(rest primary)))
 351                           ,(make-call-methods (reverse after)))
 352                        `(call-method ,(first primary) ,(rest primary)))))
 353              (if around
 354                  `(call-method ,(first around)
 355                                (,@(rest around)
 356                                   (make-method ,main-effective-method)))
 357                  main-effective-method))))))
 358 \f
 359 ;;;; the STANDARD method combination type. This is coded by hand
 360 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
 361 ;;;; and efficiency reasons. Note that the definition of the
 362 ;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
 363 ;;;; defcombin.lisp. This is because EQL methods can't appear in the
 364 ;;;; bootstrap.
 365 ;;;;
 366 ;;;; The DEFCLASS for the METHOD-COMBINATION and
 367 ;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this
 368 ;;;; reason. This code must conform to the code in the file
 369 ;;;; defcombin.lisp, look there for more details.
 370
 371 (defun compute-effective-method (generic-function combin applicable-methods)
 372   (standard-compute-effective-method generic-function
 373                                      combin
 374                                      applicable-methods))
 375
 376 (defun invalid-method-error (method format-control &rest format-arguments)
 377   (error "~@<invalid method error for ~2I_~S ~I~_method: ~2I~_~?~:>"
 378          method
 379          format-control
 380          format-arguments))
 381
 382 (defun method-combination-error (format-control &rest format-arguments)
 383   (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
 384          format-control
 385          format-arguments))