src/pcl/boot.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 #|
  27
  28 The CommonLoops evaluator is meta-circular.
  29
  30 Most of the code in PCL is methods on generic functions, including
  31 most of the code that actually implements generic functions and method
  32 lookup.
  33
  34 So, we have a classic bootstrapping problem. The solution to this is
  35 to first get a cheap implementation of generic functions running,
  36 these are called early generic functions. These early generic
  37 functions and the corresponding early methods and early method lookup
  38 are used to get enough of the system running that it is possible to
  39 create real generic functions and methods and implement real method
  40 lookup. At that point (done in the file FIXUP) the function
  41 !FIX-EARLY-GENERIC-FUNCTIONS is called to convert all the early generic
  42 functions to real generic functions.
  43
  44 The cheap generic functions are built using the same
  45 FUNCALLABLE-INSTANCE objects that real generic functions are made out of.
  46 This means that as PCL is being bootstrapped, the cheap generic
  47 function objects which are being created are the same objects which
  48 will later be real generic functions. This is good because:
  49   - we don't cons garbage structure, and
  50   - we can keep pointers to the cheap generic function objects
  51     during booting because those pointers will still point to
  52     the right object after the generic functions are all fixed up.
  53
  54 This file defines the DEFMETHOD macro and the mechanism used to expand
  55 it. This includes the mechanism for processing the body of a method.
  56 DEFMETHOD basically expands into a call to LOAD-DEFMETHOD, which
  57 basically calls ADD-METHOD to add the method to the generic function.
  58 These expansions can be loaded either during bootstrapping or when PCL
  59 is fully up and running.
  60
  61 An important effect of this arrangement is it means we can compile
  62 files with DEFMETHOD forms in them in a completely running PCL, but
  63 then load those files back in during bootstrapping. This makes
  64 development easier. It also means there is only one set of code for
  65 processing DEFMETHOD. Bootstrapping works by being sure to have
  66 LOAD-METHOD be careful to call only primitives which work during
  67 bootstrapping.
  68
  69 |#
  70
  71 (declaim (notinline make-a-method add-named-method
  72                     ensure-generic-function-using-class
  73                     add-method remove-method))
  74
  75 (defvar *!early-functions*
  76   '((make-a-method early-make-a-method real-make-a-method)
  77     (add-named-method early-add-named-method real-add-named-method)))
  78
  79 ;;; For each of the early functions, arrange to have it point to its
  80 ;;; early definition. Do this in a way that makes sure that if we
  81 ;;; redefine one of the early definitions the redefinition will take
  82 ;;; effect. This makes development easier.
  83 (dolist (fns *!early-functions*)
  84   (let ((name (car fns))
  85         (early-name (cadr fns)))
  86     (setf (gdefinition name)
  87             (set-fun-name
  88              (lambda (&rest args)
  89                (apply (fdefinition early-name) args))
  90              name))))
  91
  92 ;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
  93 ;;; to convert the few functions in the bootstrap which are supposed
  94 ;;; to be generic functions but can't be early on.
  95 ;;;
  96 ;;; each entry is a list of name and lambda-list, class names as
  97 ;;; specializers, and method body function name.
  98 (defvar *!generic-function-fixups*
  99   '((add-method
 100      ((generic-function method)
 101       (standard-generic-function method)
 102       real-add-method))
 103     (remove-method
 104      ((generic-function method)
 105       (standard-generic-function method)
 106       real-remove-method))
 107     (get-method
 108      ((generic-function qualifiers specializers &optional (errorp t))
 109       (standard-generic-function t t)
 110       real-get-method))
 111     (ensure-generic-function-using-class
 112      ((generic-function fun-name
 113                         &key generic-function-class environment
 114                         &allow-other-keys)
 115       (generic-function t)
 116       real-ensure-gf-using-class--generic-function)
 117      ((generic-function fun-name
 118                         &key generic-function-class environment
 119                         &allow-other-keys)
 120       (null t)
 121       real-ensure-gf-using-class--null))
 122     (make-method-lambda
 123      ((proto-generic-function proto-method lambda-expression environment)
 124       (standard-generic-function standard-method t t)
 125       real-make-method-lambda))
 126     (make-method-specializers-form
 127      ((proto-generic-function proto-method specializer-names environment)
 128       (standard-generic-function standard-method t t)
 129       real-make-method-specializers-form))
 130     (parse-specializer-using-class
 131      ((generic-function specializer)
 132       (standard-generic-function t)
 133       real-parse-specializer-using-class))
 134     (unparse-specializer-using-class
 135      ((generic-function specializer)
 136       (standard-generic-function t)
 137       real-unparse-specializer-using-class))
 138     (make-method-initargs-form
 139      ((proto-generic-function proto-method
 140                               lambda-expression
 141                               lambda-list environment)
 142       (standard-generic-function standard-method t t t)
 143       real-make-method-initargs-form))
 144     (compute-effective-method
 145      ((generic-function combin applicable-methods)
 146       (generic-function standard-method-combination t)
 147       standard-compute-effective-method))))
 148 \f
 149 (defmacro defgeneric (fun-name lambda-list &body options)
 150   (declare (type list lambda-list))
 151   (unless (legal-fun-name-p fun-name)
 152     (error 'simple-program-error
 153            :format-control "illegal generic function name ~S"
 154            :format-arguments (list fun-name)))
 155   (check-gf-lambda-list lambda-list)
 156   (let ((initargs ())
 157         (methods ()))
 158     (flet ((duplicate-option (name)
 159              (error 'simple-program-error
 160                     :format-control "The option ~S appears more than once."
 161                     :format-arguments (list name)))
 162            (expand-method-definition (qab) ; QAB = qualifiers, arglist, body
 163              (let* ((arglist-pos (position-if #'listp qab))
 164                     (arglist (elt qab arglist-pos))
 165                     (qualifiers (subseq qab 0 arglist-pos))
 166                     (body (nthcdr (1+ arglist-pos) qab)))
 167                `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body)
 168                       (generic-function-initial-methods (fdefinition ',fun-name))))))
 169       (macrolet ((initarg (key) `(getf initargs ,key)))
 170         (dolist (option options)
 171           (let ((car-option (car option)))
 172             (case car-option
 173               (declare
 174                (when (and
 175                       (consp (cadr option))
 176                       (member (first (cadr option))
 177                               ;; FIXME: this list is slightly weird.
 178                               ;; ANSI (on the DEFGENERIC page) in one
 179                               ;; place allows only OPTIMIZE; in
 180                               ;; another place gives this list of
 181                               ;; disallowed declaration specifiers.
 182                               ;; This seems to be the only place where
 183                               ;; the FUNCTION declaration is
 184                               ;; mentioned; TYPE seems to be missing.
 185                               ;; Very strange.  -- CSR, 2002-10-21
 186                               '(declaration ftype function
 187                                 inline notinline special)))
 188                  (error 'simple-program-error
 189                         :format-control "The declaration specifier ~S ~
 190                                          is not allowed inside DEFGENERIC."
 191                         :format-arguments (list (cadr option))))
 192                (push (cadr option) (initarg :declarations)))
 193               (:method-combination
 194                (when (initarg car-option)
 195                  (duplicate-option car-option))
 196                (unless (symbolp (cadr option))
 197                  (error 'simple-program-error
 198                         :format-control "METHOD-COMBINATION name not a ~
 199                                          symbol: ~S"
 200                         :format-arguments (list (cadr option))))
 201                (setf (initarg car-option)
 202                      `',(cdr option)))
 203               (:argument-precedence-order
 204                (let* ((required (parse-lambda-list lambda-list))
 205                       (supplied (cdr option)))
 206                  (unless (= (length required) (length supplied))
 207                    (error 'simple-program-error
 208                           :format-control "argument count discrepancy in ~
 209                                            :ARGUMENT-PRECEDENCE-ORDER clause."
 210                           :format-arguments nil))
 211                  (when (set-difference required supplied)
 212                    (error 'simple-program-error
 213                           :format-control "unequal sets for ~
 214                                            :ARGUMENT-PRECEDENCE-ORDER clause: ~
 215                                            ~S and ~S"
 216                           :format-arguments (list required supplied)))
 217                  (setf (initarg car-option)
 218                        `',(cdr option))))
 219               ((:documentation :generic-function-class :method-class)
 220                (unless (proper-list-of-length-p option 2)
 221                  (error "bad list length for ~S" option))
 222                (if (initarg car-option)
 223                    (duplicate-option car-option)
 224                    (setf (initarg car-option) `',(cadr option))))
 225               (:method
 226                (push (cdr option) methods))
 227               (t
 228                ;; ANSI requires that unsupported things must get a
 229                ;; PROGRAM-ERROR.
 230                (error 'simple-program-error
 231                       :format-control "unsupported option ~S"
 232                       :format-arguments (list option))))))
 233
 234         (when (initarg :declarations)
 235           (setf (initarg :declarations)
 236                 `',(initarg :declarations))))
 237       `(progn
 238          (eval-when (:compile-toplevel :load-toplevel :execute)
 239            (compile-or-load-defgeneric ',fun-name))
 240          (load-defgeneric ',fun-name ',lambda-list
 241                           (sb-c:source-location) ,@initargs)
 242         ,@(mapcar #'expand-method-definition methods)
 243         (fdefinition ',fun-name)))))
 244
 245 (defun compile-or-load-defgeneric (fun-name)
 246   (proclaim-as-fun-name fun-name)
 247   (note-name-defined fun-name :function)
 248   (unless (eq (info :function :where-from fun-name) :declared)
 249     (setf (info :function :where-from fun-name) :defined)
 250     (setf (info :function :type fun-name)
 251           (specifier-type 'function))))
 252
 253 (defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
 254   (when (fboundp fun-name)
 255     (style-warn "redefining ~S in DEFGENERIC" fun-name)
 256     (let ((fun (fdefinition fun-name)))
 257       (when (generic-function-p fun)
 258         (loop for method in (generic-function-initial-methods fun)
 259               do (remove-method fun method))
 260         (setf (generic-function-initial-methods fun) '()))))
 261   (apply #'ensure-generic-function
 262          fun-name
 263          :lambda-list lambda-list
 264          :definition-source source-location
 265          initargs))
 266
 267 (define-condition generic-function-lambda-list-error
 268     (reference-condition simple-program-error)
 269   ()
 270   (:default-initargs :references (list '(:ansi-cl :section (3 4 2)))))
 271
 272 (defun check-gf-lambda-list (lambda-list)
 273   (flet ((ensure (arg ok)
 274            (unless ok
 275              (error 'generic-function-lambda-list-error
 276                     :format-control
 277                     "~@<invalid ~S ~_in the generic function lambda list ~S~:>"
 278                     :format-arguments (list arg lambda-list)))))
 279     (multiple-value-bind (required optional restp rest keyp keys allowp
 280                           auxp aux morep more-context more-count)
 281         (parse-lambda-list lambda-list)
 282       (declare (ignore required)) ; since they're no different in a gf ll
 283       (declare (ignore restp rest)) ; since they're no different in a gf ll
 284       (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way
 285       (declare (ignore aux)) ; since we require AUXP=NIL
 286       (declare (ignore more-context more-count)) ; safely ignored unless MOREP
 287       ;; no defaults allowed for &OPTIONAL arguments
 288       (dolist (i optional)
 289         (ensure i (or (symbolp i)
 290                       (and (consp i) (symbolp (car i)) (null (cdr i))))))
 291       ;; no defaults allowed for &KEY arguments
 292       (when keyp
 293         (dolist (i keys)
 294           (ensure i (or (symbolp i)
 295                         (and (consp i)
 296                              (or (symbolp (car i))
 297                                  (and (consp (car i))
 298                                       (symbolp (caar i))
 299                                       (symbolp (cadar i))
 300                                       (null (cddar i))))
 301                              (null (cdr i)))))))
 302       ;; no &AUX allowed
 303       (when auxp
 304         (error "&AUX is not allowed in a generic function lambda list: ~S"
 305                lambda-list))
 306       ;; Oh, *puhlease*... not specifically as per section 3.4.2 of
 307       ;; the ANSI spec, but the CMU CL &MORE extension does not
 308       ;; belong here!
 309       (aver (not morep)))))
 310 \f
 311 (defmacro defmethod (&rest args)
 312   (multiple-value-bind (name qualifiers lambda-list body)
 313       (parse-defmethod args)
 314     `(progn
 315       ;; KLUDGE: this double expansion is quite a monumental
 316       ;; workaround: it comes about because of a fantastic interaction
 317       ;; between the processing rules of CLHS 3.2.3.1 and the
 318       ;; bizarreness of MAKE-METHOD-LAMBDA.
 319       ;;
 320       ;; MAKE-METHOD-LAMBDA can be called by the user, and if the
 321       ;; lambda itself doesn't refer to outside bindings the return
 322       ;; value must be compileable in the null lexical environment.
 323       ;; However, the function must also refer somehow to the
 324       ;; associated method object, so that it can call NO-NEXT-METHOD
 325       ;; with the appropriate arguments if there is no next method --
 326       ;; but when the function is generated, the method object doesn't
 327       ;; exist yet.
 328       ;;
 329       ;; In order to resolve this issue, we insert a literal cons cell
 330       ;; into the body of the method lambda, return the same cons cell
 331       ;; as part of the second (initargs) return value of
 332       ;; MAKE-METHOD-LAMBDA, and a method on INITIALIZE-INSTANCE fills
 333       ;; in the cell when the method is created.  However, this
 334       ;; strategy depends on having a fresh cons cell for every method
 335       ;; lambda, which (without the workaround below) is skewered by
 336       ;; the processing in CLHS 3.2.3.1, which permits implementations
 337       ;; to macroexpand the bodies of EVAL-WHEN forms with both
 338       ;; :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL only once.  The
 339       ;; expansion below forces the double expansion in those cases,
 340       ;; while expanding only once in the common case.
 341       (eval-when (:load-toplevel)
 342         (%defmethod-expander ,name ,qualifiers ,lambda-list ,body))
 343       (eval-when (:execute)
 344         (%defmethod-expander ,name ,qualifiers ,lambda-list ,body)))))
 345
 346 (defmacro %defmethod-expander
 347     (name qualifiers lambda-list body &environment env)
 348   (multiple-value-bind (proto-gf proto-method)
 349       (prototypes-for-make-method-lambda name)
 350     (expand-defmethod name proto-gf proto-method qualifiers
 351                       lambda-list body env)))
 352
 353
 354 (defun prototypes-for-make-method-lambda (name)
 355   (if (not (eq *boot-state* 'complete))
 356       (values nil nil)
 357       (let ((gf? (and (fboundp name)
 358                       (gdefinition name))))
 359         (if (or (null gf?)
 360                 (not (generic-function-p gf?)))
 361             (values (class-prototype (find-class 'standard-generic-function))
 362                     (class-prototype (find-class 'standard-method)))
 363             (values gf?
 364                     (class-prototype (or (generic-function-method-class gf?)
 365                                          (find-class 'standard-method))))))))
 366
 367 ;;; Take a name which is either a generic function name or a list specifying
 368 ;;; a SETF generic function (like: (SETF <generic-function-name>)). Return
 369 ;;; the prototype instance of the method-class for that generic function.
 370 ;;;
 371 ;;; If there is no generic function by that name, this returns the
 372 ;;; default value, the prototype instance of the class
 373 ;;; STANDARD-METHOD. This default value is also returned if the spec
 374 ;;; names an ordinary function or even a macro. In effect, this leaves
 375 ;;; the signalling of the appropriate error until load time.
 376 ;;;
 377 ;;; Note: During bootstrapping, this function is allowed to return NIL.
 378 (defun method-prototype-for-gf (name)
 379   (let ((gf? (and (fboundp name)
 380                   (gdefinition name))))
 381     (cond ((neq *boot-state* 'complete) nil)
 382           ((or (null gf?)
 383                (not (generic-function-p gf?)))          ; Someone else MIGHT
 384                                                         ; error at load time.
 385            (class-prototype (find-class 'standard-method)))
 386           (t
 387             (class-prototype (or (generic-function-method-class gf?)
 388                                  (find-class 'standard-method)))))))
 389 \f
 390 (defun expand-defmethod (name
 391                          proto-gf
 392                          proto-method
 393                          qualifiers
 394                          lambda-list
 395                          body
 396                          env)
 397   (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
 398       (add-method-declarations name qualifiers lambda-list body env)
 399     (multiple-value-bind (method-function-lambda initargs)
 400         (make-method-lambda proto-gf proto-method method-lambda env)
 401       (let ((initargs-form (make-method-initargs-form
 402                             proto-gf proto-method method-function-lambda
 403                             initargs env))
 404             (specializers-form (make-method-specializers-form
 405                                 proto-gf proto-method specializers env)))
 406         `(progn
 407           ;; Note: We could DECLAIM the ftype of the generic function
 408           ;; here, since ANSI specifies that we create it if it does
 409           ;; not exist. However, I chose not to, because I think it's
 410           ;; more useful to support a style of programming where every
 411           ;; generic function has an explicit DEFGENERIC and any typos
 412           ;; in DEFMETHODs are warned about. Otherwise
 413           ;;
 414           ;;   (DEFGENERIC FOO-BAR-BLETCH (X))
 415           ;;   (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
 416           ;;   (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
 417           ;;   (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
 418           ;;   (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
 419           ;;   (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
 420           ;;
 421           ;; compiles without raising an error and runs without
 422           ;; raising an error (since SIMPLE-VECTOR cases fall through
 423           ;; to VECTOR) but still doesn't do what was intended. I hate
 424           ;; that kind of bug (code which silently gives the wrong
 425           ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
 426           ,(make-defmethod-form name qualifiers specializers-form
 427                                 unspecialized-lambda-list
 428                                 (if proto-method
 429                                     (class-name (class-of proto-method))
 430                                     'standard-method)
 431                                 initargs-form))))))
 432
 433 (defun interned-symbol-p (x)
 434   (and (symbolp x) (symbol-package x)))
 435
 436 (defun make-defmethod-form
 437     (name qualifiers specializers unspecialized-lambda-list
 438      method-class-name initargs-form)
 439   (let (fn
 440         fn-lambda)
 441     (if (and (interned-symbol-p (fun-name-block-name name))
 442              (every #'interned-symbol-p qualifiers)
 443              (every (lambda (s)
 444                       (if (consp s)
 445                           (and (eq (car s) 'eql)
 446                                (constantp (cadr s))
 447                                (let ((sv (constant-form-value (cadr s))))
 448                                  (or (interned-symbol-p sv)
 449                                      (integerp sv)
 450                                      (and (characterp sv)
 451                                           (standard-char-p sv)))))
 452                           (interned-symbol-p s)))
 453                     specializers)
 454              (consp initargs-form)
 455              (eq (car initargs-form) 'list*)
 456              (memq (cadr initargs-form) '(:function))
 457              (consp (setq fn (caddr initargs-form)))
 458              (eq (car fn) 'function)
 459              (consp (setq fn-lambda (cadr fn)))
 460              (eq (car fn-lambda) 'lambda)
 461              (bug "Really got here"))
 462         (let* ((specls (mapcar (lambda (specl)
 463                                  (if (consp specl)
 464                                      ;; CONSTANT-FORM-VALUE?  What I
 465                                      ;; kind of want to know, though,
 466                                      ;; is what happens if we don't do
 467                                      ;; this for some slow-method
 468                                      ;; function because of a hairy
 469                                      ;; lexenv -- is the only bad
 470                                      ;; effect that the method
 471                                      ;; function ends up unnamed?  If
 472                                      ;; so, couldn't we arrange to
 473                                      ;; name it later?
 474                                      `(,(car specl) ,(eval (cadr specl)))
 475                                    specl))
 476                                specializers))
 477                (mname `(,(if (eq (cadr initargs-form) :function)
 478                              'slow-method 'fast-method)
 479                         ,name ,@qualifiers ,specls)))
 480           `(progn
 481              (defun ,mname ,(cadr fn-lambda)
 482                ,@(cddr fn-lambda))
 483              ,(make-defmethod-form-internal
 484                name qualifiers `',specls
 485                unspecialized-lambda-list method-class-name
 486                `(list* ,(cadr initargs-form)
 487                        #',mname
 488                        ,@(cdddr initargs-form)))))
 489         (make-defmethod-form-internal
 490          name qualifiers
 491          specializers
 492          #+nil
 493          `(list ,@(mapcar (lambda (specializer)
 494                             (if (consp specializer)
 495                                 ``(,',(car specializer)
 496                                       ,,(cadr specializer))
 497                                 `',specializer))
 498                           specializers))
 499          unspecialized-lambda-list
 500          method-class-name
 501          initargs-form))))
 502
 503 (defun make-defmethod-form-internal
 504     (name qualifiers specializers-form unspecialized-lambda-list
 505      method-class-name initargs-form)
 506   `(load-defmethod
 507     ',method-class-name
 508     ',name
 509     ',qualifiers
 510     ,specializers-form
 511     ',unspecialized-lambda-list
 512     ,initargs-form
 513     (sb-c:source-location)))
 514
 515 (defmacro make-method-function (method-lambda &environment env)
 516   (make-method-function-internal method-lambda env))
 517
 518 (defun make-method-function-internal (method-lambda &optional env)
 519   (multiple-value-bind (proto-gf proto-method)
 520       (prototypes-for-make-method-lambda nil)
 521     (multiple-value-bind (method-function-lambda initargs)
 522         (make-method-lambda proto-gf proto-method method-lambda env)
 523       (make-method-initargs-form proto-gf
 524                                  proto-method
 525                                  method-function-lambda
 526                                  initargs
 527                                  env))))
 528
 529 (defun add-method-declarations (name qualifiers lambda-list body env)
 530   (declare (ignore env))
 531   (multiple-value-bind (parameters unspecialized-lambda-list specializers)
 532       (parse-specialized-lambda-list lambda-list)
 533     (multiple-value-bind (real-body declarations documentation)
 534         (parse-body body)
 535       (values `(lambda ,unspecialized-lambda-list
 536                  ,@(when documentation `(,documentation))
 537                  ;; (Old PCL code used a somewhat different style of
 538                  ;; list for %METHOD-NAME values. Our names use
 539                  ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the
 540                  ;; method names look more like what you see in a
 541                  ;; DEFMETHOD form.)
 542                  ;;
 543                  ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at
 544                  ;; least the code to set up named BLOCKs around the
 545                  ;; bodies of methods, depends on the function's base
 546                  ;; name being the first element of the %METHOD-NAME
 547                  ;; list. It would be good to remove this dependency,
 548                  ;; perhaps by building the BLOCK here, or by using
 549                  ;; another declaration (e.g. %BLOCK-NAME), so that
 550                  ;; our method debug names are free to have any format,
 551                  ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)).
 552                  ;;
 553                  ;; Further, as of sbcl-0.7.9.10, the code to
 554                  ;; implement NO-NEXT-METHOD is coupled to the form of
 555                  ;; this declaration; see the definition of
 556                  ;; CALL-NO-NEXT-METHOD (and the passing of
 557                  ;; METHOD-NAME-DECLARATION arguments around the
 558                  ;; various CALL-NEXT-METHOD logic).
 559                  (declare (%method-name (,name
 560                                          ,@qualifiers
 561                                          ,specializers)))
 562                  (declare (%method-lambda-list ,@lambda-list))
 563                  ,@declarations
 564                  ,@real-body)
 565               unspecialized-lambda-list specializers))))
 566
 567 (defun real-make-method-initargs-form (proto-gf proto-method
 568                                        method-lambda initargs env)
 569   (declare (ignore proto-gf proto-method))
 570   (unless (and (consp method-lambda)
 571                (eq (car method-lambda) 'lambda))
 572     (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~
 573             is not a lambda form."
 574            method-lambda))
 575   (make-method-initargs-form-internal method-lambda initargs env))
 576
 577 (unless (fboundp 'make-method-initargs-form)
 578   (setf (gdefinition 'make-method-initargs-form)
 579         (symbol-function 'real-make-method-initargs-form)))
 580
 581 (defun real-make-method-lambda (proto-gf proto-method method-lambda env)
 582   (declare (ignore proto-gf proto-method))
 583   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
 584     (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
 585             is not a lambda form."
 586            method-lambda))
 587   (multiple-value-bind (real-body declarations documentation)
 588       (parse-body (cddr method-lambda))
 589     (let* ((name-decl (get-declaration '%method-name declarations))
 590            (sll-decl (get-declaration '%method-lambda-list declarations))
 591            (method-name (when (consp name-decl) (car name-decl)))
 592            (generic-function-name (when method-name (car method-name)))
 593            (specialized-lambda-list (or sll-decl (cadr method-lambda)))
 594            ;; the method-cell is a way of communicating what method a
 595            ;; method-function implements, for the purpose of
 596            ;; NO-NEXT-METHOD.  We need something that can be shared
 597            ;; between function and initargs, but not something that
 598            ;; will be coalesced as a constant (because we are naughty,
 599            ;; oh yes) with the expansion of any other methods in the
 600            ;; same file.  -- CSR, 2007-05-30
 601            (method-cell (list (make-symbol "METHOD-CELL"))))
 602       (multiple-value-bind (parameters lambda-list specializers)
 603           (parse-specialized-lambda-list specialized-lambda-list)
 604         (let* ((required-parameters
 605                 (mapcar (lambda (r s) (declare (ignore s)) r)
 606                         parameters
 607                         specializers))
 608                (slots (mapcar #'list required-parameters))
 609                (calls (list nil))
 610                (class-declarations
 611                 `(declare
 612                   ;; These declarations seem to be used by PCL to pass
 613                   ;; information to itself; when I tried to delete 'em
 614                   ;; ca. 0.6.10 it didn't work. I'm not sure how
 615                   ;; they work, but note the (VAR-DECLARATION '%CLASS ..)
 616                   ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30
 617                   ,@(remove nil
 618                             (mapcar (lambda (a s) (and (symbolp s)
 619                                                        (neq s t)
 620                                                        `(%class ,a ,s)))
 621                                     parameters
 622                                     specializers))
 623                   ;; These TYPE declarations weren't in the original
 624                   ;; PCL code, but the Python compiler likes them a
 625                   ;; lot. (We're telling the compiler about our
 626                   ;; knowledge of specialized argument types so that
 627                   ;; it can avoid run-time type dispatch overhead,
 628                   ;; which can be a huge win for Python.)
 629                   ;;
 630                   ;; KLUDGE: when I tried moving these to
 631                   ;; ADD-METHOD-DECLARATIONS, things broke.  No idea
 632                   ;; why.  -- CSR, 2004-06-16
 633                   ,@(mapcar #'parameter-specializer-declaration-in-defmethod
 634                             parameters
 635                             specializers)))
 636                (method-lambda
 637                 ;; Remove the documentation string and insert the
 638                 ;; appropriate class declarations. The documentation
 639                 ;; string is removed to make it easy for us to insert
 640                 ;; new declarations later, they will just go after the
 641                 ;; CADR of the method lambda. The class declarations
 642                 ;; are inserted to communicate the class of the method's
 643                 ;; arguments to the code walk.
 644                 `(lambda ,lambda-list
 645                    ;; The default ignorability of method parameters
 646                    ;; doesn't seem to be specified by ANSI. PCL had
 647                    ;; them basically ignorable but was a little
 648                    ;; inconsistent. E.g. even though the two
 649                    ;; method definitions
 650                    ;;   (DEFMETHOD FOO ((X T) (Y T)) "Z")
 651                    ;;   (DEFMETHOD FOO ((X T) Y) "Z")
 652                    ;; are otherwise equivalent, PCL treated Y as
 653                    ;; ignorable in the first definition but not in the
 654                    ;; second definition. We make all required
 655                    ;; parameters ignorable as a way of systematizing
 656                    ;; the old PCL behavior. -- WHN 2000-11-24
 657                    (declare (ignorable ,@required-parameters))
 658                    ,class-declarations
 659                    ,@declarations
 660                    (block ,(fun-name-block-name generic-function-name)
 661                      ,@real-body)))
 662                (constant-value-p (and (null (cdr real-body))
 663                                       (constantp (car real-body))))
 664                (constant-value (and constant-value-p
 665                                     (constant-form-value (car real-body))))
 666                (plist (and constant-value-p
 667                            (or (typep constant-value
 668                                       '(or number character))
 669                                (and (symbolp constant-value)
 670                                     (symbol-package constant-value)))
 671                            (list :constant-value constant-value)))
 672                (applyp (dolist (p lambda-list nil)
 673                          (cond ((memq p '(&optional &rest &key))
 674                                 (return t))
 675                                ((eq p '&aux)
 676                                 (return nil))))))
 677           (multiple-value-bind
 678                 (walked-lambda call-next-method-p closurep
 679                                next-method-p-p setq-p
 680                                parameters-setqd)
 681               (walk-method-lambda method-lambda
 682                                   required-parameters
 683                                   env
 684                                   slots
 685                                   calls)
 686             (multiple-value-bind (walked-lambda-body
 687                                   walked-declarations
 688                                   walked-documentation)
 689                 (parse-body (cddr walked-lambda))
 690               (declare (ignore walked-documentation))
 691               (when (some #'cdr slots)
 692                 (multiple-value-bind (slot-name-lists call-list)
 693                     (slot-name-lists-from-slots slots calls)
 694                   (setq plist
 695                         `(,@(when slot-name-lists
 696                                   `(:slot-name-lists ,slot-name-lists))
 697                             ,@(when call-list
 698                                     `(:call-list ,call-list))
 699                             ,@plist))
 700                   (setq walked-lambda-body
 701                         `((pv-binding (,required-parameters
 702                                        ,slot-name-lists
 703                                        (load-time-value
 704                                         (intern-pv-table
 705                                          :slot-name-lists ',slot-name-lists
 706                                          :call-list ',call-list)))
 707                             ,@walked-lambda-body)))))
 708               (when (and (memq '&key lambda-list)
 709                          (not (memq '&allow-other-keys lambda-list)))
 710                 (let ((aux (memq '&aux lambda-list)))
 711                   (setq lambda-list (nconc (ldiff lambda-list aux)
 712                                            (list '&allow-other-keys)
 713                                            aux))))
 714               (values `(lambda (.method-args. .next-methods.)
 715                          (simple-lexical-method-functions
 716                              (,lambda-list .method-args. .next-methods.
 717                                            :call-next-method-p
 718                                            ,call-next-method-p
 719                                            :next-method-p-p ,next-method-p-p
 720                                            :setq-p ,setq-p
 721                                            :method-cell ,method-cell
 722                                            :closurep ,closurep
 723                                            :applyp ,applyp)
 724                            ,@walked-declarations
 725                            (locally
 726                                (declare (disable-package-locks
 727                                          %parameter-binding-modified))
 728                              (symbol-macrolet ((%parameter-binding-modified
 729                                                 ',@parameters-setqd))
 730                                (declare (enable-package-locks
 731                                          %parameter-binding-modified))
 732                                ,@walked-lambda-body))))
 733                       `(,@(when call-next-method-p `(method-cell ,method-cell))
 734                           ,@(when plist `(plist ,plist))
 735                           ,@(when documentation `(:documentation ,documentation)))))))))))
 736
 737 (unless (fboundp 'make-method-lambda)
 738   (setf (gdefinition 'make-method-lambda)
 739         (symbol-function 'real-make-method-lambda)))
 740
 741 (defun real-make-method-specializers-form
 742     (proto-gf proto-method specializer-names env)
 743   (declare (ignore env proto-gf proto-method))
 744   (flet ((parse (name)
 745            (cond
 746              ((and (eq *boot-state* 'complete)
 747                    (specializerp name))
 748               name)
 749              ((symbolp name) `(find-class ',name))
 750              ((consp name) (ecase (car name)
 751                              ((eql) `(intern-eql-specializer ,(cadr name)))
 752                              ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))
 753                              ((prototype) `(fixme))))
 754              (t (bug "Foo")))))
 755     `(list ,@(mapcar #'parse specializer-names))))
 756
 757 (unless (fboundp 'make-method-specializers-form)
 758   (setf (gdefinition 'make-method-specializers-form)
 759         (symbol-function 'real-make-method-specializers-form)))
 760
 761 (defun real-parse-specializer-using-class (generic-function specializer)
 762   (let ((result (specializer-from-type specializer)))
 763     (if (specializerp result)
 764         result
 765         (error "~@<~S cannot be parsed as a specializer for ~S.~@:>"
 766                specializer generic-function))))
 767
 768 (unless (fboundp 'parse-specializer-using-class)
 769   (setf (gdefinition 'parse-specializer-using-class)
 770         (symbol-function 'real-parse-specializer-using-class)))
 771
 772 (defun real-unparse-specializer-using-class (generic-function specializer)
 773   (if (specializerp specializer)
 774       ;; FIXME: this HANDLER-CASE is a bit of a hammer to crack a nut:
 775       ;; the idea is that we want to unparse permissively, so that the
 776       ;; lazy (or rather the "portable") specializer extender (who
 777       ;; does not define methods on these new SBCL-specific MOP
 778       ;; functions) can still subclass specializer and define methods
 779       ;; without everything going wrong.  Making it cleaner and
 780       ;; clearer that that is what we are defending against would be
 781       ;; nice.  -- CSR, 2007-06-01
 782       (handler-case
 783           (let ((type (specializer-type specializer)))
 784             (if (and (consp type) (eq (car type) 'class))
 785                 (let* ((class (cadr type))
 786                        (class-name (class-name class)))
 787                   (if (eq class (find-class class-name nil))
 788                       class-name
 789                       type))
 790                 type))
 791         (error () specializer))
 792       (error "~@<~S is not a legal specializer for ~S.~@:>"
 793              specializer generic-function)))
 794
 795 (unless (fboundp 'unparse-specializer-using-class)
 796   (setf (gdefinition 'unparse-specializer-using-class)
 797         (symbol-function 'real-unparse-specializer-using-class)))
 798
 799 ;;; a helper function for creating Python-friendly type declarations
 800 ;;; in DEFMETHOD forms
 801 (defun parameter-specializer-declaration-in-defmethod (parameter specializer)
 802   (cond ((and (consp specializer)
 803               (eq (car specializer) 'eql))
 804          ;; KLUDGE: ANSI, in its wisdom, says that
 805          ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at
 806          ;; DEFMETHOD expansion time. Thus, although one might think
 807          ;; that in
 808          ;;   (DEFMETHOD FOO ((X PACKAGE)
 809          ;;                   (Y (EQL 12))
 810          ;;      ..))
 811          ;; the PACKAGE and (EQL 12) forms are both parallel type
 812          ;; names, they're not, as is made clear when you do
 813          ;;   (DEFMETHOD FOO ((X PACKAGE)
 814          ;;                   (Y (EQL 'BAR)))
 815          ;;     ..)
 816          ;; where Y needs to be a symbol named "BAR", not some cons
 817          ;; made by (CONS 'QUOTE 'BAR). I.e. when the
 818          ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument
 819          ;; to be of type (EQL X). It'd be easy to transform one to
 820          ;; the other, but it'd be somewhat messier to do so while
 821          ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd
 822          ;; once. (The new code wouldn't be messy, but it'd require a
 823          ;; big transformation of the old code.) So instead we punt.
 824          ;; -- WHN 20000610
 825          '(ignorable))
 826         ((member specializer
 827                  ;; KLUDGE: For some low-level implementation
 828                  ;; classes, perhaps because of some problems related
 829                  ;; to the incomplete integration of PCL into SBCL's
 830                  ;; type system, some specializer classes can't be
 831                  ;; declared as argument types. E.g.
 832                  ;;   (DEFMETHOD FOO ((X SLOT-OBJECT))
 833                  ;;     (DECLARE (TYPE SLOT-OBJECT X))
 834                  ;;     ..)
 835                  ;; loses when
 836                  ;;   (DEFSTRUCT BAR A B)
 837                  ;;   (FOO (MAKE-BAR))
 838                  ;; perhaps because of the way that STRUCTURE-OBJECT
 839                  ;; inherits both from SLOT-OBJECT and from
 840                  ;; SB-KERNEL:INSTANCE. In an effort to sweep such
 841                  ;; problems under the rug, we exclude these problem
 842                  ;; cases by blacklisting them here. -- WHN 2001-01-19
 843                  (list 'slot-object #+nil (find-class 'slot-object)))
 844          '(ignorable))
 845         ((not (eq *boot-state* 'complete))
 846          ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
 847          ;; types which don't match their specializers. (Specifically,
 848          ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL
 849          ;; second argument.) Hopefully it only does this kind of
 850          ;; weirdness when bootstrapping.. -- WHN 20000610
 851          '(ignorable))
 852         ((typep specializer 'eql-specializer)
 853          `(type (eql ,(eql-specializer-object specializer)) ,parameter))
 854         ((var-globally-special-p parameter)
 855          ;; KLUDGE: Don't declare types for global special variables
 856          ;; -- our rebinding magic for SETQ cases don't work right
 857          ;; there.
 858          ;;
 859          ;; FIXME: It would be better to detect the SETQ earlier and
 860          ;; skip declarations for specials only when needed, not
 861          ;; always.
 862          ;;
 863          ;; --NS 2004-10-14
 864          '(ignorable))
 865         (t
 866          ;; Otherwise, we can usually make Python very happy.
 867          ;;
 868          ;; KLUDGE: Since INFO doesn't work right for class objects here,
 869          ;; and they are valid specializers, see if the specializer is
 870          ;; a named class, and use the name in that case -- otherwise
 871          ;; the class instance is ok, since info will just return NIL, NIL.
 872          ;;
 873          ;; We still need to deal with the class case too, but at
 874          ;; least #.(find-class 'integer) and integer as equivalent
 875          ;; specializers with this.
 876          (let* ((specializer-nameoid
 877                  (if (and (typep specializer 'class)
 878                           (let ((name (class-name specializer)))
 879                             (and name (symbolp name)
 880                                  (eq specializer (find-class name nil)))))
 881                      (class-name specializer)
 882                      specializer))
 883                 (kind (info :type :kind specializer-nameoid)))
 884
 885            (flet ((specializer-nameoid-class ()
 886                     (typecase specializer-nameoid
 887                       (symbol (find-class specializer-nameoid nil))
 888                       (class specializer-nameoid)
 889                       (class-eq-specializer
 890                        (specializer-class specializer-nameoid))
 891                       (t nil))))
 892              (ecase kind
 893                ((:primitive) `(type ,specializer-nameoid ,parameter))
 894                ((:defined)
 895                 (let ((class (specializer-nameoid-class)))
 896                   ;; CLASS can be null here if the user has
 897                   ;; erroneously tried to use a defined type as a
 898                   ;; specializer; it can be a non-BUILT-IN-CLASS if
 899                   ;; the user defines a type and calls (SETF
 900                   ;; FIND-CLASS) in a consistent way.
 901                  (when (and class (typep class 'built-in-class))
 902                    `(type ,specializer-nameoid ,parameter))))
 903               ((:instance nil)
 904                (let ((class (specializer-nameoid-class)))
 905                  (cond
 906                    (class
 907                     (if (typep class '(or built-in-class structure-class))
 908                         `(type ,class ,parameter)
 909                         ;; don't declare CLOS classes as parameters;
 910                         ;; it's too expensive.
 911                         '(ignorable)))
 912                    (t
 913                     ;; we can get here, and still not have a failure
 914                     ;; case, by doing MOP programming like (PROGN
 915                     ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
 916                     ;; ...)).  Best to let the user know we haven't
 917                     ;; been able to extract enough information:
 918                     (style-warn
 919                      "~@<can't find type for specializer ~S in ~S.~@:>"
 920                      specializer-nameoid
 921                      'parameter-specializer-declaration-in-defmethod)
 922                     '(ignorable)))))
 923               ((:forthcoming-defclass-type)
 924                '(ignorable))))))))
 925
 926 ;;; For passing a list (groveled by the walker) of the required
 927 ;;; parameters whose bindings are modified in the method body to the
 928 ;;; optimized-slot-value* macros.
 929 (define-symbol-macro %parameter-binding-modified ())
 930
 931 (defmacro simple-lexical-method-functions ((lambda-list
 932                                             method-args
 933                                             next-methods
 934                                             &rest lmf-options)
 935                                            &body body)
 936   `(progn
 937      ,method-args ,next-methods
 938      (bind-simple-lexical-method-functions (,method-args ,next-methods
 939                                                          ,lmf-options)
 940          (bind-args (,lambda-list ,method-args)
 941            ,@body))))
 942
 943 (defmacro fast-lexical-method-functions ((lambda-list
 944                                           next-method-call
 945                                           args
 946                                           rest-arg
 947                                           &rest lmf-options)
 948                                          &body body)
 949   `(bind-fast-lexical-method-functions (,args ,rest-arg ,next-method-call ,lmf-options)
 950      (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
 951        ,@body)))
 952
 953 (defmacro bind-simple-lexical-method-functions
 954     ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p
 955                                      closurep applyp method-cell))
 956      &body body
 957      &environment env)
 958   (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
 959       `(locally
 960            ,@body)
 961       `(let ((.next-method. (car ,next-methods))
 962              (,next-methods (cdr ,next-methods)))
 963          (declare (ignorable .next-method. ,next-methods))
 964          (flet (,@(and call-next-method-p
 965                        `((call-next-method
 966                           (&rest cnm-args)
 967                           ,@(if (safe-code-p env)
 968                                 `((%check-cnm-args cnm-args
 969                                                    ,method-args
 970                                                    ',method-cell))
 971                                 nil)
 972                           (if .next-method.
 973                               (funcall (if (std-instance-p .next-method.)
 974                                            (method-function .next-method.)
 975                                            .next-method.) ; for early methods
 976                                        (or cnm-args ,method-args)
 977                                        ,next-methods)
 978                               (apply #'call-no-next-method
 979                                      ',method-cell
 980                                      (or cnm-args ,method-args))))))
 981                 ,@(and next-method-p-p
 982                        '((next-method-p ()
 983                           (not (null .next-method.))))))
 984            ,@body))))
 985
 986 (defun call-no-next-method (method-cell &rest args)
 987   (let ((method (car method-cell)))
 988     (aver method)
 989     (apply #'no-next-method (method-generic-function method)
 990            method args)))
 991
 992 (defstruct (method-call (:copier nil))
 993   (function #'identity :type function)
 994   call-method-args)
 995 (defstruct (constant-method-call (:copier nil) (:include method-call))
 996   value)
 997
 998 #-sb-fluid (declaim (sb-ext:freeze-type method-call))
 999
1000 (defmacro invoke-method-call1 (function args cm-args)
1001   `(let ((.function. ,function)
1002          (.args. ,args)
1003          (.cm-args. ,cm-args))
1004      (if (and .cm-args. (null (cdr .cm-args.)))
1005          (funcall .function. .args. (car .cm-args.))
1006          (apply .function. .args. .cm-args.))))
1007
1008 (defmacro invoke-method-call (method-call restp &rest required-args+rest-arg)
1009   `(invoke-method-call1 (method-call-function ,method-call)
1010                         ,(if restp
1011                              `(list* ,@required-args+rest-arg)
1012                              `(list ,@required-args+rest-arg))
1013                         (method-call-call-method-args ,method-call)))
1014
1015 (defstruct (fast-method-call (:copier nil))
1016   (function #'identity :type function)
1017   pv-cell
1018   next-method-call
1019   arg-info)
1020 (defstruct (constant-fast-method-call
1021              (:copier nil) (:include fast-method-call))
1022   value)
1023
1024 #-sb-fluid (declaim (sb-ext:freeze-type fast-method-call))
1025
1026 ;; The two variants of INVOKE-FAST-METHOD-CALL differ in how REST-ARGs
1027 ;; are handled. The first one will get REST-ARG as a single list (as
1028 ;; the last argument), and will thus need to use APPLY. The second one
1029 ;; will get them as a &MORE argument, so we can pass the arguments
1030 ;; directly with MULTIPLE-VALUE-CALL and %MORE-ARG-VALUES.
1031
1032 (defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg)
1033   `(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call)
1034                                 (fast-method-call-pv-cell ,method-call)
1035                                 (fast-method-call-next-method-call ,method-call)
1036                                 ,@required-args+rest-arg))
1037
1038 (defmacro invoke-fast-method-call/more (method-call
1039                                         more-context
1040                                         more-count
1041                                         &rest required-args)
1042   (macrolet ((generate-call (n)
1043                ``(funcall (fast-method-call-function ,method-call)
1044                           (fast-method-call-pv-cell ,method-call)
1045                           (fast-method-call-next-method-call ,method-call)
1046                           ,@required-args
1047                           ,@(loop for x below ,n
1048                                   collect `(sb-c::%more-arg ,more-context ,x)))))
1049     ;; The cases with only small amounts of required arguments passed
1050     ;; are probably very common, and special-casing speeds them up by
1051     ;; a factor of 2 with very little effect on the other
1052     ;; cases. Though it'd be nice to have the generic case be equally
1053     ;; fast.
1054     `(case ,more-count
1055        (0 ,(generate-call 0))
1056        (1 ,(generate-call 1))
1057        (t (multiple-value-call (fast-method-call-function ,method-call)
1058             (values (fast-method-call-pv-cell ,method-call))
1059             (values (fast-method-call-next-method-call ,method-call))
1060             ,@required-args
1061             (sb-c::%more-arg-values ,more-context 0 ,more-count))))))
1062
1063 (defstruct (fast-instance-boundp (:copier nil))
1064   (index 0 :type fixnum))
1065
1066 #-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp))
1067
1068 (eval-when (:compile-toplevel :load-toplevel :execute)
1069   (defvar *allow-emf-call-tracing-p* nil)
1070   (defvar *enable-emf-call-tracing-p* #-sb-show nil #+sb-show t))
1071 \f
1072 ;;;; effective method functions
1073
1074 (defvar *emf-call-trace-size* 200)
1075 (defvar *emf-call-trace* nil)
1076 (defvar *emf-call-trace-index* 0)
1077
1078 ;;; This function was in the CMU CL version of PCL (ca Debian 2.4.8)
1079 ;;; without explanation. It appears to be intended for debugging, so
1080 ;;; it might be useful someday, so I haven't deleted it.
1081 ;;; But it isn't documented and isn't used for anything now, so
1082 ;;; I've conditionalized it out of the base system. -- WHN 19991213
1083 #+sb-show
1084 (defun show-emf-call-trace ()
1085   (when *emf-call-trace*
1086     (let ((j *emf-call-trace-index*)
1087           (*enable-emf-call-tracing-p* nil))
1088       (format t "~&(The oldest entries are printed first)~%")
1089       (dotimes-fixnum (i *emf-call-trace-size*)
1090         (let ((ct (aref *emf-call-trace* j)))
1091           (when ct (print ct)))
1092         (incf j)
1093         (when (= j *emf-call-trace-size*)
1094           (setq j 0))))))
1095
1096 (defun trace-emf-call-internal (emf format args)
1097   (unless *emf-call-trace*
1098     (setq *emf-call-trace* (make-array *emf-call-trace-size*)))
1099   (setf (aref *emf-call-trace* *emf-call-trace-index*)
1100         (list* emf format args))
1101   (incf *emf-call-trace-index*)
1102   (when (= *emf-call-trace-index* *emf-call-trace-size*)
1103     (setq *emf-call-trace-index* 0)))
1104
1105 (defmacro trace-emf-call (emf format args)
1106   (when *allow-emf-call-tracing-p*
1107     `(when *enable-emf-call-tracing-p*
1108        (trace-emf-call-internal ,emf ,format ,args))))
1109
1110 (defmacro invoke-effective-method-function-fast
1111     (emf restp &key required-args rest-arg more-arg)
1112   `(progn
1113      (trace-emf-call ,emf ,restp (list ,@required-args rest-arg))
1114      ,(if more-arg
1115           `(invoke-fast-method-call/more ,emf
1116                                          ,@more-arg
1117                                          ,@required-args)
1118           `(invoke-fast-method-call ,emf
1119                                     ,restp
1120                                     ,@required-args
1121                                     ,@rest-arg))))
1122
1123 (defun effective-method-optimized-slot-access-clause
1124     (emf restp required-args)
1125   ;; "What," you may wonder, "do these next two clauses do?" In that
1126   ;; case, you are not a PCL implementor, for they considered this to
1127   ;; be self-documenting.:-| Or CSR, for that matter, since he can
1128   ;; also figure it out by looking at it without breaking stride. For
1129   ;; the rest of us, though: From what the code is doing with .SLOTS.
1130   ;; and whatnot, evidently it's implementing SLOT-VALUEish and
1131   ;; GET-SLOT-VALUEish things. Then we can reason backwards and
1132   ;; conclude that setting EMF to a FIXNUM is an optimized way to
1133   ;; represent these slot access operations.
1134   (when (not restp)
1135     (let ((length (length required-args)))
1136       (cond ((= 1 length)
1137              `((fixnum
1138                 (let* ((.slots. (get-slots-or-nil
1139                                  ,(car required-args)))
1140                        (value (when .slots. (clos-slots-ref .slots. ,emf))))
1141                   (if (eq value +slot-unbound+)
1142                       (slot-unbound-internal ,(car required-args)
1143                                              ,emf)
1144                       value)))))
1145             ((= 2 length)
1146              `((fixnum
1147                 (let ((.new-value. ,(car required-args))
1148                       (.slots. (get-slots-or-nil
1149                                 ,(cadr required-args))))
1150                   (when .slots.
1151                     (setf (clos-slots-ref .slots. ,emf) .new-value.)))))))
1152       ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
1153       ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
1154       ;; there was no explanation and presumably the code is 10+
1155       ;; years stale, I simply deleted it. -- WHN)
1156       )))
1157
1158 ;;; Before SBCL 0.9.16.7 instead of
1159 ;;; INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION we passed a (THE (OR
1160 ;;; FUNCTION METHOD-CALL FAST-METHOD-CALL) EMF) form as the EMF. Now,
1161 ;;; to make less work for the compiler we take a path that doesn't
1162 ;;; involve the slot-accessor clause (where EMF is a FIXNUM) at all.
1163 (macrolet ((def (name &optional narrow)
1164              `(defmacro ,name (emf restp &key required-args rest-arg more-arg)
1165                 (unless (constantp restp)
1166                   (error "The RESTP argument is not constant."))
1167                 (setq restp (constant-form-value restp))
1168                 (with-unique-names (emf-n)
1169                   `(locally
1170                        (declare (optimize (sb-c:insert-step-conditions 0)))
1171                      (let ((,emf-n ,emf))
1172                        (trace-emf-call ,emf-n ,restp (list ,@required-args ,@rest-arg))
1173                        (etypecase ,emf-n
1174                          (fast-method-call
1175                           ,(if more-arg
1176                                `(invoke-fast-method-call/more ,emf-n
1177                                                               ,@more-arg
1178                                                               ,@required-args)
1179                                `(invoke-fast-method-call ,emf-n
1180                                                          ,restp
1181                                                          ,@required-args
1182                                                          ,@rest-arg)))
1183                          ,@,(unless narrow
1184                               `(effective-method-optimized-slot-access-clause
1185                                 emf-n restp required-args))
1186                          (method-call
1187                           (invoke-method-call ,emf-n ,restp ,@required-args
1188                                               ,@rest-arg))
1189                          (function
1190                           ,(if restp
1191                                `(apply ,emf-n ,@required-args ,@rest-arg)
1192                                `(funcall ,emf-n ,@required-args
1193                                          ,@rest-arg))))))))))
1194   (def invoke-effective-method-function nil)
1195   (def invoke-narrow-effective-method-function t))
1196
1197 (defun invoke-emf (emf args)
1198   (trace-emf-call emf t args)
1199   (etypecase emf
1200     (fast-method-call
1201      (let* ((arg-info (fast-method-call-arg-info emf))
1202             (restp (cdr arg-info))
1203             (nreq (car arg-info)))
1204        (if restp
1205            (apply (fast-method-call-function emf)
1206                   (fast-method-call-pv-cell emf)
1207                   (fast-method-call-next-method-call emf)
1208                   args)
1209            (cond ((null args)
1210                   (if (eql nreq 0)
1211                       (invoke-fast-method-call emf nil)
1212                       (error 'simple-program-error
1213                              :format-control "invalid number of arguments: 0"
1214                              :format-arguments nil)))
1215                  ((null (cdr args))
1216                   (if (eql nreq 1)
1217                       (invoke-fast-method-call emf nil (car args))
1218                       (error 'simple-program-error
1219                              :format-control "invalid number of arguments: 1"
1220                              :format-arguments nil)))
1221                  ((null (cddr args))
1222                   (if (eql nreq 2)
1223                       (invoke-fast-method-call emf nil (car args) (cadr args))
1224                       (error 'simple-program-error
1225                              :format-control "invalid number of arguments: 2"
1226                              :format-arguments nil)))
1227                  (t
1228                   (apply (fast-method-call-function emf)
1229                          (fast-method-call-pv-cell emf)
1230                          (fast-method-call-next-method-call emf)
1231                          args))))))
1232     (method-call
1233      (apply (method-call-function emf)
1234             args
1235             (method-call-call-method-args emf)))
1236     (fixnum
1237      (cond ((null args)
1238             (error 'simple-program-error
1239                    :format-control "invalid number of arguments: 0"
1240                    :format-arguments nil))
1241            ((null (cdr args))
1242             (let* ((slots (get-slots (car args)))
1243                    (value (clos-slots-ref slots emf)))
1244               (if (eq value +slot-unbound+)
1245                   (slot-unbound-internal (car args) emf)
1246                   value)))
1247            ((null (cddr args))
1248             (setf (clos-slots-ref (get-slots (cadr args)) emf)
1249                   (car args)))
1250            (t (error 'simple-program-error
1251                      :format-control "invalid number of arguments"
1252                      :format-arguments nil))))
1253     (fast-instance-boundp
1254      (if (or (null args) (cdr args))
1255          (error 'simple-program-error
1256                 :format-control "invalid number of arguments"
1257                 :format-arguments nil)
1258          (let ((slots (get-slots (car args))))
1259            (not (eq (clos-slots-ref slots (fast-instance-boundp-index emf))
1260                     +slot-unbound+)))))
1261     (function
1262      (apply emf args))))
1263 \f
1264
1265 (defmacro fast-call-next-method-body ((args next-method-call rest-arg)
1266                                       method-cell
1267                                       cnm-args)
1268   `(if ,next-method-call
1269        ,(let ((call `(invoke-narrow-effective-method-function
1270                       ,next-method-call
1271                       ,(not (null rest-arg))
1272                       :required-args ,args
1273                       :rest-arg ,(when rest-arg (list rest-arg)))))
1274              `(if ,cnm-args
1275                   (bind-args ((,@args
1276                                ,@(when rest-arg
1277                                        `(&rest ,rest-arg)))
1278                               ,cnm-args)
1279                     ,call)
1280                   ,call))
1281        (call-no-next-method ',method-cell
1282                             ,@args
1283                             ,@(when rest-arg
1284                                     `(,rest-arg)))))
1285
1286 (defmacro bind-fast-lexical-method-functions
1287     ((args rest-arg next-method-call (&key
1288                                       call-next-method-p
1289                                       setq-p
1290                                       method-cell
1291                                       next-method-p-p
1292                                       closurep
1293                                       applyp))
1294      &body body
1295      &environment env)
1296   (let* ((all-params (append args (when rest-arg (list rest-arg))))
1297          (rebindings (when (or setq-p call-next-method-p)
1298                        (mapcar (lambda (x) (list x x)) all-params))))
1299     (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
1300         `(locally
1301              ,@body)
1302         `(flet (,@(when call-next-method-p
1303                         `((call-next-method (&rest cnm-args)
1304                             (declare (muffle-conditions code-deletion-note)
1305                                      (optimize (sb-c:insert-step-conditions 0)))
1306                            ,@(if (safe-code-p env)
1307                                  `((%check-cnm-args cnm-args (list ,@args)
1308                                                     ',method-cell))
1309                                  nil)
1310                            (fast-call-next-method-body (,args
1311                                                         ,next-method-call
1312                                                         ,rest-arg)
1313                             ,method-cell
1314                             cnm-args))))
1315                 ,@(when next-method-p-p
1316                         `((next-method-p ()
1317                            (declare (optimize (sb-c:insert-step-conditions 0)))
1318                            (not (null ,next-method-call))))))
1319            (let ,rebindings
1320              ,@(when rebindings `((declare (ignorable ,@all-params))))
1321              ,@body)))))
1322
1323 ;;; CMUCL comment (Gerd Moellmann):
1324 ;;;
1325 ;;; The standard says it's an error if CALL-NEXT-METHOD is called with
1326 ;;; arguments, and the set of methods applicable to those arguments is
1327 ;;; different from the set of methods applicable to the original
1328 ;;; method arguments.  (According to Barry Margolin, this rule was
1329 ;;; probably added to ensure that before and around methods are always
1330 ;;; run before primary methods.)
1331 ;;;
1332 ;;; This could be optimized for the case that the generic function
1333 ;;; doesn't have hairy methods, does have standard method combination,
1334 ;;; is a standard generic function, there are no methods defined on it
1335 ;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such
1336 ;;; preconditions.  That looks hairy and is probably not worth it,
1337 ;;; because this check will never be fast.
1338 (defun %check-cnm-args (cnm-args orig-args method-cell)
1339   (when cnm-args
1340     (let* ((gf (method-generic-function (car method-cell)))
1341            (omethods (compute-applicable-methods gf orig-args))
1342            (nmethods (compute-applicable-methods gf cnm-args)))
1343       (unless (equal omethods nmethods)
1344         (error "~@<The set of methods ~S applicable to argument~P ~
1345                 ~{~S~^, ~} to call-next-method is different from ~
1346                 the set of methods ~S applicable to the original ~
1347                 method argument~P ~{~S~^, ~}.~@:>"
1348                nmethods (length cnm-args) cnm-args omethods
1349                (length orig-args) orig-args)))))
1350
1351 (defmacro bind-args ((lambda-list args) &body body)
1352   (let ((args-tail '.args-tail.)
1353         (key '.key.)
1354         (state 'required))
1355     (flet ((process-var (var)
1356              (if (memq var lambda-list-keywords)
1357                  (progn
1358                    (case var
1359                      (&optional       (setq state 'optional))
1360                      (&key            (setq state 'key))
1361                      (&allow-other-keys)
1362                      (&rest           (setq state 'rest))
1363                      (&aux            (setq state 'aux))
1364                      (otherwise
1365                       (error
1366                        "encountered the non-standard lambda list keyword ~S"
1367                        var)))
1368                    nil)
1369                  (case state
1370                    (required `((,var (pop ,args-tail))))
1371                    (optional (cond ((not (consp var))
1372                                     `((,var (when ,args-tail
1373                                               (pop ,args-tail)))))
1374                                    ((null (cddr var))
1375                                     `((,(car var) (if ,args-tail
1376                                                       (pop ,args-tail)
1377                                                       ,(cadr var)))))
1378                                    (t
1379                                     `((,(caddr var) (not (null ,args-tail)))
1380                                       (,(car var) (if ,args-tail
1381                                                       (pop ,args-tail)
1382                                                       ,(cadr var)))))))
1383                    (rest `((,var ,args-tail)))
1384                    (key (cond ((not (consp var))
1385                                `((,var (car
1386                                         (get-key-arg-tail ,(keywordicate var)
1387                                                           ,args-tail)))))
1388                               ((null (cddr var))
1389                                (multiple-value-bind (keyword variable)
1390                                    (if (consp (car var))
1391                                        (values (caar var)
1392                                                (cadar var))
1393                                        (values (keywordicate (car var))
1394                                                (car var)))
1395                                  `((,key (get-key-arg-tail ',keyword
1396                                                            ,args-tail))
1397                                    (,variable (if ,key
1398                                                   (car ,key)
1399                                                   ,(cadr var))))))
1400                               (t
1401                                (multiple-value-bind (keyword variable)
1402                                    (if (consp (car var))
1403                                        (values (caar var)
1404                                                (cadar var))
1405                                        (values (keywordicate (car var))
1406                                                (car var)))
1407                                  `((,key (get-key-arg-tail ',keyword
1408                                                            ,args-tail))
1409                                    (,(caddr var) (not (null,key)))
1410                                    (,variable (if ,key
1411                                                   (car ,key)
1412                                                   ,(cadr var))))))))
1413                    (aux `(,var))))))
1414       (let ((bindings (mapcan #'process-var lambda-list)))
1415         `(let* ((,args-tail ,args)
1416                 ,@bindings
1417                 (.dummy0.
1418                  ,@(when (eq state 'optional)
1419                      `((unless (null ,args-tail)
1420                          (error 'simple-program-error
1421                                 :format-control "surplus arguments: ~S"
1422                                 :format-arguments (list ,args-tail)))))))
1423            (declare (ignorable ,args-tail .dummy0.))
1424            ,@body)))))
1425
1426 (defun get-key-arg-tail (keyword list)
1427   (loop for (key . tail) on list by #'cddr
1428         when (null tail) do
1429           ;; FIXME: Do we want to export this symbol? Or maybe use an
1430           ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form?
1431           (sb-c::%odd-key-args-error)
1432         when (eq key keyword)
1433           return tail))
1434
1435 (defun walk-method-lambda (method-lambda required-parameters env slots calls)
1436   (let (;; flag indicating that CALL-NEXT-METHOD should be in the
1437         ;; method definition
1438         (call-next-method-p nil)
1439         ;; flag indicating that #'CALL-NEXT-METHOD was seen in the
1440         ;; body of a method
1441         (closurep nil)
1442         ;; flag indicating that NEXT-METHOD-P should be in the method
1443         ;; definition
1444         (next-method-p-p nil)
1445         ;; a list of all required parameters whose bindings might be
1446         ;; modified in the method body.
1447         (parameters-setqd nil))
1448     (flet ((walk-function (form context env)
1449              (cond ((not (eq context :eval)) form)
1450                    ;; FIXME: Jumping to a conclusion from the way it's used
1451                    ;; above, perhaps CONTEXT should be called SITUATION
1452                    ;; (after the term used in the ANSI specification of
1453                    ;; EVAL-WHEN) and given modern ANSI keyword values
1454                    ;; like :LOAD-TOPLEVEL.
1455                    ((not (listp form)) form)
1456                    ((eq (car form) 'call-next-method)
1457                     (setq call-next-method-p t)
1458                     form)
1459                    ((eq (car form) 'next-method-p)
1460                     (setq next-method-p-p t)
1461                     form)
1462                    ((memq (car form) '(setq multiple-value-setq))
1463                     ;; FIXME: this is possibly a little strong as
1464                     ;; conditions go.  Ideally we would want to detect
1465                     ;; which, if any, of the method parameters are
1466                     ;; being set, and communicate that information to
1467                     ;; e.g. SPLIT-DECLARATIONS.  However, the brute
1468                     ;; force method doesn't really cost much; a little
1469                     ;; loss of discrimination over IGNORED variables
1470                     ;; should be all.  -- CSR, 2004-07-01
1471                     ;;
1472                     ;; As of 2006-09-18 modified parameter bindings
1473                     ;; are now tracked with more granularity than just
1474                     ;; one SETQ-P flag, in order to disable SLOT-VALUE
1475                     ;; optimizations for parameters that are SETQd.
1476                     ;; The old binary SETQ-P flag is still used for
1477                     ;; all other purposes, since as noted above, the
1478                     ;; extra cost is minimal. -- JES, 2006-09-18
1479                     ;;
1480                     ;; The walker will split (SETQ A 1 B 2) to
1481                     ;; separate (SETQ A 1) and (SETQ B 2) forms, so we
1482                     ;; only need to handle the simple case of SETQ
1483                     ;; here.
1484                     (let ((vars (if (eq (car form) 'setq)
1485                                     (list (second form))
1486                                     (second form))))
1487                       (dolist (var vars)
1488                         ;; Note that we don't need to check for
1489                         ;; %VARIABLE-REBINDING declarations like is
1490                         ;; done in CAN-OPTIMIZE-ACCESS1, since the
1491                         ;; bindings that will have that declation will
1492                         ;; never be SETQd.
1493                         (when (var-declaration '%class var env)
1494                           ;; If a parameter binding is shadowed by
1495                           ;; another binding it won't have a %CLASS
1496                           ;; declaration anymore, and this won't get
1497                           ;; executed.
1498                           (pushnew var parameters-setqd))))
1499                     form)
1500                    ((and (eq (car form) 'function)
1501                          (cond ((eq (cadr form) 'call-next-method)
1502                                 (setq call-next-method-p t)
1503                                 (setq closurep t)
1504                                 form)
1505                                ((eq (cadr form) 'next-method-p)
1506                                 (setq next-method-p-p t)
1507                                 (setq closurep t)
1508                                 form)
1509                                (t nil))))
1510                    ((and (memq (car form)
1511                                '(slot-value set-slot-value slot-boundp))
1512                          (constantp (caddr form)))
1513                     (let ((parameter (can-optimize-access form
1514                                                           required-parameters
1515                                                           env)))
1516                       (let ((fun (ecase (car form)
1517                                    (slot-value #'optimize-slot-value)
1518                                    (set-slot-value #'optimize-set-slot-value)
1519                                    (slot-boundp #'optimize-slot-boundp))))
1520                         (funcall fun slots parameter form))))
1521                    (t form))))
1522
1523       (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
1524         ;;; FIXME: the walker's rewriting of the source code causes
1525         ;;; trouble when doing code coverage. The rewrites should be
1526         ;;; removed, and the same operations done using
1527         ;;; compiler-macros or tranforms.
1528         (values (if (sb-c:policy env (= sb-c:store-coverage-data 0))
1529                     walked-lambda
1530                     method-lambda)
1531                 call-next-method-p
1532                 closurep
1533                 next-method-p-p
1534                 (not (null parameters-setqd))
1535                 parameters-setqd)))))
1536
1537 (defun generic-function-name-p (name)
1538   (and (legal-fun-name-p name)
1539        (fboundp name)
1540        (if (eq *boot-state* 'complete)
1541            (standard-generic-function-p (gdefinition name))
1542            (funcallable-instance-p (gdefinition name)))))
1543 \f
1544 (defun method-plist-value (method key &optional default)
1545   (let ((plist (if (consp method)
1546                    (getf (early-method-initargs method) 'plist)
1547                    (object-plist method))))
1548     (getf plist key default)))
1549
1550 (defun (setf method-plist-value) (new-value method key &optional default)
1551   (if (consp method)
1552       (setf (getf (getf (early-method-initargs method) 'plist) key default)
1553             new-value)
1554       (setf (getf (object-plist method) key default) new-value)))
1555 \f
1556 (defun load-defmethod (class name quals specls ll initargs source-location)
1557   (let ((method-cell (getf initargs 'method-cell)))
1558     (setq initargs (copy-tree initargs))
1559     (when method-cell
1560       (setf (getf initargs 'method-cell) method-cell))
1561     #+nil
1562     (setf (getf (getf initargs 'plist) :name)
1563           (make-method-spec name quals specls))
1564     (load-defmethod-internal class name quals specls
1565                              ll initargs source-location)))
1566
1567 (defun load-defmethod-internal
1568     (method-class gf-spec qualifiers specializers lambda-list
1569                   initargs source-location)
1570   (when (and (eq *boot-state* 'complete)
1571              (fboundp gf-spec))
1572     (let* ((gf (fdefinition gf-spec))
1573            (method (and (generic-function-p gf)
1574                         (generic-function-methods gf)
1575                         (find-method gf qualifiers specializers nil))))
1576       (when method
1577         (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
1578                     gf-spec qualifiers specializers))))
1579   (let ((method (apply #'add-named-method
1580                        gf-spec qualifiers specializers lambda-list
1581                        :definition-source source-location
1582                        initargs)))
1583     (unless (or (eq method-class 'standard-method)
1584                 (eq (find-class method-class nil) (class-of method)))
1585       ;; FIXME: should be STYLE-WARNING?
1586       (format *error-output*
1587               "~&At the time the method with qualifiers ~:S and~%~
1588                specializers ~:S on the generic function ~S~%~
1589                was compiled, the method-class for that generic function was~%~
1590                ~S. But, the method class is now ~S, this~%~
1591                may mean that this method was compiled improperly.~%"
1592               qualifiers specializers gf-spec
1593               method-class (class-name (class-of method))))
1594     method))
1595
1596 (defun make-method-spec (gf qualifiers specializers)
1597   (let ((name (generic-function-name gf))
1598         (unparsed-specializers (unparse-specializers gf specializers)))
1599     `(slow-method ,name ,@qualifiers ,unparsed-specializers)))
1600
1601 (defun initialize-method-function (initargs method)
1602   (let* ((mf (getf initargs :function))
1603          (mff (and (typep mf '%method-function)
1604                    (%method-function-fast-function mf)))
1605          (plist (getf initargs 'plist))
1606          (name (getf plist :name))
1607          (method-cell (getf initargs 'method-cell)))
1608     (when method-cell
1609       (setf (car method-cell) method))
1610     (when name
1611       (when mf
1612         (setq mf (set-fun-name mf name)))
1613       (when (and mff (consp name) (eq (car name) 'slow-method))
1614         (let ((fast-name `(fast-method ,@(cdr name))))
1615           (set-fun-name mff fast-name))))
1616     (when plist
1617       (let ((plist plist))
1618         (let ((snl (getf plist :slot-name-lists))
1619               (cl (getf plist :call-list)))
1620           (when (or snl cl)
1621             (setf (method-plist-value method :pv-table)
1622                   (intern-pv-table :slot-name-lists snl :call-list cl))))))))
1623 \f
1624 (defun analyze-lambda-list (lambda-list)
1625   (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
1626          (parse-key-arg (arg)
1627            (if (listp arg)
1628                (if (listp (car arg))
1629                    (caar arg)
1630                    (keywordicate (car arg)))
1631                (keywordicate arg))))
1632     (let ((nrequired 0)
1633           (noptional 0)
1634           (keysp nil)
1635           (restp nil)
1636           (nrest 0)
1637           (allow-other-keys-p nil)
1638           (keywords ())
1639           (keyword-parameters ())
1640           (state 'required))
1641       (dolist (x lambda-list)
1642         (if (memq x lambda-list-keywords)
1643             (case x
1644               (&optional         (setq state 'optional))
1645               (&key              (setq keysp t
1646                                        state 'key))
1647               (&allow-other-keys (setq allow-other-keys-p t))
1648               (&rest             (setq restp t
1649                                        state 'rest))
1650               (&aux           (return t))
1651               (otherwise
1652                 (error "encountered the non-standard lambda list keyword ~S"
1653                        x)))
1654             (ecase state
1655               (required  (incf nrequired))
1656               (optional  (incf noptional))
1657               (key       (push (parse-key-arg x) keywords)
1658                          (push x keyword-parameters))
1659               (rest      (incf nrest)))))
1660       (when (and restp (zerop nrest))
1661         (error "Error in lambda-list:~%~
1662                 After &REST, a DEFGENERIC lambda-list ~
1663                 must be followed by at least one variable."))
1664       (values nrequired noptional keysp restp allow-other-keys-p
1665               (reverse keywords)
1666               (reverse keyword-parameters)))))
1667
1668 (defun keyword-spec-name (x)
1669   (let ((key (if (atom x) x (car x))))
1670     (if (atom key)
1671         (keywordicate key)
1672         (car key))))
1673
1674 (defun ftype-declaration-from-lambda-list (lambda-list name)
1675   (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p
1676                                   keywords keyword-parameters)
1677       (analyze-lambda-list lambda-list)
1678     (declare (ignore keyword-parameters))
1679     (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
1680            (old-ftype (if (fun-type-p old) old nil))
1681            (old-restp (and old-ftype (fun-type-rest old-ftype)))
1682            (old-keys (and old-ftype
1683                           (mapcar #'key-info-name
1684                                   (fun-type-keywords
1685                                    old-ftype))))
1686            (old-keysp (and old-ftype (fun-type-keyp old-ftype)))
1687            (old-allowp (and old-ftype
1688                             (fun-type-allowp old-ftype)))
1689            (keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
1690       `(function ,(append (make-list nrequired :initial-element t)
1691                           (when (plusp noptional)
1692                             (append '(&optional)
1693                                     (make-list noptional :initial-element t)))
1694                           (when (or restp old-restp)
1695                             '(&rest t))
1696                           (when (or keysp old-keysp)
1697                             (append '(&key)
1698                                     (mapcar (lambda (key)
1699                                               `(,key t))
1700                                             keywords)
1701                                     (when (or allow-other-keys-p old-allowp)
1702                                       '(&allow-other-keys)))))
1703                  *))))
1704
1705 (defun defgeneric-declaration (spec lambda-list)
1706   `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
1707 \f
1708 ;;;; early generic function support
1709
1710 (defvar *!early-generic-functions* ())
1711
1712 (defun ensure-generic-function (fun-name
1713                                 &rest all-keys
1714                                 &key environment source-location
1715                                 &allow-other-keys)
1716   (declare (ignore environment))
1717   (let ((existing (and (fboundp fun-name)
1718                        (gdefinition fun-name))))
1719     (cond ((and existing
1720                 (eq *boot-state* 'complete)
1721                 (null (generic-function-p existing)))
1722            (generic-clobbers-function fun-name)
1723            (fmakunbound fun-name)
1724            (apply #'ensure-generic-function fun-name all-keys))
1725           (t
1726            (apply #'ensure-generic-function-using-class
1727                   existing fun-name all-keys)))))
1728
1729 (defun generic-clobbers-function (fun-name)
1730   (cerror "Replace the function binding"
1731           'simple-program-error
1732           :format-control "~S already names an ordinary function or a macro."
1733           :format-arguments (list fun-name)))
1734
1735 (defvar *sgf-wrapper*
1736   (boot-make-wrapper (early-class-size 'standard-generic-function)
1737                      'standard-generic-function))
1738
1739 (defvar *sgf-slots-init*
1740   (mapcar (lambda (canonical-slot)
1741             (if (memq (getf canonical-slot :name) '(arg-info source))
1742                 +slot-unbound+
1743                 (let ((initfunction (getf canonical-slot :initfunction)))
1744                   (if initfunction
1745                       (funcall initfunction)
1746                       +slot-unbound+))))
1747           (early-collect-inheritance 'standard-generic-function)))
1748
1749 (defvar *sgf-method-class-index*
1750   (!bootstrap-slot-index 'standard-generic-function 'method-class))
1751
1752 (defun early-gf-p (x)
1753   (and (fsc-instance-p x)
1754        (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*)
1755            +slot-unbound+)))
1756
1757 (defvar *sgf-methods-index*
1758   (!bootstrap-slot-index 'standard-generic-function 'methods))
1759
1760 (defmacro early-gf-methods (gf)
1761   `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
1762
1763 (defun safe-generic-function-methods (generic-function)
1764   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
1765       (clos-slots-ref (get-slots generic-function) *sgf-methods-index*)
1766       (generic-function-methods generic-function)))
1767
1768 (defvar *sgf-arg-info-index*
1769   (!bootstrap-slot-index 'standard-generic-function 'arg-info))
1770
1771 (defmacro early-gf-arg-info (gf)
1772   `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*))
1773
1774 (defvar *sgf-dfun-state-index*
1775   (!bootstrap-slot-index 'standard-generic-function 'dfun-state))
1776
1777 (defstruct (arg-info
1778             (:conc-name nil)
1779             (:constructor make-arg-info ())
1780             (:copier nil))
1781   (arg-info-lambda-list :no-lambda-list)
1782   arg-info-precedence
1783   arg-info-metatypes
1784   arg-info-number-optional
1785   arg-info-key/rest-p
1786   arg-info-keys   ;nil        no &KEY or &REST allowed
1787                   ;(k1 k2 ..) Each method must accept these &KEY arguments.
1788                   ;T          must have &KEY or &REST
1789
1790   gf-info-simple-accessor-type ; nil, reader, writer, boundp
1791   (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
1792
1793   gf-info-static-c-a-m-emf
1794   (gf-info-c-a-m-emf-std-p t)
1795   gf-info-fast-mf-p)
1796
1797 #-sb-fluid (declaim (sb-ext:freeze-type arg-info))
1798
1799 (defun arg-info-valid-p (arg-info)
1800   (not (null (arg-info-number-optional arg-info))))
1801
1802 (defun arg-info-applyp (arg-info)
1803   (or (plusp (arg-info-number-optional arg-info))
1804       (arg-info-key/rest-p arg-info)))
1805
1806 (defun arg-info-number-required (arg-info)
1807   (length (arg-info-metatypes arg-info)))
1808
1809 (defun arg-info-nkeys (arg-info)
1810   (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info)))
1811
1812 (defun create-gf-lambda-list (lambda-list)
1813   ;;; Create a gf lambda list from a method lambda list
1814   (loop for x in lambda-list
1815         collect (if (consp x) (list (car x)) x)
1816         if (eq x '&key) do (loop-finish)))
1817
1818 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
1819                         argument-precedence-order)
1820   (let* ((arg-info (if (eq *boot-state* 'complete)
1821                        (gf-arg-info gf)
1822                        (early-gf-arg-info gf)))
1823          (methods (if (eq *boot-state* 'complete)
1824                       (generic-function-methods gf)
1825                       (early-gf-methods gf)))
1826          (was-valid-p (integerp (arg-info-number-optional arg-info)))
1827          (first-p (and new-method (null (cdr methods)))))
1828     (when (and (not lambda-list-p) methods)
1829       (setq lambda-list (gf-lambda-list gf)))
1830     (when (or lambda-list-p
1831               (and first-p
1832                    (eq (arg-info-lambda-list arg-info) :no-lambda-list)))
1833       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1834           (analyze-lambda-list lambda-list)
1835         (when (and methods (not first-p))
1836           (let ((gf-nreq (arg-info-number-required arg-info))
1837                 (gf-nopt (arg-info-number-optional arg-info))
1838                 (gf-key/rest-p (arg-info-key/rest-p arg-info)))
1839             (unless (and (= nreq gf-nreq)
1840                          (= nopt gf-nopt)
1841                          (eq (or keysp restp) gf-key/rest-p))
1842               (error "The lambda-list ~S is incompatible with ~
1843                      existing methods of ~S."
1844                      lambda-list gf))))
1845         (setf (arg-info-lambda-list arg-info)
1846               (if lambda-list-p
1847                   lambda-list
1848                    (create-gf-lambda-list lambda-list)))
1849         (when (or lambda-list-p argument-precedence-order
1850                   (null (arg-info-precedence arg-info)))
1851           (setf (arg-info-precedence arg-info)
1852                 (compute-precedence lambda-list nreq argument-precedence-order)))
1853         (setf (arg-info-metatypes arg-info) (make-list nreq))
1854         (setf (arg-info-number-optional arg-info) nopt)
1855         (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
1856         (setf (arg-info-keys arg-info)
1857               (if lambda-list-p
1858                   (if allow-other-keys-p t keywords)
1859                   (arg-info-key/rest-p arg-info)))))
1860     (when new-method
1861       (check-method-arg-info gf arg-info new-method))
1862     (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
1863     arg-info))
1864
1865 (defun check-method-arg-info (gf arg-info method)
1866   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1867       (analyze-lambda-list (if (consp method)
1868                                (early-method-lambda-list method)
1869                                (method-lambda-list method)))
1870     (flet ((lose (string &rest args)
1871              (error 'simple-program-error
1872                     :format-control "~@<attempt to add the method~2I~_~S~I~_~
1873                                      to the generic function~2I~_~S;~I~_~
1874                                      but ~?~:>"
1875                     :format-arguments (list method gf string args)))
1876            (comparison-description (x y)
1877              (if (> x y) "more" "fewer")))
1878       (let ((gf-nreq (arg-info-number-required arg-info))
1879             (gf-nopt (arg-info-number-optional arg-info))
1880             (gf-key/rest-p (arg-info-key/rest-p arg-info))
1881             (gf-keywords (arg-info-keys arg-info)))
1882         (unless (= nreq gf-nreq)
1883           (lose
1884            "the method has ~A required arguments than the generic function."
1885            (comparison-description nreq gf-nreq)))
1886         (unless (= nopt gf-nopt)
1887           (lose
1888            "the method has ~A optional arguments than the generic function."
1889            (comparison-description nopt gf-nopt)))
1890         (unless (eq (or keysp restp) gf-key/rest-p)
1891           (lose
1892            "the method and generic function differ in whether they accept~_~
1893             &REST or &KEY arguments."))
1894         (when (consp gf-keywords)
1895           (unless (or (and restp (not keysp))
1896                       allow-other-keys-p
1897                       (every (lambda (k) (memq k keywords)) gf-keywords))
1898             (lose "the method does not accept each of the &KEY arguments~2I~_~
1899                    ~S."
1900                   gf-keywords)))))))
1901
1902 (defvar *sm-specializers-index*
1903   (!bootstrap-slot-index 'standard-method 'specializers))
1904 (defvar *sm-%function-index*
1905   (!bootstrap-slot-index 'standard-method '%function))
1906 (defvar *sm-qualifiers-index*
1907   (!bootstrap-slot-index 'standard-method 'qualifiers))
1908 (defvar *sm-plist-index*
1909   (!bootstrap-slot-index 'standard-method 'plist))
1910
1911 ;;; FIXME: we don't actually need this; we could test for the exact
1912 ;;; class and deal with it as appropriate.  In fact we probably don't
1913 ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
1914 ;;; the standard reader method for METHOD-SPECIALIZERS.  Probably.
1915 (dolist (s '(specializers %function plist))
1916   (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
1917            (!bootstrap-slot-index 'standard-reader-method s)
1918            (!bootstrap-slot-index 'standard-writer-method s)
1919            (!bootstrap-slot-index 'standard-boundp-method s))))
1920
1921 (defun safe-method-specializers (method)
1922   (let ((standard-method-classes
1923          (list *the-class-standard-method*
1924                *the-class-standard-reader-method*
1925                *the-class-standard-writer-method*
1926                *the-class-standard-boundp-method*))
1927         (class (class-of method)))
1928     (if (member class standard-method-classes)
1929         (clos-slots-ref (get-slots method) *sm-specializers-index*)
1930         (method-specializers method))))
1931 (defun safe-method-fast-function (method)
1932   (let ((mf (safe-method-function method)))
1933     (and (typep mf '%method-function)
1934          (%method-function-fast-function mf))))
1935 (defun safe-method-function (method)
1936   (let ((standard-method-classes
1937          (list *the-class-standard-method*
1938                *the-class-standard-reader-method*
1939                *the-class-standard-writer-method*
1940                *the-class-standard-boundp-method*))
1941         (class (class-of method)))
1942     (if (member class standard-method-classes)
1943         (clos-slots-ref (get-slots method) *sm-%function-index*)
1944         (method-function method))))
1945 (defun safe-method-qualifiers (method)
1946   (let ((standard-method-classes
1947          (list *the-class-standard-method*
1948                *the-class-standard-reader-method*
1949                *the-class-standard-writer-method*
1950                *the-class-standard-boundp-method*))
1951         (class (class-of method)))
1952     (if (member class standard-method-classes)
1953         (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
1954         (method-qualifiers method))))
1955
1956 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
1957   (let* ((existing-p (and methods (cdr methods) new-method))
1958          (nreq (length (arg-info-metatypes arg-info)))
1959          (metatypes (if existing-p
1960                         (arg-info-metatypes arg-info)
1961                         (make-list nreq)))
1962          (type (if existing-p
1963                    (gf-info-simple-accessor-type arg-info)
1964                    nil)))
1965     (when (arg-info-valid-p arg-info)
1966       (dolist (method (if new-method (list new-method) methods))
1967         (let* ((specializers (if (or (eq *boot-state* 'complete)
1968                                      (not (consp method)))
1969                                  (safe-method-specializers method)
1970                                  (early-method-specializers method t)))
1971                (class (if (or (eq *boot-state* 'complete) (not (consp method)))
1972                           (class-of method)
1973                           (early-method-class method)))
1974                (new-type
1975                 (when (and class
1976                            (or (not (eq *boot-state* 'complete))
1977                                (eq (generic-function-method-combination gf)
1978                                    *standard-method-combination*)))
1979                   (cond ((or (eq class *the-class-standard-reader-method*)
1980                              (eq class *the-class-global-reader-method*))
1981                          'reader)
1982                         ((or (eq class *the-class-standard-writer-method*)
1983                              (eq class *the-class-global-writer-method*))
1984                          'writer)
1985                         ((or (eq class *the-class-standard-boundp-method*)
1986                              (eq class *the-class-global-boundp-method*))
1987                          'boundp)))))
1988           (setq metatypes (mapcar #'raise-metatype metatypes specializers))
1989           (setq type (cond ((null type) new-type)
1990                            ((eq type new-type) type)
1991                            (t nil)))))
1992       (setf (arg-info-metatypes arg-info) metatypes)
1993       (setf (gf-info-simple-accessor-type arg-info) type)))
1994   (when (or (not was-valid-p) first-p)
1995     (multiple-value-bind (c-a-m-emf std-p)
1996         (if (early-gf-p gf)
1997             (values t t)
1998             (compute-applicable-methods-emf gf))
1999       (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
2000       (setf (gf-info-c-a-m-emf-std-p arg-info) std-p)
2001       (unless (gf-info-c-a-m-emf-std-p arg-info)
2002         (setf (gf-info-simple-accessor-type arg-info) t))))
2003   (unless was-valid-p
2004     (let ((name (if (eq *boot-state* 'complete)
2005                     (generic-function-name gf)
2006                     (!early-gf-name gf))))
2007       (setf (gf-precompute-dfun-and-emf-p arg-info)
2008             (cond
2009               ((and (consp name)
2010                     (member (car name)
2011                             *internal-pcl-generalized-fun-name-symbols*))
2012                 nil)
2013               (t (let* ((symbol (fun-name-block-name name))
2014                         (package (symbol-package symbol)))
2015                    (and (or (eq package *pcl-package*)
2016                             (memq package (package-use-list *pcl-package*)))
2017                         ;; FIXME: this test will eventually be
2018                         ;; superseded by the *internal-pcl...* test,
2019                         ;; above.  While we are in a process of
2020                         ;; transition, however, it should probably
2021                         ;; remain.
2022                         (not (find #\Space (symbol-name symbol))))))))))
2023   (setf (gf-info-fast-mf-p arg-info)
2024         (or (not (eq *boot-state* 'complete))
2025             (let* ((method-class (generic-function-method-class gf))
2026                    (methods (compute-applicable-methods
2027                              #'make-method-lambda
2028                              (list gf (class-prototype method-class)
2029                                    '(lambda) nil))))
2030               (and methods (null (cdr methods))
2031                    (let ((specls (method-specializers (car methods))))
2032                      (and (classp (car specls))
2033                           (eq 'standard-generic-function
2034                               (class-name (car specls)))
2035                           (classp (cadr specls))
2036                           (eq 'standard-method
2037                               (class-name (cadr specls)))))))))
2038   arg-info)
2039
2040 ;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS.
2041 ;;;
2042 ;;; The STATIC-SLOTS field of the funcallable instances used as early
2043 ;;; generic functions is used to store the early methods and early
2044 ;;; discriminator code for the early generic function. The static
2045 ;;; slots field of the fins contains a list whose:
2046 ;;;    CAR    -   a list of the early methods on this early gf
2047 ;;;    CADR   -   the early discriminator code for this method
2048 (defun ensure-generic-function-using-class (existing spec &rest keys
2049                                             &key (lambda-list nil
2050                                                               lambda-list-p)
2051                                             argument-precedence-order
2052                                             source-location
2053                                             &allow-other-keys)
2054   (declare (ignore keys))
2055   (cond ((and existing (early-gf-p existing))
2056          (when lambda-list-p
2057            (set-arg-info existing :lambda-list lambda-list))
2058          existing)
2059         ((assoc spec *!generic-function-fixups* :test #'equal)
2060          (if existing
2061              (make-early-gf spec lambda-list lambda-list-p existing
2062                             argument-precedence-order source-location)
2063              (bug "The function ~S is not already defined." spec)))
2064         (existing
2065          (bug "~S should be on the list ~S."
2066               spec '*!generic-function-fixups*))
2067         (t
2068          (pushnew spec *!early-generic-functions* :test #'equal)
2069          (make-early-gf spec lambda-list lambda-list-p nil
2070                         argument-precedence-order source-location))))
2071
2072 (defun make-early-gf (spec &optional lambda-list lambda-list-p
2073                       function argument-precedence-order source-location)
2074   (let ((fin (allocate-standard-funcallable-instance
2075               *sgf-wrapper* *sgf-slots-init*)))
2076     (set-funcallable-instance-function
2077      fin
2078      (or function
2079          (if (eq spec 'print-object)
2080              #'(lambda (instance stream)
2081                  (print-unreadable-object (instance stream :identity t)
2082                    (format stream "std-instance")))
2083              #'(lambda (&rest args)
2084                  (declare (ignore args))
2085                  (error "The function of the funcallable-instance ~S~
2086                          has not been set." fin)))))
2087     (setf (gdefinition spec) fin)
2088     (!bootstrap-set-slot 'standard-generic-function fin 'name spec)
2089     (!bootstrap-set-slot 'standard-generic-function
2090                          fin
2091                          'source
2092                          source-location)
2093     (set-fun-name fin spec)
2094     (let ((arg-info (make-arg-info)))
2095       (setf (early-gf-arg-info fin) arg-info)
2096       (when lambda-list-p
2097         (proclaim (defgeneric-declaration spec lambda-list))
2098         (if argument-precedence-order
2099             (set-arg-info fin
2100                           :lambda-list lambda-list
2101                           :argument-precedence-order argument-precedence-order)
2102             (set-arg-info fin :lambda-list lambda-list))))
2103     fin))
2104
2105 (defun safe-gf-dfun-state (generic-function)
2106   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
2107       (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*)
2108       (gf-dfun-state generic-function)))
2109 (defun (setf safe-gf-dfun-state) (new-value generic-function)
2110   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
2111       (setf (clos-slots-ref (get-slots generic-function)
2112                             *sgf-dfun-state-index*)
2113             new-value)
2114       (setf (gf-dfun-state generic-function) new-value)))
2115
2116 (defun set-dfun (gf &optional dfun cache info)
2117   (let ((new-state (if (and dfun (or cache info))
2118                        (list* dfun cache info)
2119                        dfun)))
2120     (cond
2121       ((eq *boot-state* 'complete)
2122        ;; Check that we are under the lock.
2123        #+sb-thread
2124        (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf))))
2125        (setf (safe-gf-dfun-state gf) new-state))
2126       (t
2127        (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
2128              new-state))))
2129   dfun)
2130
2131 (defun gf-dfun-cache (gf)
2132   (let ((state (if (eq *boot-state* 'complete)
2133                    (safe-gf-dfun-state gf)
2134                    (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
2135     (typecase state
2136       (function nil)
2137       (cons (cadr state)))))
2138
2139 (defun gf-dfun-info (gf)
2140   (let ((state (if (eq *boot-state* 'complete)
2141                    (safe-gf-dfun-state gf)
2142                    (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
2143     (typecase state
2144       (function nil)
2145       (cons (cddr state)))))
2146
2147 (defvar *sgf-name-index*
2148   (!bootstrap-slot-index 'standard-generic-function 'name))
2149
2150 (defun !early-gf-name (gf)
2151   (clos-slots-ref (get-slots gf) *sgf-name-index*))
2152
2153 (defun gf-lambda-list (gf)
2154   (let ((arg-info (if (eq *boot-state* 'complete)
2155                       (gf-arg-info gf)
2156                       (early-gf-arg-info gf))))
2157     (if (eq :no-lambda-list (arg-info-lambda-list arg-info))
2158         (let ((methods (if (eq *boot-state* 'complete)
2159                            (generic-function-methods gf)
2160                            (early-gf-methods gf))))
2161           (if (null methods)
2162               (progn
2163                 (warn "no way to determine the lambda list for ~S" gf)
2164                 nil)
2165               (let* ((method (car (last methods)))
2166                      (ll (if (consp method)
2167                              (early-method-lambda-list method)
2168                              (method-lambda-list method))))
2169                 (create-gf-lambda-list ll))))
2170         (arg-info-lambda-list arg-info))))
2171
2172 (defmacro real-ensure-gf-internal (gf-class all-keys env)
2173   `(progn
2174      (cond ((symbolp ,gf-class)
2175             (setq ,gf-class (find-class ,gf-class t ,env)))
2176            ((classp ,gf-class))
2177            (t
2178             (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
2179                     class nor a symbol that names a class."
2180                    ,gf-class)))
2181      (unless (class-finalized-p ,gf-class)
2182        (if (class-has-a-forward-referenced-superclass-p ,gf-class)
2183            ;; FIXME: reference MOP documentation -- this is an
2184            ;; additional requirement on our users
2185            (error "The generic function class ~S is not finalizeable" ,gf-class)
2186            (finalize-inheritance ,gf-class)))
2187      (remf ,all-keys :generic-function-class)
2188      (remf ,all-keys :environment)
2189      (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
2190        (unless (eq combin '.shes-not-there.)
2191          (setf (getf ,all-keys :method-combination)
2192                (find-method-combination (class-prototype ,gf-class)
2193                                         (car combin)
2194                                         (cdr combin)))))
2195     (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
2196       (unless (eq method-class '.shes-not-there.)
2197         (setf (getf ,all-keys :method-class)
2198               (cond ((classp method-class)
2199                      method-class)
2200                     (t (find-class method-class t ,env))))))))
2201
2202 (defun real-ensure-gf-using-class--generic-function
2203        (existing
2204         fun-name
2205         &rest all-keys
2206         &key environment (lambda-list nil lambda-list-p)
2207         (generic-function-class 'standard-generic-function)
2208         &allow-other-keys)
2209   (real-ensure-gf-internal generic-function-class all-keys environment)
2210   ;; KLUDGE: the above macro does SETQ on GENERIC-FUNCTION-CLASS,
2211   ;; which is what makes the next line work
2212   (unless (eq (class-of existing) generic-function-class)
2213     (change-class existing generic-function-class))
2214   (prog1
2215       (apply #'reinitialize-instance existing all-keys)
2216     (when lambda-list-p
2217       (proclaim (defgeneric-declaration fun-name lambda-list)))))
2218
2219 (defun real-ensure-gf-using-class--null
2220        (existing
2221         fun-name
2222         &rest all-keys
2223         &key environment (lambda-list nil lambda-list-p)
2224              (generic-function-class 'standard-generic-function)
2225         &allow-other-keys)
2226   (declare (ignore existing))
2227   (real-ensure-gf-internal generic-function-class all-keys environment)
2228   (prog1
2229       (setf (gdefinition fun-name)
2230             (apply #'make-instance generic-function-class
2231                    :name fun-name all-keys))
2232     (when lambda-list-p
2233       (proclaim (defgeneric-declaration fun-name lambda-list)))))
2234 \f
2235 (defun safe-gf-arg-info (generic-function)
2236   (if (eq (class-of generic-function) *the-class-standard-generic-function*)
2237       (clos-slots-ref (fsc-instance-slots generic-function)
2238                       *sgf-arg-info-index*)
2239       (gf-arg-info generic-function)))
2240
2241 ;;; FIXME: this function took on a slightly greater role than it
2242 ;;; previously had around 2005-11-02, when CSR fixed the bug whereby
2243 ;;; having more than one subclass of standard-generic-function caused
2244 ;;; the whole system to die horribly through a metacircle in
2245 ;;; GF-ARG-INFO.  The fix is to be slightly more disciplined about
2246 ;;; calling accessor methods -- we call GET-GENERIC-FUN-INFO when
2247 ;;; computing discriminating functions, so we need to be careful about
2248 ;;; having a base case for the recursion, and we provide that with the
2249 ;;; STANDARD-GENERIC-FUNCTION case below.  However, we are not (yet)
2250 ;;; as disciplined as CLISP's CLOS/MOP, and it would be nice to get to
2251 ;;; that stage, where all potentially dangerous cases are enumerated
2252 ;;; and stopped.  -- CSR, 2005-11-02.
2253 (defun get-generic-fun-info (gf)
2254   ;; values   nreq applyp metatypes nkeys arg-info
2255   (multiple-value-bind (applyp metatypes arg-info)
2256       (let* ((arg-info (if (early-gf-p gf)
2257                            (early-gf-arg-info gf)
2258                            (safe-gf-arg-info gf)))
2259              (metatypes (arg-info-metatypes arg-info)))
2260         (values (arg-info-applyp arg-info)
2261                 metatypes
2262                 arg-info))
2263     (values (length metatypes) applyp metatypes
2264             (count-if (lambda (x) (neq x t)) metatypes)
2265             arg-info)))
2266
2267 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
2268                             &key slot-name object-class method-class-function)
2269   (let ((parsed ())
2270         (unparsed ()))
2271     ;; Figure out whether we got class objects or class names as the
2272     ;; specializers and set parsed and unparsed appropriately. If we
2273     ;; got class objects, then we can compute unparsed, but if we got
2274     ;; class names we don't try to compute parsed.
2275     ;;
2276     ;; Note that the use of not symbolp in this call to every should be
2277     ;; read as 'classp' we can't use classp itself because it doesn't
2278     ;; exist yet.
2279     (if (every (lambda (s) (not (symbolp s))) specializers)
2280         (setq parsed specializers
2281               unparsed (mapcar (lambda (s)
2282                                  (if (eq s t) t (class-name s)))
2283                                specializers))
2284         (setq unparsed specializers
2285               parsed ()))
2286     (let ((result
2287            (list :early-method
2288
2289                  (getf initargs :function)
2290                  (let ((mf (getf initargs :function)))
2291                    (aver mf)
2292                    (and (typep mf '%method-function)
2293                         (%method-function-fast-function mf)))
2294
2295                  ;; the parsed specializers. This is used by
2296                  ;; EARLY-METHOD-SPECIALIZERS to cache the parse.
2297                  ;; Note that this only comes into play when there is
2298                  ;; more than one early method on an early gf.
2299                  parsed
2300
2301                  ;; A list to which REAL-MAKE-A-METHOD can be applied
2302                  ;; to make a real method corresponding to this early
2303                  ;; one.
2304                  (append
2305                   (list class qualifiers arglist unparsed
2306                         initargs doc)
2307                   (when slot-name
2308                     (list :slot-name slot-name :object-class object-class
2309                           :method-class-function method-class-function))))))
2310       (initialize-method-function initargs result)
2311       result)))
2312
2313 (defun real-make-a-method
2314        (class qualifiers lambda-list specializers initargs doc
2315         &rest args &key slot-name object-class method-class-function)
2316   (if method-class-function
2317       (let* ((object-class (if (classp object-class) object-class
2318                                (find-class object-class)))
2319              (slots (class-direct-slots object-class))
2320              (slot-definition (find slot-name slots
2321                                     :key #'slot-definition-name)))
2322         (aver slot-name)
2323         (aver slot-definition)
2324         (let ((initargs (list* :qualifiers qualifiers :lambda-list lambda-list
2325                                :specializers specializers :documentation doc
2326                                :slot-definition slot-definition
2327                                :slot-name slot-name initargs)))
2328           (apply #'make-instance
2329                  (apply method-class-function object-class slot-definition
2330                         initargs)
2331                  initargs)))
2332       (apply #'make-instance class :qualifiers qualifiers
2333              :lambda-list lambda-list :specializers specializers
2334              :documentation doc (append args initargs))))
2335
2336 (defun early-method-function (early-method)
2337   (values (cadr early-method) (caddr early-method)))
2338
2339 (defun early-method-class (early-method)
2340   (find-class (car (fifth early-method))))
2341
2342 (defun early-method-standard-accessor-p (early-method)
2343   (let ((class (first (fifth early-method))))
2344     (or (eq class 'standard-reader-method)
2345         (eq class 'standard-writer-method)
2346         (eq class 'standard-boundp-method))))
2347
2348 (defun early-method-standard-accessor-slot-name (early-method)
2349   (eighth (fifth early-method)))
2350
2351 ;;; Fetch the specializers of an early method. This is basically just
2352 ;;; a simple accessor except that when the second argument is t, this
2353 ;;; converts the specializers from symbols into class objects. The
2354 ;;; class objects are cached in the early method, this makes
2355 ;;; bootstrapping faster because the class objects only have to be
2356 ;;; computed once.
2357 ;;;
2358 ;;; NOTE:
2359 ;;;  The second argument should only be passed as T by
2360 ;;;  early-lookup-method. This is to implement the rule that only when
2361 ;;;  there is more than one early method on a generic function is the
2362 ;;;  conversion from class names to class objects done. This
2363 ;;;  corresponds to the fact that we are only allowed to have one
2364 ;;;  method on any generic function up until the time classes exist.
2365 (defun early-method-specializers (early-method &optional objectsp)
2366   (if (and (listp early-method)
2367            (eq (car early-method) :early-method))
2368       (cond ((eq objectsp t)
2369              (or (fourth early-method)
2370                  (setf (fourth early-method)
2371                        (mapcar #'find-class (cadddr (fifth early-method))))))
2372             (t
2373              (fourth (fifth early-method))))
2374       (error "~S is not an early-method." early-method)))
2375
2376 (defun early-method-qualifiers (early-method)
2377   (second (fifth early-method)))
2378
2379 (defun early-method-lambda-list (early-method)
2380   (third (fifth early-method)))
2381
2382 (defun early-method-initargs (early-method)
2383   (fifth (fifth early-method)))
2384
2385 (defun (setf early-method-initargs) (new-value early-method)
2386   (setf (fifth (fifth early-method)) new-value))
2387
2388 (defun early-add-named-method (generic-function-name qualifiers
2389                                specializers arglist &rest initargs)
2390   (let* (;; we don't need to deal with the :generic-function-class
2391          ;; argument here because the default,
2392          ;; STANDARD-GENERIC-FUNCTION, is right for all early generic
2393          ;; functions.  (See REAL-ADD-NAMED-METHOD)
2394          (gf (ensure-generic-function generic-function-name))
2395          (existing
2396            (dolist (m (early-gf-methods gf))
2397              (when (and (equal (early-method-specializers m) specializers)
2398                         (equal (early-method-qualifiers m) qualifiers))
2399                (return m)))))
2400     (setf (getf (getf initargs 'plist) :name)
2401           (make-method-spec gf qualifiers specializers))
2402     (let ((new (make-a-method 'standard-method qualifiers arglist
2403                               specializers initargs ())))
2404       (when existing (remove-method gf existing))
2405       (add-method gf new))))
2406
2407 ;;; This is the early version of ADD-METHOD. Later this will become a
2408 ;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has
2409 ;;; special knowledge about ADD-METHOD.
2410 (defun add-method (generic-function method)
2411   (when (not (fsc-instance-p generic-function))
2412     (error "Early ADD-METHOD didn't get a funcallable instance."))
2413   (when (not (and (listp method) (eq (car method) :early-method)))
2414     (error "Early ADD-METHOD didn't get an early method."))
2415   (push method (early-gf-methods generic-function))
2416   (set-arg-info generic-function :new-method method)
2417   (unless (assoc (!early-gf-name generic-function)
2418                  *!generic-function-fixups*
2419                  :test #'equal)
2420     (update-dfun generic-function)))
2421
2422 ;;; This is the early version of REMOVE-METHOD. See comments on
2423 ;;; the early version of ADD-METHOD.
2424 (defun remove-method (generic-function method)
2425   (when (not (fsc-instance-p generic-function))
2426     (error "An early remove-method didn't get a funcallable instance."))
2427   (when (not (and (listp method) (eq (car method) :early-method)))
2428     (error "An early remove-method didn't get an early method."))
2429   (setf (early-gf-methods generic-function)
2430         (remove method (early-gf-methods generic-function)))
2431   (set-arg-info generic-function)
2432   (unless (assoc (!early-gf-name generic-function)
2433                  *!generic-function-fixups*
2434                  :test #'equal)
2435     (update-dfun generic-function)))
2436
2437 ;;; This is the early version of GET-METHOD. See comments on the early
2438 ;;; version of ADD-METHOD.
2439 (defun get-method (generic-function qualifiers specializers
2440                                     &optional (errorp t))
2441   (if (early-gf-p generic-function)
2442       (or (dolist (m (early-gf-methods generic-function))
2443             (when (and (or (equal (early-method-specializers m nil)
2444                                   specializers)
2445                            (equal (early-method-specializers m t)
2446                                   specializers))
2447                        (equal (early-method-qualifiers m) qualifiers))
2448               (return m)))
2449           (if errorp
2450               (error "can't get early method")
2451               nil))
2452       (real-get-method generic-function qualifiers specializers errorp)))
2453
2454 (defun !fix-early-generic-functions ()
2455   (let ((accessors nil))
2456     ;; Rearrange *!EARLY-GENERIC-FUNCTIONS* to speed up
2457     ;; FIX-EARLY-GENERIC-FUNCTIONS.
2458     (dolist (early-gf-spec *!early-generic-functions*)
2459       (when (every #'early-method-standard-accessor-p
2460                    (early-gf-methods (gdefinition early-gf-spec)))
2461         (push early-gf-spec accessors)))
2462     (dolist (spec (nconc accessors
2463                          '(accessor-method-slot-name
2464                            generic-function-methods
2465                            method-specializers
2466                            specializerp
2467                            specializer-type
2468                            specializer-class
2469                            slot-definition-location
2470                            slot-definition-name
2471                            class-slots
2472                            gf-arg-info
2473                            class-precedence-list
2474                            slot-boundp-using-class
2475                            (setf slot-value-using-class)
2476                            slot-value-using-class
2477                            structure-class-p
2478                            standard-class-p
2479                            funcallable-standard-class-p
2480                            specializerp)))
2481       (/show spec)
2482       (setq *!early-generic-functions*
2483             (cons spec
2484                   (delete spec *!early-generic-functions* :test #'equal))))
2485
2486     (dolist (early-gf-spec *!early-generic-functions*)
2487       (/show early-gf-spec)
2488       (let* ((gf (gdefinition early-gf-spec))
2489              (methods (mapcar (lambda (early-method)
2490                                 (let ((args (copy-list (fifth
2491                                                         early-method))))
2492                                   (setf (fourth args)
2493                                         (early-method-specializers
2494                                          early-method t))
2495                                   (apply #'real-make-a-method args)))
2496                               (early-gf-methods gf))))
2497         (setf (generic-function-method-class gf) *the-class-standard-method*)
2498         (setf (generic-function-method-combination gf)
2499               *standard-method-combination*)
2500         (set-methods gf methods)))
2501
2502     (dolist (fn *!early-functions*)
2503       (/show fn)
2504       (setf (gdefinition (car fn)) (fdefinition (caddr fn))))
2505
2506     (dolist (fixup *!generic-function-fixups*)
2507       (/show fixup)
2508       (let* ((fspec (car fixup))
2509              (gf (gdefinition fspec))
2510              (methods (mapcar (lambda (method)
2511                                 (let* ((lambda-list (first method))
2512                                        (specializers (mapcar #'find-class (second method)))
2513                                        (method-fn-name (third method))
2514                                        (fn-name (or method-fn-name fspec))
2515                                        (fn (fdefinition fn-name))
2516                                        (initargs
2517                                         (list :function
2518                                               (set-fun-name
2519                                                (lambda (args next-methods)
2520                                                  (declare (ignore
2521                                                            next-methods))
2522                                                  (apply fn args))
2523                                                `(call ,fn-name)))))
2524                                   (declare (type function fn))
2525                                   (make-a-method 'standard-method
2526                                                  ()
2527                                                  lambda-list
2528                                                  specializers
2529                                                  initargs
2530                                                  nil)))
2531                               (cdr fixup))))
2532         (setf (generic-function-method-class gf) *the-class-standard-method*)
2533         (setf (generic-function-method-combination gf)
2534               *standard-method-combination*)
2535         (set-methods gf methods))))
2536   (/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
2537 \f
2538 ;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument
2539 ;;; into the 'real' arguments. This is where the syntax of DEFMETHOD
2540 ;;; is really implemented.
2541 (defun parse-defmethod (cdr-of-form)
2542   (declare (list cdr-of-form))
2543   (let ((name (pop cdr-of-form))
2544         (qualifiers ())
2545         (spec-ll ()))
2546     (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
2547               (push (pop cdr-of-form) qualifiers)
2548               (return (setq qualifiers (nreverse qualifiers)))))
2549     (setq spec-ll (pop cdr-of-form))
2550     (values name qualifiers spec-ll cdr-of-form)))
2551
2552 (defun parse-specializers (generic-function specializers)
2553   (declare (list specializers))
2554   (flet ((parse (spec)
2555            (parse-specializer-using-class generic-function spec)))
2556     (mapcar #'parse specializers)))
2557
2558 (defun unparse-specializers (generic-function specializers)
2559   (declare (list specializers))
2560   (flet ((unparse (spec)
2561            (unparse-specializer-using-class generic-function spec)))
2562     (mapcar #'unparse specializers)))
2563 \f
2564 (defun extract-parameters (specialized-lambda-list)
2565   (multiple-value-bind (parameters ignore1 ignore2)
2566       (parse-specialized-lambda-list specialized-lambda-list)
2567     (declare (ignore ignore1 ignore2))
2568     parameters))
2569
2570 (defun extract-lambda-list (specialized-lambda-list)
2571   (multiple-value-bind (ignore1 lambda-list ignore2)
2572       (parse-specialized-lambda-list specialized-lambda-list)
2573     (declare (ignore ignore1 ignore2))
2574     lambda-list))
2575
2576 (defun extract-specializer-names (specialized-lambda-list)
2577   (multiple-value-bind (ignore1 ignore2 specializers)
2578       (parse-specialized-lambda-list specialized-lambda-list)
2579     (declare (ignore ignore1 ignore2))
2580     specializers))
2581
2582 (defun extract-required-parameters (specialized-lambda-list)
2583   (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
2584       (parse-specialized-lambda-list specialized-lambda-list)
2585     (declare (ignore ignore1 ignore2 ignore3))
2586     required-parameters))
2587
2588 (define-condition specialized-lambda-list-error
2589     (reference-condition simple-program-error)
2590   ()
2591   (:default-initargs :references (list '(:ansi-cl :section (3 4 3)))))
2592
2593 (defun parse-specialized-lambda-list
2594     (arglist
2595      &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux))
2596      &aux (specialized-lambda-list-keywords
2597            '(&optional &rest &key &allow-other-keys &aux)))
2598   (let ((arg (car arglist)))
2599     (cond ((null arglist) (values nil nil nil nil))
2600           ((eq arg '&aux)
2601            (values nil arglist nil nil))
2602           ((memq arg lambda-list-keywords)
2603            ;; non-standard lambda-list-keywords are errors.
2604            (unless (memq arg specialized-lambda-list-keywords)
2605              (error 'specialized-lambda-list-error
2606                     :format-control "unknown specialized-lambda-list ~
2607                                      keyword ~S~%"
2608                     :format-arguments (list arg)))
2609            ;; no multiple &rest x &rest bla specifying
2610            (when (memq arg supplied-keywords)
2611              (error 'specialized-lambda-list-error
2612                     :format-control "multiple occurrence of ~
2613                                      specialized-lambda-list keyword ~S~%"
2614                     :format-arguments (list arg)))
2615            ;; And no placing &key in front of &optional, either.
2616            (unless (memq arg allowed-keywords)
2617              (error 'specialized-lambda-list-error
2618                     :format-control "misplaced specialized-lambda-list ~
2619                                      keyword ~S~%"
2620                     :format-arguments (list arg)))
2621            ;; When we are at a lambda-list keyword, the parameters
2622            ;; don't include the lambda-list keyword; the lambda-list
2623            ;; does include the lambda-list keyword; and no
2624            ;; specializers are allowed to follow the lambda-list
2625            ;; keywords (at least for now).
2626            (multiple-value-bind (parameters lambda-list)
2627                (parse-specialized-lambda-list (cdr arglist)
2628                                               (cons arg supplied-keywords)
2629                                               (if (eq arg '&key)
2630                                                   (cons '&allow-other-keys
2631                                                         (cdr (member arg allowed-keywords)))
2632                                                 (cdr (member arg allowed-keywords))))
2633              (when (and (eq arg '&rest)
2634                         (or (null lambda-list)
2635                             (memq (car lambda-list)
2636                                   specialized-lambda-list-keywords)
2637                             (not (or (null (cadr lambda-list))
2638                                      (memq (cadr lambda-list)
2639                                            specialized-lambda-list-keywords)))))
2640                (error 'specialized-lambda-list-error
2641                       :format-control
2642                       "in a specialized-lambda-list, excactly one ~
2643                        variable must follow &REST.~%"
2644                       :format-arguments nil))
2645              (values parameters
2646                      (cons arg lambda-list)
2647                      ()
2648                      ())))
2649           (supplied-keywords
2650            ;; After a lambda-list keyword there can be no specializers.
2651            (multiple-value-bind (parameters lambda-list)
2652                (parse-specialized-lambda-list (cdr arglist)
2653                                               supplied-keywords
2654                                               allowed-keywords)
2655              (values (cons (if (listp arg) (car arg) arg) parameters)
2656                      (cons arg lambda-list)
2657                      ()
2658                      ())))
2659           (t
2660            (multiple-value-bind (parameters lambda-list specializers required)
2661                (parse-specialized-lambda-list (cdr arglist))
2662              (values (cons (if (listp arg) (car arg) arg) parameters)
2663                      (cons (if (listp arg) (car arg) arg) lambda-list)
2664                      (cons (if (listp arg) (cadr arg) t) specializers)
2665                      (cons (if (listp arg) (car arg) arg) required)))))))
2666 \f
2667 (setq *boot-state* 'early)
2668 \f
2669 ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
2670 ;;; which used %WALKER stuff. That suggests to me that maybe the code
2671 ;;; walker stuff was only used for implementing stuff like that; maybe
2672 ;;; it's not needed any more? Hunt down what it was used for and see.
2673
2674 (defmacro with-slots (slots instance &body body)
2675   (let ((in (gensym)))
2676     `(let ((,in ,instance))
2677        (declare (ignorable ,in))
2678        ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
2679                              (third instance)
2680                              instance)))
2681            (and (symbolp instance)
2682                 `((declare (%variable-rebinding ,in ,instance)))))
2683        ,in
2684        (symbol-macrolet ,(mapcar (lambda (slot-entry)
2685                                    (let ((var-name
2686                                           (if (symbolp slot-entry)
2687                                               slot-entry
2688                                               (car slot-entry)))
2689                                          (slot-name
2690                                           (if (symbolp slot-entry)
2691                                               slot-entry
2692                                               (cadr slot-entry))))
2693                                      `(,var-name
2694                                        (slot-value ,in ',slot-name))))
2695                                  slots)
2696                         ,@body))))
2697
2698 (defmacro with-accessors (slots instance &body body)
2699   (let ((in (gensym)))
2700     `(let ((,in ,instance))
2701        (declare (ignorable ,in))
2702        ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
2703                              (third instance)
2704                              instance)))
2705            (and (symbolp instance)
2706                 `((declare (%variable-rebinding ,in ,instance)))))
2707        ,in
2708        (symbol-macrolet ,(mapcar (lambda (slot-entry)
2709                                    (let ((var-name (car slot-entry))
2710                                          (accessor-name (cadr slot-entry)))
2711                                      `(,var-name (,accessor-name ,in))))
2712                                  slots)
2713           ,@body))))