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 (safe-method-fast-function method)))
  34           (let* ((pv-table (and fmf (method-plist-value method :pv-table))))
  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                             (bug "early method with no method-function")
  45                             (method-function method)))
  46                  t nil nil)))))))
  47
  48 (defun make-effective-method-function (generic-function form &optional
  49                                        method-alist wrappers)
  50   (funcall (make-effective-method-function1 generic-function form
  51                                             (not (null method-alist))
  52                                             (not (null wrappers)))
  53            method-alist wrappers))
  54
  55 (defun make-effective-method-function1 (generic-function form
  56                                         method-alist-p wrappers-p)
  57   (if (and (listp form)
  58            (eq (car form) 'call-method))
  59       (make-effective-method-function-simple generic-function form)
  60       ;; We have some sort of `real' effective method. Go off and get a
  61       ;; compiled function for it. Most of the real hair here is done by
  62       ;; the GET-FUN mechanism.
  63       (make-effective-method-function-internal generic-function form
  64                                                method-alist-p wrappers-p)))
  65
  66 (defun make-effective-method-fun-type (generic-function
  67                                        form
  68                                        method-alist-p
  69                                        wrappers-p)
  70   (if (and (listp form)
  71            (eq (car form) 'call-method))
  72       (let* ((cm-args (cdr form))
  73              (method (car cm-args)))
  74         (when method
  75           (if (if (listp method)
  76                   (eq (car method) :early-method)
  77                   (method-p method))
  78               (if method-alist-p
  79                   t
  80                   (multiple-value-bind (mf fmf)
  81                       (if (listp method)
  82                           (early-method-function method)
  83                           (values nil (safe-method-fast-function method)))
  84                     (declare (ignore mf))
  85                     (let* ((pv-table (and fmf (method-plist-value method :pv-table))))
  86                       (if (and fmf (or (null pv-table) wrappers-p))
  87                           'fast-method-call
  88                           'method-call))))
  89               (if (and (consp method) (eq (car method) 'make-method))
  90                   (make-effective-method-fun-type
  91                    generic-function (cadr method) method-alist-p wrappers-p)
  92                   (type-of method)))))
  93       'fast-method-call))
  94
  95 (defun make-effective-method-function-simple
  96     (generic-function form &optional no-fmf-p)
  97   ;; The effective method is just a call to CALL-METHOD. This opens up
  98   ;; the possibility of just using the method function of the method as
  99   ;; the effective method function.
 100   ;;
 101   ;; But we have to be careful. If that method function will ask for
 102   ;; the next methods we have to provide them. We do not look to see
 103   ;; if there are next methods, we look at whether the method function
 104   ;; asks about them. If it does, we must tell it whether there are
 105   ;; or aren't to prevent the leaky next methods bug.
 106   (let* ((cm-args (cdr form))
 107          (fmf-p (and (null no-fmf-p)
 108                      (or (not (eq *boot-state* 'complete))
 109                          (gf-fast-method-function-p generic-function))
 110                      (null (cddr cm-args))))
 111          (method (car cm-args))
 112          (cm-args1 (cdr cm-args)))
 113     (lambda (method-alist wrappers)
 114       (make-effective-method-function-simple1 generic-function
 115                                               method
 116                                               cm-args1
 117                                               fmf-p
 118                                               method-alist
 119                                               wrappers))))
 120
 121 (defun make-emf-from-method
 122     (method cm-args &optional gf fmf-p method-alist wrappers)
 123   (multiple-value-bind (mf real-mf-p fmf pv-cell)
 124       (get-method-function method method-alist wrappers)
 125     (if fmf
 126         (let* ((next-methods (car cm-args))
 127                (next (make-effective-method-function-simple1
 128                       gf (car next-methods)
 129                       (list* (cdr next-methods) (cdr cm-args))
 130                       fmf-p method-alist wrappers))
 131                (arg-info (method-plist-value method :arg-info))
 132                (default (cons nil nil))
 133                (value (method-plist-value method :constant-value default)))
 134           (if (eq value default)
 135               (make-fast-method-call :function fmf :pv-cell pv-cell
 136                                      :next-method-call next :arg-info arg-info)
 137               (make-constant-fast-method-call
 138                :function fmf :pv-cell pv-cell :next-method-call next
 139                :arg-info arg-info :value value)))
 140         (if real-mf-p
 141             (flet ((frob-cm-arg (arg)
 142                      (if (if (listp arg)
 143                              (eq (car arg) :early-method)
 144                              (method-p arg))
 145                          arg
 146                          (if (and (consp arg) (eq (car arg) 'make-method))
 147                              (let ((emf (make-effective-method-function
 148                                          gf (cadr arg) method-alist wrappers)))
 149                                (etypecase emf
 150                                  (method-call
 151                                   (make-instance 'standard-method
 152                                                  :specializers nil ; XXX
 153                                                  :qualifiers nil ; XXX
 154                                                  :function (method-call-function emf)))
 155                                  (fast-method-call
 156                                   (let* ((fmf (fast-method-call-function emf))
 157                                          (fun (method-function-from-fast-method-call emf))
 158                                          (mf (%make-method-function fmf nil)))
 159                                     (set-funcallable-instance-function mf fun)
 160                                     (make-instance 'standard-method
 161                                                    :specializers nil ; XXX
 162                                                    :qualifiers nil
 163                                                    :function mf)))))
 164                              arg))))
 165               (let* ((default (cons nil nil))
 166                      (value
 167                       (method-plist-value method :constant-value default))
 168                      ;; FIXME: this is wrong.  Very wrong.  It assumes
 169                      ;; that the only place that can have make-method
 170                      ;; calls is in the list structure of the second
 171                      ;; argument to CALL-METHOD, but AMOP says that
 172                      ;; CALL-METHOD can be more complicated if
 173                      ;; COMPUTE-EFFECTIVE-METHOD (and presumably
 174                      ;; MAKE-METHOD-LAMBDA) is adjusted to match.
 175                      ;;
 176                      ;; On the other hand, it's a start, because
 177                      ;; without this calls to MAKE-METHOD in method
 178                      ;; combination where one of the methods is of a
 179                      ;; user-defined class don't work at all.  -- CSR,
 180                      ;; 2006-08-05
 181                      (args (cons (mapcar #'frob-cm-arg (car cm-args))
 182                                  (cdr cm-args))))
 183                 (if (eq value default)
 184                     (make-method-call :function mf :call-method-args args)
 185                     (make-constant-method-call :function mf :value value
 186                                                :call-method-args args))))
 187             mf))))
 188
 189 (defun make-effective-method-function-simple1
 190     (gf method cm-args fmf-p &optional method-alist wrappers)
 191   (when method
 192     (if (if (listp method)
 193             (eq (car method) :early-method)
 194             (method-p method))
 195         (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
 196         (if (and (consp method) (eq (car method) 'make-method))
 197             (make-effective-method-function gf
 198                                             (cadr method)
 199                                             method-alist wrappers)
 200             method))))
 201
 202 (defvar *global-effective-method-gensyms* ())
 203 (defvar *rebound-effective-method-gensyms*)
 204
 205 (defun get-effective-method-gensym ()
 206   (or (pop *rebound-effective-method-gensyms*)
 207       (let ((new (format-symbol *pcl-package*
 208                                 "EFFECTIVE-METHOD-GENSYM-~D"
 209                                 (length *global-effective-method-gensyms*))))
 210         (setq *global-effective-method-gensyms*
 211               (append *global-effective-method-gensyms* (list new)))
 212         new)))
 213
 214 (let ((*rebound-effective-method-gensyms* ()))
 215   (dotimes-fixnum (i 10) (get-effective-method-gensym)))
 216
 217 (defun expand-effective-method-function (gf effective-method &optional env)
 218   (declare (ignore env))
 219   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
 220       (get-generic-fun-info gf)
 221     (declare (ignore nreq nkeys arg-info))
 222     (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
 223           (check-applicable-keywords
 224            (when (and applyp (gf-requires-emf-keyword-checks gf))
 225              '((check-applicable-keywords))))
 226           (error-p (or (eq (first effective-method) '%no-primary-method)
 227                        (eq (first effective-method) '%invalid-qualifiers)))
 228           (mc-args-p
 229            (when (eq *boot-state* 'complete)
 230              ;; Otherwise the METHOD-COMBINATION slot is not bound.
 231              (let ((combin (generic-function-method-combination gf)))
 232                (and (long-method-combination-p combin)
 233                     (long-method-combination-args-lambda-list combin))))))
 234       (cond
 235         (error-p
 236          `(lambda (.pv-cell. .next-method-call. &rest .args.)
 237            (declare (ignore .pv-cell. .next-method-call.))
 238            (declare (ignorable .args.))
 239            (flet ((%no-primary-method (gf args)
 240                     (apply #'no-primary-method gf args))
 241                   (%invalid-qualifiers (gf combin method)
 242                     (invalid-qualifiers gf combin method)))
 243              (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
 244              ,effective-method)))
 245         (mc-args-p
 246          (let* ((required
 247                  ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp
 248                  (let (req)
 249                    (dotimes (i (length metatypes) (nreverse req))
 250                      (push (dfun-arg-symbol i) req))))
 251                 (gf-args (if applyp
 252                              `(list* ,@required
 253                                      (sb-c::%listify-rest-args
 254                                       .dfun-more-context.
 255                                       (the (and (unsigned-byte fixnum))
 256                                         .dfun-more-count.)))
 257                              `(list ,@required))))
 258            `(lambda ,ll
 259              (declare (ignore .pv-cell. .next-method-call.))
 260              (let ((.gf-args. ,gf-args))
 261                (declare (ignorable .gf-args.))
 262                ,@check-applicable-keywords
 263                ,effective-method))))
 264         (t
 265          `(lambda ,ll
 266            (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
 267            ,@check-applicable-keywords
 268            ,effective-method))))))
 269
 270 (defun expand-emf-call-method (gf form metatypes applyp env)
 271   (declare (ignore gf metatypes applyp env))
 272   `(call-method ,(cdr form)))
 273
 274 (defmacro call-method (&rest args)
 275   (declare (ignore args))
 276   ;; the PROGN is here to defend against premature macroexpansion by
 277   ;; RESTART-CASE.
 278   `(progn (error "~S outside of a effective method form" 'call-method)))
 279
 280 (defun make-effective-method-list-fun-type
 281     (generic-function form method-alist-p wrappers-p)
 282   (if (every (lambda (form)
 283                (eq 'fast-method-call
 284                    (make-effective-method-fun-type
 285                     generic-function form method-alist-p wrappers-p)))
 286              (cdr form))
 287       'fast-method-call
 288       t))
 289
 290 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
 291   (case (and (consp form) (car form))
 292     (call-method
 293      (case (make-effective-method-fun-type
 294             generic-function form method-alist-p wrappers-p)
 295        (fast-method-call '.fast-call-method.)
 296        (t '.call-method.)))
 297     (call-method-list
 298      (case (make-effective-method-list-fun-type
 299             generic-function form method-alist-p wrappers-p)
 300        (fast-method-call '.fast-call-method-list.)
 301        (t '.call-method-list.)))
 302     (check-applicable-keywords 'check-applicable-keywords)
 303     (t (default-test-converter form))))
 304
 305 ;;; CMUCL comment (2003-10-15):
 306 ;;;
 307 ;;;   This function is called via the GET-FUNCTION mechanism on forms
 308 ;;;   of an emf lambda.  First value returned replaces FORM in the emf
 309 ;;;   lambda.  Second value is a list of variable names that become
 310 ;;;   closure variables.
 311 (defun memf-code-converter
 312     (form generic-function metatypes applyp method-alist-p wrappers-p)
 313   (case (and (consp form) (car form))
 314     (call-method
 315      (let ((gensym (get-effective-method-gensym)))
 316        (values (make-emf-call
 317                 metatypes applyp gensym
 318                 (make-effective-method-fun-type
 319                  generic-function form method-alist-p wrappers-p))
 320                (list gensym))))
 321     (call-method-list
 322      (let ((gensym (get-effective-method-gensym))
 323            (type (make-effective-method-list-fun-type
 324                   generic-function form method-alist-p wrappers-p)))
 325        (values `(dolist (emf ,gensym nil)
 326                  ,(make-emf-call metatypes applyp 'emf type))
 327                (list gensym))))
 328     (check-applicable-keywords
 329      (values `(check-applicable-keywords .keyargs-start.
 330                                          .valid-keys.
 331                                          .dfun-more-context.
 332                                          .dfun-more-count.)
 333              '(.keyargs-start. .valid-keys.)))
 334     (t
 335      (default-code-converter form))))
 336
 337 (defun memf-constant-converter (form generic-function)
 338   (case (and (consp form) (car form))
 339     (call-method
 340      (list (cons '.meth.
 341                  (make-effective-method-function-simple
 342                   generic-function form))))
 343     (call-method-list
 344      (list (cons '.meth-list.
 345                  (mapcar (lambda (form)
 346                            (make-effective-method-function-simple
 347                             generic-function form))
 348                          (cdr form)))))
 349     (check-applicable-keywords
 350      '(.keyargs-start. .valid-keys.))
 351     (t
 352      (default-constant-converter form))))
 353
 354 (defvar *applicable-methods*)
 355 (defun make-effective-method-function-internal
 356     (generic-function effective-method method-alist-p wrappers-p)
 357   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
 358       (get-generic-fun-info generic-function)
 359     (declare (ignore nkeys arg-info))
 360     (let* ((*rebound-effective-method-gensyms*
 361             *global-effective-method-gensyms*)
 362            (name (if (early-gf-p generic-function)
 363                      (!early-gf-name generic-function)
 364                      (generic-function-name generic-function)))
 365            (arg-info (cons nreq applyp))
 366            (effective-method-lambda (expand-effective-method-function
 367                                      generic-function effective-method)))
 368       (multiple-value-bind (cfunction constants)
 369           (get-fun1 effective-method-lambda
 370                     (lambda (form)
 371                       (memf-test-converter form generic-function
 372                                            method-alist-p wrappers-p))
 373                     (lambda (form)
 374                       (memf-code-converter form generic-function
 375                                            metatypes applyp
 376                                            method-alist-p wrappers-p))
 377                     (lambda (form)
 378                       (memf-constant-converter form generic-function)))
 379         (lambda (method-alist wrappers)
 380           (multiple-value-bind (valid-keys keyargs-start)
 381               (when (memq '.valid-keys. constants)
 382                 (compute-applicable-keywords
 383                  generic-function *applicable-methods*))
 384             (flet ((compute-constant (constant)
 385                      (if (consp constant)
 386                          (case (car constant)
 387                            (.meth.
 388                             (funcall (cdr constant) method-alist wrappers))
 389                            (.meth-list.
 390                             (mapcar (lambda (fn)
 391                                       (funcall fn method-alist wrappers))
 392                                     (cdr constant)))
 393                            (t constant))
 394                          (case constant
 395                            (.keyargs-start. keyargs-start)
 396                            (.valid-keys. valid-keys)
 397                            (t constant)))))
 398               (let ((fun (apply cfunction
 399                                 (mapcar #'compute-constant constants))))
 400                 (set-fun-name fun `(combined-method ,name))
 401                 (make-fast-method-call :function fun
 402                                        :arg-info arg-info)))))))))
 403
 404 (defmacro call-method-list (&rest calls)
 405   `(progn ,@calls))
 406
 407 (defun make-call-methods (methods)
 408   `(call-method-list
 409     ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
 410
 411 (defun gf-requires-emf-keyword-checks (generic-function)
 412   (member '&key (gf-lambda-list generic-function)))
 413
 414 (defvar *in-precompute-effective-methods-p* nil)
 415
 416 (defun standard-compute-effective-method
 417     (generic-function combin applicable-methods)
 418   (collect ((before) (primary) (after) (around))
 419     (flet ((invalid (gf combin m)
 420              (if *in-precompute-effective-methods-p*
 421                  (return-from standard-compute-effective-method
 422                    `(%invalid-qualifiers ',gf ',combin ',m))
 423                  (invalid-qualifiers gf combin m))))
 424       (dolist (m applicable-methods)
 425         (let ((qualifiers (if (listp m)
 426                               (early-method-qualifiers m)
 427                               (method-qualifiers m))))
 428           (cond
 429             ((null qualifiers) (primary m))
 430             ((cdr qualifiers) (invalid generic-function combin m))
 431             ((eq (car qualifiers) :around) (around m))
 432             ((eq (car qualifiers) :before) (before m))
 433             ((eq (car qualifiers) :after) (after m))
 434             (t (invalid generic-function combin m))))))
 435     (cond ((null (primary))
 436            `(%no-primary-method ',generic-function .args.))
 437           ((and (null (before)) (null (after)) (null (around)))
 438            ;; By returning a single call-method `form' here we enable
 439            ;; an important implementation-specific optimization; that
 440            ;; is, we can use the fast method function directly as the
 441            ;; effective method function.
 442            ;;
 443            ;; However, the requirement by ANSI (CLHS 7.6.5) on generic
 444            ;; function argument checking inhibits this, as we don't
 445            ;; perform this checking in fast-method-functions given
 446            ;; that they are not solely used for effective method
 447            ;; functions, but also in combination, when they should not
 448            ;; perform argument checks.
 449            (let ((call-method
 450                   `(call-method ,(first (primary)) ,(rest (primary)))))
 451              (if (gf-requires-emf-keyword-checks generic-function)
 452                  ;; the PROGN inhibits the above optimization
 453                  `(progn ,call-method)
 454                  call-method)))
 455           (t
 456            (let ((main-effective-method
 457                    (if (or (before) (after))
 458                        `(multiple-value-prog1
 459                           (progn
 460                             ,(make-call-methods (before))
 461                             (call-method ,(first (primary))
 462                                          ,(rest (primary))))
 463                           ,(make-call-methods (reverse (after))))
 464                        `(call-method ,(first (primary)) ,(rest (primary))))))
 465              (if (around)
 466                  `(call-method ,(first (around))
 467                                (,@(rest (around))
 468                                   (make-method ,main-effective-method)))
 469                  main-effective-method))))))
 470 \f
 471 ;;; helper code for checking keywords in generic function calls.
 472 (defun compute-applicable-keywords (gf methods)
 473   (let ((any-keyp nil))
 474     (flet ((analyze (lambda-list)
 475              (multiple-value-bind (nreq nopt keyp restp allowp keys)
 476                  (analyze-lambda-list lambda-list)
 477                (declare (ignore nreq restp))
 478                (when keyp
 479                  (setq any-keyp t))
 480                (values nopt allowp keys))))
 481       (multiple-value-bind (nopt allowp keys)
 482           (analyze (generic-function-lambda-list gf))
 483         (dolist (method methods)
 484           (let ((ll (if (consp method)
 485                         (early-method-lambda-list method)
 486                         (method-lambda-list method))))
 487             (multiple-value-bind (n allowp method-keys)
 488                 (analyze ll)
 489               (declare (ignore n))
 490               (when allowp
 491                 (return-from compute-applicable-keywords (values t nopt)))
 492               (setq keys (union method-keys keys)))))
 493         (aver any-keyp)
 494         (values (if allowp t keys) nopt)))))
 495
 496 (defun check-applicable-keywords (start valid-keys more-context more-count)
 497   (let ((allow-other-keys-seen nil)
 498         (allow-other-keys nil)
 499         (i start))
 500     (declare (type index i more-count)
 501              (optimize speed))
 502     (flet ((current-value ()
 503              (sb-c::%more-arg more-context i)))
 504       (declare (inline current-value))
 505       (collect ((invalid))
 506         (loop
 507            (when (>= i more-count)
 508              (when (and (invalid) (not allow-other-keys))
 509                (error 'simple-program-error
 510                       :format-control "~@<invalid keyword argument~P: ~
 511                                    ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
 512                       :format-arguments (list (length (invalid)) (invalid) valid-keys)))
 513              (return))
 514            (let ((key (current-value)))
 515              (incf i)
 516              (cond
 517                ((not (symbolp key))
 518                 (error 'simple-program-error
 519                        :format-control "~@<keyword argument not a symbol: ~S.~@:>"
 520                        :format-arguments (list key)))
 521                ((= i more-count)
 522                 (sb-c::%odd-key-args-error))
 523                ((eq key :allow-other-keys)
 524                 ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
 525                 (unless allow-other-keys-seen
 526                   (setq allow-other-keys-seen t
 527                         allow-other-keys (current-value))))
 528                ((eq t valid-keys))
 529                ((not (memq key valid-keys)) (invalid key))))
 530            (incf i))))))
 531 \f
 532 ;;;; the STANDARD method combination type. This is coded by hand
 533 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
 534 ;;;; and efficiency reasons. Note that the definition of the
 535 ;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
 536 ;;;; defcombin.lisp. This is because EQL methods can't appear in the
 537 ;;;; bootstrap.
 538 ;;;;
 539 ;;;; The DEFCLASS for the METHOD-COMBINATION and
 540 ;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this
 541 ;;;; reason. This code must conform to the code in the file
 542 ;;;; defcombin.lisp, look there for more details.
 543
 544 (defun compute-effective-method (generic-function combin applicable-methods)
 545   (standard-compute-effective-method generic-function
 546                                      combin
 547                                      applicable-methods))
 548
 549 (defun invalid-method-error (method format-control &rest format-arguments)
 550   (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
 551     (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
 552            method
 553            format-control
 554            format-arguments)))
 555
 556 (defun method-combination-error (format-control &rest format-arguments)
 557   (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
 558     (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
 559            format-control
 560            format-arguments)))