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