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