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