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 ;;; FIXME: As of sbcl-0.6.9.10, PCL still uses this nonstandard type
  72 ;;; of declaration internally. It would be good to figure out how to
  73 ;;; get rid of it, or failing that, (1) document why it's needed and
  74 ;;; (2) use a private symbol with a forbidding name which suggests
  75 ;;; it's not to be messed with by the user (e.g. SB-PCL:%CLASS)
  76 ;;; instead of the too-inviting CLASS. (I tried just deleting the
  77 ;;; declarations in MAKE-METHOD-LAMBDA-INTERNAL ca. sbcl-0.6.9.10, but
  78 ;;; then things break.)
  79 (declaim (declaration class))
  80
  81 ;;; FIXME: SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY-HOOK shouldn't be a
  82 ;;; separate function. Instead, we should define a simple placeholder
  83 ;;; version of SB-PCL:CHECK-WRAPPER-VALIDITY where
  84 ;;; SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY is defined now, then just
  85 ;;; let the later real PCL DEFUN of SB-PCL:CHECK-WRAPPER-VALIDITY
  86 ;;; overwrite it.
  87 (setf (symbol-function 'sb-kernel::pcl-check-wrapper-validity-hook)
  88       #'check-wrapper-validity)
  89
  90 (declaim (notinline make-a-method
  91                     add-named-method
  92                     ensure-generic-function-using-class
  93
  94                     add-method
  95                     remove-method))
  96
  97 (defvar *!early-functions*
  98         '((make-a-method early-make-a-method
  99                          real-make-a-method)
 100           (add-named-method early-add-named-method
 101                             real-add-named-method)
 102           ))
 103
 104 ;;; For each of the early functions, arrange to have it point to its early
 105 ;;; definition. Do this in a way that makes sure that if we redefine one
 106 ;;; of the early definitions the redefinition will take effect. This makes
 107 ;;; development easier.
 108 ;;;
 109 ;;; The function which generates the redirection closure is pulled out into
 110 ;;; a separate piece of code because of a bug in ExCL which causes this not
 111 ;;; to work if it is inlined.
 112 ;;; FIXME: We no longer need to worry about ExCL now, so we could unscrew this.
 113 (eval-when (:load-toplevel :execute)
 114
 115 (defun redirect-early-function-internal (real early)
 116   (setf (gdefinition real)
 117         (set-function-name
 118          #'(lambda (&rest args)
 119              (apply (the function (symbol-function early)) args))
 120          real)))
 121
 122 (dolist (fns *!early-functions*)
 123   (let ((name (car fns))
 124         (early-name (cadr fns)))
 125     (redirect-early-function-internal name early-name)))
 126
 127 ) ; EVAL-WHEN
 128
 129 ;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
 130 ;;; to convert the few functions in the bootstrap which are supposed
 131 ;;; to be generic functions but can't be early on.
 132 (defvar *!generic-function-fixups*
 133   '((add-method
 134      ((generic-function method)  ;lambda-list
 135       (standard-generic-function method) ;specializers
 136       real-add-method))          ;method-function
 137     (remove-method
 138      ((generic-function method)
 139       (standard-generic-function method)
 140       real-remove-method))
 141     (get-method
 142      ((generic-function qualifiers specializers &optional (errorp t))
 143       (standard-generic-function t t)
 144       real-get-method))
 145     (ensure-generic-function-using-class
 146      ((generic-function function-name
 147                         &key generic-function-class environment
 148                         &allow-other-keys)
 149       (generic-function t)
 150       real-ensure-gf-using-class--generic-function)
 151      ((generic-function function-name
 152                         &key generic-function-class environment
 153                         &allow-other-keys)
 154       (null t)
 155       real-ensure-gf-using-class--null))
 156     (make-method-lambda
 157      ((proto-generic-function proto-method lambda-expression environment)
 158       (standard-generic-function standard-method t t)
 159       real-make-method-lambda))
 160     (make-method-initargs-form
 161      ((proto-generic-function proto-method
 162                               lambda-expression
 163                               lambda-list environment)
 164       (standard-generic-function standard-method t t t)
 165       real-make-method-initargs-form))
 166     (compute-effective-method
 167      ((generic-function combin applicable-methods)
 168       (generic-function standard-method-combination t)
 169       standard-compute-effective-method))))
 170 \f
 171 (defmacro defgeneric (function-name lambda-list &body options)
 172   (expand-defgeneric function-name lambda-list options))
 173
 174 (defun expand-defgeneric (function-name lambda-list options)
 175   (when (listp function-name)
 176     (do-standard-defsetf-1 (sb-int:function-name-block-name function-name)))
 177   (let ((initargs ())
 178         (methods ()))
 179     (flet ((duplicate-option (name)
 180              (error 'sb-kernel:simple-program-error
 181                     :format-control "The option ~S appears more than once."
 182                     :format-arguments (list name)))
 183            (expand-method-definition (qab) ; QAB = qualifiers, arglist, body
 184              (let* ((arglist-pos (position-if #'listp qab))
 185                     (arglist (elt qab arglist-pos))
 186                     (qualifiers (subseq qab 0 arglist-pos))
 187                     (body (nthcdr (1+ arglist-pos) qab)))
 188                (when (not (equal (cadr (getf initargs :method-combination))
 189                                  qualifiers))
 190                  (error "bad method specification in DEFGENERIC ~A~%~
 191                          -- qualifier mismatch for lambda list ~A"
 192                         function-name arglist))
 193                `(defmethod ,function-name ,@qualifiers ,arglist ,@body))))
 194       (macrolet ((initarg (key) `(getf initargs ,key)))
 195         (dolist (option options)
 196           (let ((car-option (car option)))
 197             (case car-option
 198               (declare
 199                (push (cdr option) (initarg :declarations)))
 200               ((:argument-precedence-order :method-combination)
 201                (if (initarg car-option)
 202                    (duplicate-option car-option)
 203                    (setf (initarg car-option)
 204                          `',(cdr option))))
 205               ((:documentation :generic-function-class :method-class)
 206                (unless (sb-int:proper-list-of-length-p option 2)
 207                  (error "bad list length for ~S" option))
 208                (if (initarg car-option)
 209                    (duplicate-option car-option)
 210                    (setf (initarg car-option) `',(cadr option))))
 211               (:method
 212                (push (cdr option) methods))
 213               (t
 214                ;; ANSI requires that unsupported things must get a
 215                ;; PROGRAM-ERROR.
 216                (error 'sb-kernel:simple-program-error
 217                       :format-control "unsupported option ~S"
 218                       :format-arguments (list option))))))
 219
 220         (when (initarg :declarations)
 221           (setf (initarg :declarations)
 222                 `',(initarg :declarations))))
 223       `(progn
 224          (eval-when (:compile-toplevel :load-toplevel :execute)
 225            (compile-or-load-defgeneric ',function-name))
 226          ,(make-top-level-form
 227            `(defgeneric ,function-name)
 228            *defgeneric-times*
 229            `(load-defgeneric ',function-name ',lambda-list ,@initargs))
 230          ,@(mapcar #'expand-method-definition methods)
 231          `,(function ,function-name)))))
 232
 233 (defun compile-or-load-defgeneric (function-name)
 234   (sb-kernel:proclaim-as-function-name function-name)
 235   (sb-kernel:note-name-defined function-name :function)
 236   (unless (eq (sb-int:info :function :where-from function-name) :declared)
 237     (setf (sb-int:info :function :where-from function-name) :defined)
 238     (setf (sb-int:info :function :type function-name)
 239           (sb-kernel:specifier-type 'function))))
 240
 241 (defun load-defgeneric (function-name lambda-list &rest initargs)
 242   (when (listp function-name)
 243     (do-standard-defsetf-1 (cadr function-name)))
 244   (when (fboundp function-name)
 245     (sb-kernel::style-warn "redefining ~S in DEFGENERIC" function-name))
 246   (apply #'ensure-generic-function
 247          function-name
 248          :lambda-list lambda-list
 249          :definition-source `((defgeneric ,function-name)
 250                               ,*load-truename*)
 251          initargs))
 252 \f
 253 (defmacro defmethod (&rest args &environment env)
 254   (declare (arglist name
 255                     {method-qualifier}*
 256                     specialized-lambda-list
 257                     &body body))
 258   (multiple-value-bind (name qualifiers lambda-list body)
 259       (parse-defmethod args)
 260     (multiple-value-bind (proto-gf proto-method)
 261         (prototypes-for-make-method-lambda name)
 262       (expand-defmethod name
 263                         proto-gf
 264                         proto-method
 265                         qualifiers
 266                         lambda-list
 267                         body
 268                         env))))
 269
 270 (defun prototypes-for-make-method-lambda (name)
 271   (if (not (eq *boot-state* 'complete))
 272       (values nil nil)
 273       (let ((gf? (and (gboundp name)
 274                       (gdefinition name))))
 275         (if (or (null gf?)
 276                 (not (generic-function-p gf?)))
 277             (values (class-prototype (find-class 'standard-generic-function))
 278                     (class-prototype (find-class 'standard-method)))
 279             (values gf?
 280                     (class-prototype (or (generic-function-method-class gf?)
 281                                          (find-class 'standard-method))))))))
 282
 283 ;;; Take a name which is either a generic function name or a list specifying
 284 ;;; a SETF generic function (like: (SETF <generic-function-name>)). Return
 285 ;;; the prototype instance of the method-class for that generic function.
 286 ;;;
 287 ;;; If there is no generic function by that name, this returns the
 288 ;;; default value, the prototype instance of the class
 289 ;;; STANDARD-METHOD. This default value is also returned if the spec
 290 ;;; names an ordinary function or even a macro. In effect, this leaves
 291 ;;; the signalling of the appropriate error until load time.
 292 ;;;
 293 ;;; Note: During bootstrapping, this function is allowed to return NIL.
 294 (defun method-prototype-for-gf (name)
 295   (let ((gf? (and (gboundp name)
 296                   (gdefinition name))))
 297     (cond ((neq *boot-state* 'complete) nil)
 298           ((or (null gf?)
 299                (not (generic-function-p gf?)))          ; Someone else MIGHT
 300                                                         ; error at load time.
 301            (class-prototype (find-class 'standard-method)))
 302           (t
 303             (class-prototype (or (generic-function-method-class gf?)
 304                                  (find-class 'standard-method)))))))
 305 \f
 306 (defvar *optimize-asv-funcall-p* nil)
 307 (defvar *asv-readers*)
 308 (defvar *asv-writers*)
 309 (defvar *asv-boundps*)
 310
 311 (defun expand-defmethod (name
 312                          proto-gf
 313                          proto-method
 314                          qualifiers
 315                          lambda-list
 316                          body
 317                          env)
 318   (when (listp name)
 319     (do-standard-defsetf-1 (cadr name)))
 320   (let ((*make-instance-function-keys* nil)
 321         (*optimize-asv-funcall-p* t)
 322         (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil))
 323     (declare (special *make-instance-function-keys*))
 324     (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
 325         (add-method-declarations name qualifiers lambda-list body env)
 326       (multiple-value-bind (method-function-lambda initargs)
 327           (make-method-lambda proto-gf proto-method method-lambda env)
 328         (let ((initargs-form (make-method-initargs-form proto-gf
 329                                                         proto-method
 330                                                         method-function-lambda
 331                                                         initargs
 332                                                         env)))
 333           `(progn
 334              ;; Note: We could DECLAIM the ftype of the generic
 335              ;; function here, since ANSI specifies that we create it
 336              ;; if it does not exist. However, I chose not to, because
 337              ;; I think it's more useful to support a style of
 338              ;; programming where every generic function has an
 339              ;; explicit DEFGENERIC and any typos in DEFMETHODs are
 340              ;; warned about. Otherwise
 341              ;;   (DEFGENERIC FOO-BAR-BLETCH ((X T)))
 342              ;;   (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
 343              ;;   (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
 344              ;;   (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
 345              ;;   (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
 346              ;;   (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
 347              ;; compiles without raising an error and runs without
 348              ;; raising an error (since SIMPLE-VECTOR cases fall
 349              ;; through to VECTOR) but still doesn't do what was
 350              ;; intended. I hate that kind of bug (code which silently
 351              ;; gives the wrong answer), so we don't do a DECLAIM
 352              ;; here. -- WHN 20000229
 353              ,@(when *make-instance-function-keys*
 354                  `((get-make-instance-functions
 355                     ',*make-instance-function-keys*)))
 356              ,@(when (or *asv-readers* *asv-writers* *asv-boundps*)
 357                  `((initialize-internal-slot-gfs*
 358                     ',*asv-readers* ',*asv-writers* ',*asv-boundps*)))
 359              ,(make-defmethod-form name qualifiers specializers
 360                                    unspecialized-lambda-list
 361                                    (if proto-method
 362                                        (class-name (class-of proto-method))
 363                                        'standard-method)
 364                                    initargs-form
 365                                    (getf (getf initargs ':plist)
 366                                          ':pv-table-symbol))))))))
 367
 368 (defun interned-symbol-p (x)
 369   (and (symbolp x) (symbol-package x)))
 370
 371 (defun make-defmethod-form (name qualifiers specializers
 372                                  unspecialized-lambda-list method-class-name
 373                                  initargs-form &optional pv-table-symbol)
 374   (let (fn
 375         fn-lambda)
 376     (if (and (interned-symbol-p (sb-int:function-name-block-name name))
 377              (every #'interned-symbol-p qualifiers)
 378              (every #'(lambda (s)
 379                         (if (consp s)
 380                             (and (eq (car s) 'eql)
 381                                  (constantp (cadr s))
 382                                  (let ((sv (eval (cadr s))))
 383                                    (or (interned-symbol-p sv)
 384                                        (integerp sv)
 385                                        (and (characterp sv)
 386                                             (standard-char-p sv)))))
 387                             (interned-symbol-p s)))
 388                     specializers)
 389              (consp initargs-form)
 390              (eq (car initargs-form) 'list*)
 391              (memq (cadr initargs-form) '(:function :fast-function))
 392              (consp (setq fn (caddr initargs-form)))
 393              (eq (car fn) 'function)
 394              (consp (setq fn-lambda (cadr fn)))
 395              (eq (car fn-lambda) 'lambda))
 396         (let* ((specls (mapcar (lambda (specl)
 397                                  (if (consp specl)
 398                                      `(,(car specl) ,(eval (cadr specl)))
 399                                    specl))
 400                                specializers))
 401                (mname `(,(if (eq (cadr initargs-form) ':function)
 402                              'method 'fast-method)
 403                         ,name ,@qualifiers ,specls))
 404                (mname-sym (intern (let ((*print-pretty* nil)
 405                                         ;; (We bind *PACKAGE* to
 406                                         ;; KEYWORD here as a way to
 407                                         ;; force symbols to be printed
 408                                         ;; with explicit package
 409                                         ;; prefixes.)
 410                                         (*package* sb-int:*keyword-package*))
 411                                     (format nil "~S" mname)))))
 412           `(eval-when ,*defmethod-times*
 413             (defun ,mname-sym ,(cadr fn-lambda)
 414               ,@(cddr fn-lambda))
 415             ,(make-defmethod-form-internal
 416               name qualifiers `',specls
 417               unspecialized-lambda-list method-class-name
 418               `(list* ,(cadr initargs-form)
 419                       #',mname-sym
 420                       ,@(cdddr initargs-form))
 421               pv-table-symbol)))
 422         (make-top-level-form
 423          `(defmethod ,name ,@qualifiers ,specializers)
 424          *defmethod-times*
 425          (make-defmethod-form-internal
 426           name qualifiers
 427           `(list ,@(mapcar #'(lambda (specializer)
 428                                (if (consp specializer)
 429                                    ``(,',(car specializer)
 430                                       ,,(cadr specializer))
 431                                    `',specializer))
 432                     specializers))
 433           unspecialized-lambda-list method-class-name
 434           initargs-form
 435           pv-table-symbol)))))
 436
 437 (defun make-defmethod-form-internal
 438     (name qualifiers specializers-form unspecialized-lambda-list
 439      method-class-name initargs-form &optional pv-table-symbol)
 440   `(load-defmethod
 441     ',method-class-name
 442     ',name
 443     ',qualifiers
 444     ,specializers-form
 445     ',unspecialized-lambda-list
 446     ,initargs-form
 447     ;; Paper over a bug in KCL by passing the cache-symbol here in
 448     ;; addition to in the list. FIXME: We should no longer need to do
 449     ;; this, since the CLOS code is now SBCL-specific, and doesn't
 450     ;; need to be ported to every buggy compiler in existence.
 451     ',pv-table-symbol))
 452
 453 (defmacro make-method-function (method-lambda &environment env)
 454   (make-method-function-internal method-lambda env))
 455
 456 (defun make-method-function-internal (method-lambda &optional env)
 457   (multiple-value-bind (proto-gf proto-method)
 458       (prototypes-for-make-method-lambda nil)
 459     (multiple-value-bind (method-function-lambda initargs)
 460         (make-method-lambda proto-gf proto-method method-lambda env)
 461       (make-method-initargs-form proto-gf
 462                                  proto-method
 463                                  method-function-lambda
 464                                  initargs
 465                                  env))))
 466
 467 (defun add-method-declarations (name qualifiers lambda-list body env)
 468   (multiple-value-bind (parameters unspecialized-lambda-list specializers)
 469       (parse-specialized-lambda-list lambda-list)
 470     (declare (ignore parameters))
 471     (multiple-value-bind (documentation declarations real-body)
 472         (extract-declarations body env)
 473       (values `(lambda ,unspecialized-lambda-list
 474                  ,@(when documentation `(,documentation))
 475                  (declare (method-name ,(list name qualifiers specializers)))
 476                  (declare (method-lambda-list ,@lambda-list))
 477                  ,@declarations
 478                  ,@real-body)
 479               unspecialized-lambda-list specializers))))
 480
 481 (defun real-make-method-initargs-form (proto-gf proto-method
 482                                        method-lambda initargs env)
 483   (declare (ignore proto-gf proto-method))
 484   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
 485     (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~
 486             is not a lambda form."
 487            method-lambda))
 488   (make-method-initargs-form-internal method-lambda initargs env))
 489
 490 (unless (fboundp 'make-method-initargs-form)
 491   (setf (gdefinition 'make-method-initargs-form)
 492         (symbol-function 'real-make-method-initargs-form)))
 493
 494 (defun real-make-method-lambda (proto-gf proto-method method-lambda env)
 495   (declare (ignore proto-gf proto-method))
 496   (make-method-lambda-internal method-lambda env))
 497
 498 (defun make-method-lambda-internal (method-lambda &optional env)
 499   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
 500     (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
 501             is not a lambda form."
 502            method-lambda))
 503   (multiple-value-bind (documentation declarations real-body)
 504       (extract-declarations (cddr method-lambda) env)
 505     (let* ((name-decl (get-declaration 'method-name declarations))
 506            (sll-decl (get-declaration 'method-lambda-list declarations))
 507            (method-name (when (consp name-decl) (car name-decl)))
 508            (generic-function-name (when method-name (car method-name)))
 509            (specialized-lambda-list (or sll-decl (cadr method-lambda))))
 510       (multiple-value-bind (parameters lambda-list specializers)
 511           (parse-specialized-lambda-list specialized-lambda-list)
 512         (let* ((required-parameters
 513                 (mapcar (lambda (r s) (declare (ignore s)) r)
 514                         parameters
 515                         specializers))
 516                (slots (mapcar #'list required-parameters))
 517                (calls (list nil))
 518                (class-declarations
 519                 `(declare
 520                   ;; FIXME: These nonstandard (DECLARE (SB-PCL::CLASS FOO BAR))
 521                   ;; declarations should go away but as of 0.6.9.10, it's not
 522                   ;; as simple as just deleting them.
 523                   ,@(remove nil
 524                             (mapcar (lambda (a s) (and (symbolp s)
 525                                                        (neq s 't)
 526                                                        `(class ,a ,s)))
 527                                     parameters
 528                                     specializers))
 529                   ;; These TYPE declarations weren't in the original
 530                   ;; PCL code, but Python likes them a lot. (We're
 531                   ;; telling the compiler about our knowledge of
 532                   ;; specialized argument types so that it can avoid
 533                   ;; run-time type overhead, which can be a big win
 534                   ;; for Python.)
 535                   ,@(mapcar (lambda (a s)
 536                               (cond ((and (consp s)
 537                                           (eql (car s) 'eql))
 538                                      ;; KLUDGE: ANSI, in its wisdom, says
 539                                      ;; that EQL-SPECIALIZER-FORMs in EQL
 540                                      ;; specializers are evaluated at
 541                                      ;; DEFMETHOD expansion time. Thus,
 542                                      ;; although one might think that in
 543                                      ;;   (DEFMETHOD FOO ((X PACKAGE)
 544                                      ;;                   (Y (EQL 12))
 545                                      ;;      ..))
 546                                      ;; the PACKAGE and (EQL 12) forms are
 547                                      ;; both parallel type names, they're
 548                                      ;; not, as is made clear when you do
 549                                      ;;   (DEFMETHOD FOO ((X PACKAGE)
 550                                      ;;                   (Y (EQL 'BAR)))
 551                                      ;;     ..)
 552                                      ;; where Y needs to be a symbol
 553                                      ;; named "BAR", not some cons made by
 554                                      ;; (CONS 'QUOTE 'BAR). I.e. when
 555                                      ;; the EQL-SPECIALIZER-FORM is (EQL 'X),
 556                                      ;; it requires an argument to be of
 557                                      ;; type (EQL X). It'd be easy to transform
 558                                      ;; one to the other, but it'd be somewhat
 559                                      ;; messier to do so while ensuring that
 560                                      ;; the EQL-SPECIALIZER-FORM is only
 561                                      ;; EVAL'd once. (The new code wouldn't
 562                                      ;; be messy, but it'd require a big
 563                                      ;; transformation of the old code.)
 564                                      ;; So instead we punt. -- WHN 20000610
 565                                      '(ignorable))
 566                                     ((not (eq *boot-state* 'complete))
 567                                      ;; KLUDGE: PCL, in its wisdom,
 568                                      ;; sometimes calls methods with
 569                                      ;; types which don't match their
 570                                      ;; specializers. (Specifically, it calls
 571                                      ;; ENSURE-CLASS-USING-CLASS (T NULL)
 572                                      ;; with a non-NULL second argument.)
 573                                      ;; Hopefully it only does this kind
 574                                      ;; of weirdness when bootstrapping..
 575                                      ;; -- WHN 20000610
 576                                      '(ignorable))
 577                                     (t
 578                                      ;; Otherwise, we can make Python
 579                                      ;; very happy.
 580                                      `(type ,s ,a))))
 581                             parameters
 582                             specializers)))
 583                (method-lambda
 584                 ;; Remove the documentation string and insert the
 585                 ;; appropriate class declarations. The documentation
 586                 ;; string is removed to make it easy for us to insert
 587                 ;; new declarations later, they will just go after the
 588                 ;; CADR of the method lambda. The class declarations
 589                 ;; are inserted to communicate the class of the method's
 590                 ;; arguments to the code walk.
 591                 `(lambda ,lambda-list
 592                    ;; The default ignorability of method parameters
 593                    ;; doesn't seem to be specified by ANSI. PCL had
 594                    ;; them basically ignorable but was a little
 595                    ;; inconsistent. E.g. even though the two
 596                    ;; method definitions
 597                    ;;   (DEFMETHOD FOO ((X T) (Y T)) "Z")
 598                    ;;   (DEFMETHOD FOO ((X T) Y) "Z")
 599                    ;; are otherwise equivalent, PCL treated Y as
 600                    ;; ignorable in the first definition but not in the
 601                    ;; second definition. We make all required
 602                    ;; parameters ignorable as a way of systematizing
 603                    ;; the old PCL behavior. -- WHN 2000-11-24
 604                    (declare (ignorable ,@required-parameters))
 605                    ,class-declarations
 606                    ,@declarations
 607                    (block ,(sb-int:function-name-block-name
 608                             generic-function-name)
 609                      ,@real-body)))
 610                (constant-value-p (and (null (cdr real-body))
 611                                       (constantp (car real-body))))
 612                (constant-value (and constant-value-p
 613                                     (eval (car real-body))))
 614                ;; FIXME: This can become a bare AND (no IF), just like
 615                ;; the expression for CONSTANT-VALUE just above.
 616                (plist (if (and constant-value-p
 617                                (or (typep constant-value
 618                                           '(or number character))
 619                                    (and (symbolp constant-value)
 620                                         (symbol-package constant-value))))
 621                           (list :constant-value constant-value)
 622                           ()))
 623                (applyp (dolist (p lambda-list nil)
 624                          (cond ((memq p '(&optional &rest &key))
 625                                 (return t))
 626                                ((eq p '&aux)
 627                                 (return nil))))))
 628           (multiple-value-bind
 629               (walked-lambda call-next-method-p closurep next-method-p-p)
 630               (walk-method-lambda method-lambda
 631                                   required-parameters
 632                                   env
 633                                   slots
 634                                   calls)
 635             (multiple-value-bind
 636                 (ignore walked-declarations walked-lambda-body)
 637                 (extract-declarations (cddr walked-lambda))
 638               (declare (ignore ignore))
 639               (when (or next-method-p-p call-next-method-p)
 640                 (setq plist (list* :needs-next-methods-p 't plist)))
 641               (when (some #'cdr slots)
 642                 (multiple-value-bind (slot-name-lists call-list)
 643                     (slot-name-lists-from-slots slots calls)
 644                   (let ((pv-table-symbol (make-symbol "pv-table")))
 645                     (setq plist
 646                           `(,@(when slot-name-lists
 647                                 `(:slot-name-lists ,slot-name-lists))
 648                               ,@(when call-list
 649                                   `(:call-list ,call-list))
 650                               :pv-table-symbol ,pv-table-symbol
 651                               ,@plist))
 652                     (setq walked-lambda-body
 653                           `((pv-binding (,required-parameters
 654                                          ,slot-name-lists
 655                                          ,pv-table-symbol)
 656                                         ,@walked-lambda-body))))))
 657               (when (and (memq '&key lambda-list)
 658                          (not (memq '&allow-other-keys lambda-list)))
 659                 (let ((aux (memq '&aux lambda-list)))
 660                 (setq lambda-list (nconc (ldiff lambda-list aux)
 661                                          (list '&allow-other-keys)
 662                                          aux))))
 663               (values `(lambda (.method-args. .next-methods.)
 664                          (simple-lexical-method-functions
 665                           (,lambda-list .method-args. .next-methods.
 666                                         :call-next-method-p
 667                                         ,call-next-method-p
 668                                         :next-method-p-p ,next-method-p-p
 669                                         :closurep ,closurep
 670                                         :applyp ,applyp)
 671                           ,@walked-declarations
 672                           ,@walked-lambda-body))
 673                       `(,@(when plist
 674                       `(:plist ,plist))
 675                           ,@(when documentation
 676                           `(:documentation ,documentation)))))))))))
 677
 678 (unless (fboundp 'make-method-lambda)
 679   (setf (gdefinition 'make-method-lambda)
 680         (symbol-function 'real-make-method-lambda)))
 681
 682 (defmacro simple-lexical-method-functions ((lambda-list
 683                                             method-args
 684                                             next-methods
 685                                             &rest lmf-options)
 686                                            &body body)
 687   `(progn
 688      ,method-args ,next-methods
 689      (bind-simple-lexical-method-macros (,method-args ,next-methods)
 690        (bind-lexical-method-functions (,@lmf-options)
 691          (bind-args (,lambda-list ,method-args)
 692            ,@body)))))
 693
 694 (defmacro fast-lexical-method-functions ((lambda-list
 695                                           next-method-call
 696                                           args
 697                                           rest-arg
 698                                           &rest lmf-options)
 699                                          &body body)
 700  `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
 701     (bind-lexical-method-functions (,@lmf-options)
 702       (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
 703         ,@body))))
 704
 705 (defmacro bind-simple-lexical-method-macros ((method-args next-methods)
 706                                              &body body)
 707   `(macrolet ((call-next-method-bind (&body body)
 708                 `(let ((.next-method. (car ,',next-methods))
 709                        (,',next-methods (cdr ,',next-methods)))
 710                    .next-method. ,',next-methods
 711                    ,@body))
 712               (call-next-method-body (cnm-args)
 713                 `(if .next-method.
 714                      (funcall (if (std-instance-p .next-method.)
 715                                   (method-function .next-method.)
 716                                   .next-method.) ; for early methods
 717                               (or ,cnm-args ,',method-args)
 718                               ,',next-methods)
 719                      (error "no next method")))
 720               (next-method-p-body ()
 721                 `(not (null .next-method.))))
 722      ,@body))
 723
 724 (defstruct method-call
 725   (function #'identity :type function)
 726   call-method-args)
 727
 728 #-sb-fluid (declaim (sb-ext:freeze-type method-call))
 729
 730 (defmacro invoke-method-call1 (function args cm-args)
 731   `(let ((.function. ,function)
 732          (.args. ,args)
 733          (.cm-args. ,cm-args))
 734      (if (and .cm-args. (null (cdr .cm-args.)))
 735          (funcall .function. .args. (car .cm-args.))
 736          (apply .function. .args. .cm-args.))))
 737
 738 (defmacro invoke-method-call (method-call restp &rest required-args+rest-arg)
 739   `(invoke-method-call1 (method-call-function ,method-call)
 740                         ,(if restp
 741                              `(list* ,@required-args+rest-arg)
 742                              `(list ,@required-args+rest-arg))
 743                         (method-call-call-method-args ,method-call)))
 744
 745 (defstruct fast-method-call
 746   (function #'identity :type function)
 747   pv-cell
 748   next-method-call
 749   arg-info)
 750
 751 #-sb-fluid (declaim (sb-ext:freeze-type fast-method-call))
 752
 753 (defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
 754   `(funcall ,fn ,pv-cell ,next-method-call ,@args))
 755
 756 (defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg)
 757   `(fmc-funcall (fast-method-call-function ,method-call)
 758                 (fast-method-call-pv-cell ,method-call)
 759                 (fast-method-call-next-method-call ,method-call)
 760                 ,@required-args+rest-arg))
 761
 762 (defstruct fast-instance-boundp
 763   (index 0 :type fixnum))
 764
 765 #-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp))
 766
 767 (eval-when (:compile-toplevel :load-toplevel :execute)
 768
 769 (defvar *allow-emf-call-tracing-p* nil)
 770 (defvar *enable-emf-call-tracing-p* #-testing nil #+testing t)
 771
 772 ) ; EVAL-WHEN
 773 \f
 774 ;;;; effective method functions
 775
 776 (defvar *emf-call-trace-size* 200)
 777 (defvar *emf-call-trace* nil)
 778 (defvar *emf-call-trace-index* 0)
 779
 780 ;;; This function was in the CMU CL version of PCL (ca Debian 2.4.8)
 781 ;;; without explanation. It appears to be intended for debugging, so
 782 ;;; it might be useful someday, so I haven't deleted it.
 783 ;;; But it isn't documented and isn't used for anything now, so
 784 ;;; I've conditionalized it out of the base system. -- WHN 19991213
 785 #+sb-show
 786 (defun show-emf-call-trace ()
 787   (when *emf-call-trace*
 788     (let ((j *emf-call-trace-index*)
 789           (*enable-emf-call-tracing-p* nil))
 790       (format t "~&(The oldest entries are printed first)~%")
 791       (dotimes-fixnum (i *emf-call-trace-size*)
 792         (let ((ct (aref *emf-call-trace* j)))
 793           (when ct (print ct)))
 794         (incf j)
 795         (when (= j *emf-call-trace-size*)
 796           (setq j 0))))))
 797
 798 (defun trace-emf-call-internal (emf format args)
 799   (unless *emf-call-trace*
 800     (setq *emf-call-trace* (make-array *emf-call-trace-size*)))
 801   (setf (aref *emf-call-trace* *emf-call-trace-index*)
 802         (list* emf format args))
 803   (incf *emf-call-trace-index*)
 804   (when (= *emf-call-trace-index* *emf-call-trace-size*)
 805     (setq *emf-call-trace-index* 0)))
 806
 807 (defmacro trace-emf-call (emf format args)
 808   (when *allow-emf-call-tracing-p*
 809     `(when *enable-emf-call-tracing-p*
 810        (trace-emf-call-internal ,emf ,format ,args))))
 811
 812 (defmacro invoke-effective-method-function-fast
 813     (emf restp &rest required-args+rest-arg)
 814   `(progn
 815      (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
 816      (invoke-fast-method-call ,emf ,@required-args+rest-arg)))
 817
 818 (defmacro invoke-effective-method-function (emf restp
 819                                                 &rest required-args+rest-arg)
 820   (unless (constantp restp)
 821     (error "The RESTP argument is not constant."))
 822   (setq restp (eval restp))
 823   `(progn
 824      (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
 825      (cond ((typep ,emf 'fast-method-call)
 826              (invoke-fast-method-call ,emf ,@required-args+rest-arg))
 827            ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
 828                `(((typep ,emf 'fixnum)
 829                   (let* ((.slots. (get-slots-or-nil
 830                                    ,(car required-args+rest-arg)))
 831                          (value (when .slots. (%instance-ref .slots. ,emf))))
 832                     (if (eq value +slot-unbound+)
 833                         (slot-unbound-internal ,(car required-args+rest-arg)
 834                                                ,emf)
 835                         value)))))
 836            ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
 837                `(((typep ,emf 'fixnum)
 838                   (let ((.new-value. ,(car required-args+rest-arg))
 839                         (.slots. (get-slots-or-nil
 840                                   ,(car required-args+rest-arg))))
 841                     (when .slots. ; just to avoid compiler warnings
 842                       (setf (%instance-ref .slots. ,emf) .new-value.))))))
 843            #||
 844            ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
 845                `(((typep ,emf 'fast-instance-boundp)
 846                   (let ((.slots. (get-slots-or-nil
 847                                   ,(car required-args+rest-arg))))
 848                     (and .slots.
 849                          (not (eq (%instance-ref
 850                                    .slots. (fast-instance-boundp-index ,emf))
 851                                   +slot-unbound+)))))))
 852            ||#
 853            (t
 854             (etypecase ,emf
 855               (method-call
 856                (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
 857               (function
 858                ,(if restp
 859                     `(apply (the function ,emf) ,@required-args+rest-arg)
 860                     `(funcall (the function ,emf)
 861                               ,@required-args+rest-arg))))))))
 862
 863 (defun invoke-emf (emf args)
 864   (trace-emf-call emf t args)
 865   (etypecase emf
 866     (fast-method-call
 867      (let* ((arg-info (fast-method-call-arg-info emf))
 868             (restp (cdr arg-info))
 869             (nreq (car arg-info)))
 870        (if restp
 871            (let* ((rest-args (nthcdr nreq args))
 872                   (req-args (ldiff args rest-args)))
 873              (apply (fast-method-call-function emf)
 874                     (fast-method-call-pv-cell emf)
 875                     (fast-method-call-next-method-call emf)
 876                     (nconc req-args (list rest-args))))
 877            (cond ((null args)
 878                   (if (eql nreq 0)
 879                       (invoke-fast-method-call emf)
 880                       (error "wrong number of args")))
 881                  ((null (cdr args))
 882                   (if (eql nreq 1)
 883                       (invoke-fast-method-call emf (car args))
 884                       (error "wrong number of args")))
 885                  ((null (cddr args))
 886                   (if (eql nreq 2)
 887                       (invoke-fast-method-call emf (car args) (cadr args))
 888                       (error "wrong number of args")))
 889                  (t
 890                   (apply (fast-method-call-function emf)
 891                          (fast-method-call-pv-cell emf)
 892                          (fast-method-call-next-method-call emf)
 893                          args))))))
 894     (method-call
 895      (apply (method-call-function emf)
 896             args
 897             (method-call-call-method-args emf)))
 898     (fixnum
 899      (cond ((null args) (error "1 or 2 args were expected."))
 900            ((null (cdr args))
 901             (let ((value (%instance-ref (get-slots (car args)) emf)))
 902               (if (eq value +slot-unbound+)
 903                   (slot-unbound-internal (car args) emf)
 904                   value)))
 905            ((null (cddr args))
 906             (setf (%instance-ref (get-slots (cadr args)) emf)
 907                   (car args)))
 908            (t (error "1 or 2 args were expected."))))
 909     (fast-instance-boundp
 910      (if (or (null args) (cdr args))
 911          (error "1 arg was expected.")
 912          (not (eq (%instance-ref (get-slots (car args))
 913                                  (fast-instance-boundp-index emf))
 914                   +slot-unbound+))))
 915     (function
 916      (apply emf args))))
 917
 918 ;; KLUDGE: A comment from the original PCL said "This can be improved alot."
 919 (defun gf-make-function-from-emf (gf emf)
 920   (etypecase emf
 921     (fast-method-call (let* ((arg-info (gf-arg-info gf))
 922                              (nreq (arg-info-number-required arg-info))
 923                              (restp (arg-info-applyp arg-info)))
 924                         #'(lambda (&rest args)
 925                             (trace-emf-call emf t args)
 926                             (apply (fast-method-call-function emf)
 927                                    (fast-method-call-pv-cell emf)
 928                                    (fast-method-call-next-method-call emf)
 929                                    (if restp
 930                                        (let* ((rest-args (nthcdr nreq args))
 931                                               (req-args (ldiff args
 932                                                                rest-args)))
 933                                          (nconc req-args rest-args))
 934                                        args)))))
 935     (method-call #'(lambda (&rest args)
 936                      (trace-emf-call emf t args)
 937                      (apply (method-call-function emf)
 938                             args
 939                             (method-call-call-method-args emf))))
 940     (function emf)))
 941 \f
 942 (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
 943                                            &body body)
 944   `(macrolet ((call-next-method-bind (&body body)
 945                 `(let () ,@body))
 946               (call-next-method-body (cnm-args)
 947                 `(if ,',next-method-call
 948                      ,(if (and (null ',rest-arg)
 949                                (consp cnm-args)
 950                                (eq (car cnm-args) 'list))
 951                           `(invoke-effective-method-function
 952                             ,',next-method-call nil
 953                             ,@(cdr cnm-args))
 954                           (let ((call `(invoke-effective-method-function
 955                                         ,',next-method-call
 956                                         ,',(not (null rest-arg))
 957                                         ,@',args
 958                                         ,@',(when rest-arg `(,rest-arg)))))
 959                             `(if ,cnm-args
 960                                  (bind-args ((,@',args
 961                                               ,@',(when rest-arg
 962                                                     `(&rest ,rest-arg)))
 963                                              ,cnm-args)
 964                                             ,call)
 965                                  ,call)))
 966                      (error "no next method")))
 967               (next-method-p-body ()
 968                 `(not (null ,',next-method-call))))
 969      ,@body))
 970
 971 (defmacro bind-lexical-method-functions
 972     ((&key call-next-method-p next-method-p-p closurep applyp)
 973      &body body)
 974   (cond ((and (null call-next-method-p) (null next-method-p-p)
 975               (null closurep)
 976               (null applyp))
 977          `(let () ,@body))
 978          ((and (null closurep)
 979                (null applyp))
 980          ;; OK to use MACROLET, and all args are mandatory
 981          ;; (else APPLYP would be true).
 982          `(call-next-method-bind
 983             (macrolet ((call-next-method (&rest cnm-args)
 984                          `(call-next-method-body ,(when cnm-args
 985                                                     `(list ,@cnm-args))))
 986                        (next-method-p ()
 987                          `(next-method-p-body)))
 988                ,@body)))
 989         (t
 990          `(call-next-method-bind
 991             (flet (,@(and call-next-method-p
 992                           '((call-next-method (&rest cnm-args)
 993                               (call-next-method-body cnm-args))))
 994                    ,@(and next-method-p-p
 995                           '((next-method-p ()
 996                               (next-method-p-body)))))
 997               ,@body)))))
 998
 999 (defmacro bind-args ((lambda-list args) &body body)
1000   (let ((args-tail '.args-tail.)
1001         (key '.key.)
1002         (state 'required))
1003     (flet ((process-var (var)
1004              (if (memq var lambda-list-keywords)
1005                  (progn
1006                    (case var
1007                      (&optional       (setq state 'optional))
1008                      (&key            (setq state 'key))
1009                      (&allow-other-keys)
1010                      (&rest           (setq state 'rest))
1011                      (&aux            (setq state 'aux))
1012                      (otherwise
1013                       (error
1014                        "encountered the non-standard lambda list keyword ~S"
1015                        var)))
1016                    nil)
1017                  (case state
1018                    (required `((,var (pop ,args-tail))))
1019                    (optional (cond ((not (consp var))
1020                                     `((,var (when ,args-tail
1021                                               (pop ,args-tail)))))
1022                                    ((null (cddr var))
1023                                     `((,(car var) (if ,args-tail
1024                                                       (pop ,args-tail)
1025                                                       ,(cadr var)))))
1026                                    (t
1027                                     `((,(caddr var) ,args-tail)
1028                                       (,(car var) (if ,args-tail
1029                                                       (pop ,args-tail)
1030                                                       ,(cadr var)))))))
1031                    (rest `((,var ,args-tail)))
1032                    (key (cond ((not (consp var))
1033                                `((,var (get-key-arg ,(sb-int:keywordicate var)
1034                                                     ,args-tail))))
1035                               ((null (cddr var))
1036                                (multiple-value-bind (keyword variable)
1037                                    (if (consp (car var))
1038                                        (values (caar var)
1039                                                (cadar var))
1040                                        (values (sb-int:keywordicate (car var))
1041                                                (car var)))
1042                                  `((,key (get-key-arg1 ',keyword ,args-tail))
1043                                    (,variable (if (consp ,key)
1044                                                   (car ,key)
1045                                                   ,(cadr var))))))
1046                               (t
1047                                (multiple-value-bind (keyword variable)
1048                                    (if (consp (car var))
1049                                        (values (caar var)
1050                                                (cadar var))
1051                                        (values (sb-int:keywordicate (car var))
1052                                                (car var)))
1053                                  `((,key (get-key-arg1 ',keyword ,args-tail))
1054                                    (,(caddr var) ,key)
1055                                    (,variable (if (consp ,key)
1056                                                   (car ,key)
1057                                                   ,(cadr var))))))))
1058                    (aux `(,var))))))
1059       (let ((bindings (mapcan #'process-var lambda-list)))
1060         `(let* ((,args-tail ,args)
1061                 ,@bindings)
1062            (declare (ignorable ,args-tail))
1063            ,@body)))))
1064
1065 (defun get-key-arg (keyword list)
1066   (loop (when (atom list) (return nil))
1067         (when (eq (car list) keyword) (return (cadr list)))
1068         (setq list (cddr list))))
1069
1070 (defun get-key-arg1 (keyword list)
1071   (loop (when (atom list) (return nil))
1072         (when (eq (car list) keyword) (return (cdr list)))
1073         (setq list (cddr list))))
1074
1075 (defun walk-method-lambda (method-lambda required-parameters env slots calls)
1076   (let ((call-next-method-p nil)   ; flag indicating that CALL-NEXT-METHOD
1077                                    ; should be in the method definition
1078         (closurep nil)             ; flag indicating that #'CALL-NEXT-METHOD
1079                                    ; was seen in the body of a method
1080         (next-method-p-p nil))     ; flag indicating that NEXT-METHOD-P
1081                                    ; should be in the method definition
1082     (flet ((walk-function (form context env)
1083              (cond ((not (eq context ':eval)) form)
1084                    ;; FIXME: Jumping to a conclusion from the way it's used
1085                    ;; above, perhaps CONTEXT should be called SITUATION
1086                    ;; (after the term used in the ANSI specification of
1087                    ;; EVAL-WHEN) and given modern ANSI keyword values
1088                    ;; like :LOAD-TOPLEVEL.
1089                    ((not (listp form)) form)
1090                    ((eq (car form) 'call-next-method)
1091                     (setq call-next-method-p 't)
1092                     form)
1093                    ((eq (car form) 'next-method-p)
1094                     (setq next-method-p-p 't)
1095                     form)
1096                    ((and (eq (car form) 'function)
1097                          (cond ((eq (cadr form) 'call-next-method)
1098                                 (setq call-next-method-p 't)
1099                                 (setq closurep t)
1100                                 form)
1101                                ((eq (cadr form) 'next-method-p)
1102                                 (setq next-method-p-p 't)
1103                                 (setq closurep t)
1104                                 form)
1105                                (t nil))))
1106                    (;; FIXME: should be MEMQ or FIND :TEST #'EQ
1107                     (and (or (eq (car form) 'slot-value)
1108                              (eq (car form) 'set-slot-value)
1109                              (eq (car form) 'slot-boundp))
1110                          (constantp (caddr form)))
1111                     (let ((parameter (can-optimize-access form
1112                                                           required-parameters
1113                                                           env)))
1114                       ;; FIXME: could be
1115                       ;;   (LET ((FUN (ECASE (CAR FORM) ..)))
1116                       ;;     (FUNCALL FUN SLOTS PARAMETER FORM))
1117                       (ecase (car form)
1118                         (slot-value
1119                          (optimize-slot-value     slots parameter form))
1120                         (set-slot-value
1121                          (optimize-set-slot-value slots parameter form))
1122                         (slot-boundp
1123                          (optimize-slot-boundp    slots parameter form)))))
1124                    ((and (eq (car form) 'apply)
1125                          (consp (cadr form))
1126                          (eq (car (cadr form)) 'function)
1127                          (generic-function-name-p (cadr (cadr form))))
1128                     (optimize-generic-function-call
1129                      form required-parameters env slots calls))
1130                    ((generic-function-name-p (car form))
1131                     (optimize-generic-function-call
1132                      form required-parameters env slots calls))
1133                    ((and (eq (car form) 'asv-funcall)
1134                          *optimize-asv-funcall-p*)
1135                     (case (fourth form)
1136                       (reader (push (third form) *asv-readers*))
1137                       (writer (push (third form) *asv-writers*))
1138                       (boundp (push (third form) *asv-boundps*)))
1139                     `(,(second form) ,@(cddddr form)))
1140                    (t form))))
1141
1142       (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
1143         (values walked-lambda
1144                 call-next-method-p
1145                 closurep
1146                 next-method-p-p)))))
1147
1148 (defun generic-function-name-p (name)
1149   (and (sb-int:legal-function-name-p name)
1150        (gboundp name)
1151        (if (eq *boot-state* 'complete)
1152            (standard-generic-function-p (gdefinition name))
1153            (funcallable-instance-p (gdefinition name)))))
1154 \f
1155 (defvar *method-function-plist* (make-hash-table :test 'eq))
1156 (defvar *mf1* nil)
1157 (defvar *mf1p* nil)
1158 (defvar *mf1cp* nil)
1159 (defvar *mf2* nil)
1160 (defvar *mf2p* nil)
1161 (defvar *mf2cp* nil)
1162
1163 (defun method-function-plist (method-function)
1164   (unless (eq method-function *mf1*)
1165     (rotatef *mf1* *mf2*)
1166     (rotatef *mf1p* *mf2p*)
1167     (rotatef *mf1cp* *mf2cp*))
1168   (unless (or (eq method-function *mf1*) (null *mf1cp*))
1169     (setf (gethash *mf1* *method-function-plist*) *mf1p*))
1170   (unless (eq method-function *mf1*)
1171     (setf *mf1* method-function
1172           *mf1cp* nil
1173           *mf1p* (gethash method-function *method-function-plist*)))
1174   *mf1p*)
1175
1176 (defun #-setf SETF\ SB-PCL\ METHOD-FUNCTION-PLIST
1177        #+setf (setf method-function-plist)
1178     (val method-function)
1179   (unless (eq method-function *mf1*)
1180     (rotatef *mf1* *mf2*)
1181     (rotatef *mf1cp* *mf2cp*)
1182     (rotatef *mf1p* *mf2p*))
1183   (unless (or (eq method-function *mf1*) (null *mf1cp*))
1184     (setf (gethash *mf1* *method-function-plist*) *mf1p*))
1185   (setf *mf1* method-function
1186         *mf1cp* t
1187         *mf1p* val))
1188
1189 (defun method-function-get (method-function key &optional default)
1190   (getf (method-function-plist method-function) key default))
1191
1192 (defun #-setf SETF\ SB-PCL\ METHOD-FUNCTION-GET
1193        #+setf (setf method-function-get)
1194     (val method-function key)
1195   (setf (getf (method-function-plist method-function) key) val))
1196
1197 (defun method-function-pv-table (method-function)
1198   (method-function-get method-function :pv-table))
1199
1200 (defun method-function-method (method-function)
1201   (method-function-get method-function :method))
1202
1203 (defun method-function-needs-next-methods-p (method-function)
1204   (method-function-get method-function :needs-next-methods-p t))
1205 \f
1206 (defmacro method-function-closure-generator (method-function)
1207   `(method-function-get ,method-function 'closure-generator))
1208
1209 (defun load-defmethod
1210     (class name quals specls ll initargs &optional pv-table-symbol)
1211   (when (listp name) (do-standard-defsetf-1 (cadr name)))
1212   (setq initargs (copy-tree initargs))
1213   (let ((method-spec (or (getf initargs ':method-spec)
1214                          (make-method-spec name quals specls))))
1215     (setf (getf initargs ':method-spec) method-spec)
1216     (record-definition 'method method-spec)
1217     (load-defmethod-internal class name quals specls
1218                              ll initargs pv-table-symbol)))
1219
1220 (defun load-defmethod-internal
1221     (method-class gf-spec qualifiers specializers lambda-list
1222                   initargs pv-table-symbol)
1223   (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
1224   (when pv-table-symbol
1225     (setf (getf (getf initargs ':plist) :pv-table-symbol)
1226           pv-table-symbol))
1227   ;; FIXME: It seems as though I should be able to get this to work.
1228   ;; But it keeps on screwing up PCL bootstrapping.
1229   #+nil
1230   (when (and (eq *boot-state* 'complete)
1231              (fboundp gf-spec))
1232     (let* ((gf (symbol-function gf-spec))
1233            (method (and (generic-function-p gf)
1234                         (find-method gf
1235                                      qualifiers
1236                                      (mapcar #'find-class specializers)
1237                                      nil))))
1238       (when method
1239         (sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
1240                                gf-spec qualifiers specializers))))
1241   (let ((method (apply #'add-named-method
1242                        gf-spec qualifiers specializers lambda-list
1243                        :definition-source `((defmethod ,gf-spec
1244                                                 ,@qualifiers
1245                                               ,specializers)
1246                                             ,*load-truename*)
1247                        initargs)))
1248     (unless (or (eq method-class 'standard-method)
1249                 (eq (find-class method-class nil) (class-of method)))
1250       ;; FIXME: should be STYLE-WARNING?
1251       (format *error-output*
1252               "~&At the time the method with qualifiers ~:S and~%~
1253                specializers ~:S on the generic function ~S~%~
1254                was compiled, the method-class for that generic function was~%~
1255                ~S. But, the method class is now ~S, this~%~
1256                may mean that this method was compiled improperly.~%"
1257               qualifiers specializers gf-spec
1258               method-class (class-name (class-of method))))
1259     method))
1260
1261 (defun make-method-spec (gf-spec qualifiers unparsed-specializers)
1262   `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
1263
1264 (defun initialize-method-function (initargs &optional return-function-p method)
1265   (let* ((mf (getf initargs ':function))
1266          (method-spec (getf initargs ':method-spec))
1267          (plist (getf initargs ':plist))
1268          (pv-table-symbol (getf plist ':pv-table-symbol))
1269          (pv-table nil)
1270          (mff (getf initargs ':fast-function)))
1271     (flet ((set-mf-property (p v)
1272              (when mf
1273                (setf (method-function-get mf p) v))
1274              (when mff
1275                (setf (method-function-get mff p) v))))
1276       (when method-spec
1277         (when mf
1278           (setq mf (set-function-name mf method-spec)))
1279         (when mff
1280           (let ((name `(,(or (get (car method-spec) 'fast-sym)
1281                              (setf (get (car method-spec) 'fast-sym)
1282                                    ;; KLUDGE: If we're going to be
1283                                    ;; interning private symbols in our
1284                                    ;; a this way, it would be cleanest
1285                                    ;; to use a separate package
1286                                    ;; %PCL-PRIVATE or something, and
1287                                    ;; failing that, to use a special
1288                                    ;; symbol prefix denoting privateness.
1289                                    ;; -- WHN 19991201
1290                                    (intern (format nil "FAST-~A"
1291                                                    (car method-spec))
1292                                            *pcl-package*)))
1293                          ,@(cdr method-spec))))
1294             (set-function-name mff name)
1295             (unless mf
1296               (set-mf-property :name name)))))
1297       (when plist
1298         (let ((snl (getf plist :slot-name-lists))
1299               (cl (getf plist :call-list)))
1300           (when (or snl cl)
1301             (setq pv-table (intern-pv-table :slot-name-lists snl
1302                                             :call-list cl))
1303             (when pv-table (set pv-table-symbol pv-table))
1304             (set-mf-property :pv-table pv-table)))
1305         (loop (when (null plist) (return nil))
1306               (set-mf-property (pop plist) (pop plist)))
1307         (when method
1308           (set-mf-property :method method))
1309         (when return-function-p
1310           (or mf (method-function-from-fast-function mff)))))))
1311 \f
1312 (defun analyze-lambda-list (lambda-list)
1313   (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
1314          (parse-keyword-argument (arg)
1315            (if (listp arg)
1316                (if (listp (car arg))
1317                    (caar arg)
1318                    (sb-int:keywordicate (car arg)))
1319                (sb-int:keywordicate arg))))
1320     (let ((nrequired 0)
1321           (noptional 0)
1322           (keysp nil)
1323           (restp nil)
1324           (allow-other-keys-p nil)
1325           (keywords ())
1326           (keyword-parameters ())
1327           (state 'required))
1328       (dolist (x lambda-list)
1329         (if (memq x lambda-list-keywords)
1330             (case x
1331               (&optional         (setq state 'optional))
1332               (&key           (setq keysp 't
1333                                        state 'key))
1334               (&allow-other-keys (setq allow-other-keys-p 't))
1335               (&rest         (setq restp 't
1336                                        state 'rest))
1337               (&aux           (return t))
1338               (otherwise
1339                 (error "encountered the non-standard lambda list keyword ~S" x)))
1340             (ecase state
1341               (required  (incf nrequired))
1342               (optional  (incf noptional))
1343               (key       (push (parse-keyword-argument x) keywords)
1344                          (push x keyword-parameters))
1345               (rest      ()))))
1346       (values nrequired noptional keysp restp allow-other-keys-p
1347               (reverse keywords)
1348               (reverse keyword-parameters)))))
1349
1350 (defun keyword-spec-name (x)
1351   (let ((key (if (atom x) x (car x))))
1352     (if (atom key)
1353         (intern (symbol-name key) sb-int:*keyword-package*)
1354         (car key))))
1355
1356 (defun ftype-declaration-from-lambda-list (lambda-list name)
1357   (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p
1358                                   keywords keyword-parameters)
1359       (analyze-lambda-list lambda-list)
1360     (declare (ignore keyword-parameters))
1361     (let* ((old (sb-c::info :function :type name)) ;FIXME:FDOCUMENTATION instead?
1362            (old-ftype (if (sb-c::function-type-p old) old nil))
1363            (old-restp (and old-ftype (sb-c::function-type-rest old-ftype)))
1364            (old-keys (and old-ftype
1365                           (mapcar #'sb-c::key-info-name
1366                                   (sb-c::function-type-keywords old-ftype))))
1367            (old-keysp (and old-ftype (sb-c::function-type-keyp old-ftype)))
1368            (old-allowp (and old-ftype (sb-c::function-type-allowp old-ftype)))
1369            (keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
1370       `(function ,(append (make-list nrequired :initial-element 't)
1371                           (when (plusp noptional)
1372                             (append '(&optional)
1373                                     (make-list noptional :initial-element 't)))
1374                           (when (or restp old-restp)
1375                             '(&rest t))
1376                           (when (or keysp old-keysp)
1377                             (append '(&key)
1378                                     (mapcar #'(lambda (key)
1379                                                 `(,key t))
1380                                             keywords)
1381                                     (when (or allow-other-keys-p old-allowp)
1382                                       '(&allow-other-keys)))))
1383                  *))))
1384
1385 (defun defgeneric-declaration (spec lambda-list)
1386   (when (consp spec)
1387     (setq spec (get-setf-function-name (cadr spec))))
1388   `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
1389 \f
1390 ;;;; early generic function support
1391
1392 (defvar *!early-generic-functions* ())
1393
1394 (defun ensure-generic-function (function-name
1395                                 &rest all-keys
1396                                 &key environment
1397                                 &allow-other-keys)
1398   (declare (ignore environment))
1399   (let ((existing (and (gboundp function-name)
1400                        (gdefinition function-name))))
1401     (if (and existing
1402              (eq *boot-state* 'complete)
1403              (null (generic-function-p existing)))
1404         (generic-clobbers-function function-name)
1405         (apply #'ensure-generic-function-using-class
1406                existing function-name all-keys))))
1407
1408 (defun generic-clobbers-function (function-name)
1409   (error 'sb-kernel:simple-program-error
1410          :format-control
1411          "~S already names an ordinary function or a macro."
1412          :format-arguments (list function-name)))
1413
1414 (defvar *sgf-wrapper*
1415   (boot-make-wrapper (early-class-size 'standard-generic-function)
1416                      'standard-generic-function))
1417
1418 (defvar *sgf-slots-init*
1419   (mapcar #'(lambda (canonical-slot)
1420               (if (memq (getf canonical-slot :name) '(arg-info source))
1421                   +slot-unbound+
1422                   (let ((initfunction (getf canonical-slot :initfunction)))
1423                     (if initfunction
1424                         (funcall initfunction)
1425                         +slot-unbound+))))
1426           (early-collect-inheritance 'standard-generic-function)))
1427
1428 (defvar *sgf-method-class-index*
1429   (bootstrap-slot-index 'standard-generic-function 'method-class))
1430
1431 (defun early-gf-p (x)
1432   (and (fsc-instance-p x)
1433        (eq (instance-ref (get-slots x) *sgf-method-class-index*)
1434            +slot-unbound+)))
1435
1436 (defvar *sgf-methods-index*
1437   (bootstrap-slot-index 'standard-generic-function 'methods))
1438
1439 (defmacro early-gf-methods (gf)
1440   `(instance-ref (get-slots ,gf) *sgf-methods-index*))
1441
1442 (defvar *sgf-arg-info-index*
1443   (bootstrap-slot-index 'standard-generic-function 'arg-info))
1444
1445 (defmacro early-gf-arg-info (gf)
1446   `(instance-ref (get-slots ,gf) *sgf-arg-info-index*))
1447
1448 (defvar *sgf-dfun-state-index*
1449   (bootstrap-slot-index 'standard-generic-function 'dfun-state))
1450
1451 (defstruct (arg-info
1452              (:conc-name nil)
1453              (:constructor make-arg-info ()))
1454   (arg-info-lambda-list :no-lambda-list)
1455   arg-info-precedence
1456   arg-info-metatypes
1457   arg-info-number-optional
1458   arg-info-key/rest-p
1459   arg-info-keywords ;nil        no keyword or rest allowed
1460                     ;(k1 k2 ..) each method must accept these keyword arguments
1461                     ;T    must have &key or &rest
1462
1463   gf-info-simple-accessor-type ; nil, reader, writer, boundp
1464   (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
1465
1466   gf-info-static-c-a-m-emf
1467   (gf-info-c-a-m-emf-std-p t)
1468   gf-info-fast-mf-p)
1469
1470 #-sb-fluid (declaim (sb-ext:freeze-type arg-info))
1471
1472 (defun arg-info-valid-p (arg-info)
1473   (not (null (arg-info-number-optional arg-info))))
1474
1475 (defun arg-info-applyp (arg-info)
1476   (or (plusp (arg-info-number-optional arg-info))
1477       (arg-info-key/rest-p arg-info)))
1478
1479 (defun arg-info-number-required (arg-info)
1480   (length (arg-info-metatypes arg-info)))
1481
1482 (defun arg-info-nkeys (arg-info)
1483   (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
1484
1485 ;;; Keep pages clean by not setting if the value is already the same.
1486 (defmacro esetf (pos val)
1487   (let ((valsym (gensym "value")))
1488     `(let ((,valsym ,val))
1489        (unless (equal ,pos ,valsym)
1490          (setf ,pos ,valsym)))))
1491
1492 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
1493                         argument-precedence-order)
1494   (let* ((arg-info (if (eq *boot-state* 'complete)
1495                        (gf-arg-info gf)
1496                        (early-gf-arg-info gf)))
1497          (methods (if (eq *boot-state* 'complete)
1498                       (generic-function-methods gf)
1499                       (early-gf-methods gf)))
1500          (was-valid-p (integerp (arg-info-number-optional arg-info)))
1501          (first-p (and new-method (null (cdr methods)))))
1502     (when (and (not lambda-list-p) methods)
1503       (setq lambda-list (gf-lambda-list gf)))
1504     (when (or lambda-list-p
1505               (and first-p
1506                    (eq (arg-info-lambda-list arg-info) ':no-lambda-list)))
1507       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1508           (analyze-lambda-list lambda-list)
1509         (when (and methods (not first-p))
1510           (let ((gf-nreq (arg-info-number-required arg-info))
1511                 (gf-nopt (arg-info-number-optional arg-info))
1512                 (gf-key/rest-p (arg-info-key/rest-p arg-info)))
1513             (unless (and (= nreq gf-nreq)
1514                          (= nopt gf-nopt)
1515                          (eq (or keysp restp) gf-key/rest-p))
1516               (error "The lambda-list ~S is incompatible with ~
1517                      existing methods of ~S."
1518                      lambda-list gf))))
1519         (when lambda-list-p
1520           (esetf (arg-info-lambda-list arg-info) lambda-list))
1521         (when (or lambda-list-p argument-precedence-order
1522                   (null (arg-info-precedence arg-info)))
1523           (esetf (arg-info-precedence arg-info)
1524                  (compute-precedence lambda-list nreq
1525                                      argument-precedence-order)))
1526         (esetf (arg-info-metatypes arg-info) (make-list nreq))
1527         (esetf (arg-info-number-optional arg-info) nopt)
1528         (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
1529         (esetf (arg-info-keywords arg-info)
1530                (if lambda-list-p
1531                    (if allow-other-keys-p t keywords)
1532                    (arg-info-key/rest-p arg-info)))))
1533     (when new-method
1534       (check-method-arg-info gf arg-info new-method))
1535     (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
1536     arg-info))
1537
1538 (defun check-method-arg-info (gf arg-info method)
1539   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1540       (analyze-lambda-list (if (consp method)
1541                                (early-method-lambda-list method)
1542                                (method-lambda-list method)))
1543     (flet ((lose (string &rest args)
1544              (error
1545               "attempt to add the method ~S to the generic function ~S.~%~
1546                But ~A"
1547               method
1548               gf
1549               (apply #'format nil string args)))
1550            (compare (x y)
1551              (if (> x y) "more" "fewer")))
1552       (let ((gf-nreq (arg-info-number-required arg-info))
1553             (gf-nopt (arg-info-number-optional arg-info))
1554             (gf-key/rest-p (arg-info-key/rest-p arg-info))
1555             (gf-keywords (arg-info-keywords arg-info)))
1556         (unless (= nreq gf-nreq)
1557           (lose
1558            "the method has ~A required arguments than the generic function."
1559            (compare nreq gf-nreq)))
1560         (unless (= nopt gf-nopt)
1561           (lose
1562            "the method has ~S optional arguments than the generic function."
1563            (compare nopt gf-nopt)))
1564         (unless (eq (or keysp restp) gf-key/rest-p)
1565           (error
1566            "The method and generic function differ in whether they accept~%~
1567             &REST or &KEY arguments."))
1568         (when (consp gf-keywords)
1569           (unless (or (and restp (not keysp))
1570                       allow-other-keys-p
1571                       (every #'(lambda (k) (memq k keywords)) gf-keywords))
1572             (lose "the method does not accept each of the keyword arguments~%~
1573                    ~S."
1574                   gf-keywords)))))))
1575
1576 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
1577   (let* ((existing-p (and methods (cdr methods) new-method))
1578          (nreq (length (arg-info-metatypes arg-info)))
1579          (metatypes (if existing-p
1580                         (arg-info-metatypes arg-info)
1581                         (make-list nreq)))
1582          (type (if existing-p
1583                    (gf-info-simple-accessor-type arg-info)
1584                    nil)))
1585     (when (arg-info-valid-p arg-info)
1586       (dolist (method (if new-method (list new-method) methods))
1587         (let* ((specializers (if (or (eq *boot-state* 'complete)
1588                                      (not (consp method)))
1589                                  (method-specializers method)
1590                                  (early-method-specializers method t)))
1591                (class (if (or (eq *boot-state* 'complete) (not (consp method)))
1592                           (class-of method)
1593                           (early-method-class method)))
1594                (new-type (when (and class
1595                                     (or (not (eq *boot-state* 'complete))
1596                                         (eq (generic-function-method-combination gf)
1597                                             *standard-method-combination*)))
1598                            (cond ((eq class *the-class-standard-reader-method*)
1599                                   'reader)
1600                                  ((eq class *the-class-standard-writer-method*)
1601                                   'writer)
1602                                  ((eq class *the-class-standard-boundp-method*)
1603                                   'boundp)))))
1604           (setq metatypes (mapcar #'raise-metatype metatypes specializers))
1605           (setq type (cond ((null type) new-type)
1606                            ((eq type new-type) type)
1607                            (t nil)))))
1608       (esetf (arg-info-metatypes arg-info) metatypes)
1609       (esetf (gf-info-simple-accessor-type arg-info) type)))
1610   (when (or (not was-valid-p) first-p)
1611     (multiple-value-bind (c-a-m-emf std-p)
1612         (if (early-gf-p gf)
1613             (values t t)
1614             (compute-applicable-methods-emf gf))
1615       (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
1616       (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p)
1617       (unless (gf-info-c-a-m-emf-std-p arg-info)
1618         (esetf (gf-info-simple-accessor-type arg-info) t))))
1619   (unless was-valid-p
1620     (let ((name (if (eq *boot-state* 'complete)
1621                     (generic-function-name gf)
1622                     (early-gf-name gf))))
1623       (esetf (gf-precompute-dfun-and-emf-p arg-info)
1624              (let* ((sym (if (atom name) name (cadr name)))
1625                     (pkg-list (cons *pcl-package*
1626                                     (package-use-list *pcl-package*))))
1627                (and sym (symbolp sym)
1628                     (not (null (memq (symbol-package sym) pkg-list)))
1629                     (not (find #\space (symbol-name sym))))))))
1630   (esetf (gf-info-fast-mf-p arg-info)
1631          (or (not (eq *boot-state* 'complete))
1632              (let* ((method-class (generic-function-method-class gf))
1633                     (methods (compute-applicable-methods
1634                               #'make-method-lambda
1635                               (list gf (class-prototype method-class)
1636                                     '(lambda) nil))))
1637                (and methods (null (cdr methods))
1638                     (let ((specls (method-specializers (car methods))))
1639                       (and (classp (car specls))
1640                            (eq 'standard-generic-function
1641                                (class-name (car specls)))
1642                            (classp (cadr specls))
1643                            (eq 'standard-method
1644                                (class-name (cadr specls)))))))))
1645   arg-info)
1646
1647 ;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS.
1648 ;;;
1649 ;;; The STATIC-SLOTS field of the funcallable instances used as early
1650 ;;; generic functions is used to store the early methods and early
1651 ;;; discriminator code for the early generic function. The static
1652 ;;; slots field of the fins contains a list whose:
1653 ;;;    CAR    -   a list of the early methods on this early gf
1654 ;;;    CADR   -   the early discriminator code for this method
1655 (defun ensure-generic-function-using-class (existing spec &rest keys
1656                                             &key (lambda-list nil lambda-list-p)
1657                                             &allow-other-keys)
1658   (declare (ignore keys))
1659   (cond ((and existing (early-gf-p existing))
1660          existing)
1661         ((assoc spec *!generic-function-fixups* :test #'equal)
1662          (if existing
1663              (make-early-gf spec lambda-list lambda-list-p existing)
1664              (error "The function ~S is not already defined." spec)))
1665         (existing
1666          (error "~S should be on the list ~S."
1667                 spec
1668                 '*!generic-function-fixups*))
1669         (t
1670          (pushnew spec *!early-generic-functions* :test #'equal)
1671          (make-early-gf spec lambda-list lambda-list-p))))
1672
1673 (defun make-early-gf (spec &optional lambda-list lambda-list-p function)
1674   (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
1675     (set-funcallable-instance-function
1676      fin
1677      (or function
1678          (if (eq spec 'print-object)
1679              #'(sb-kernel:instance-lambda (instance stream)
1680                  (print-unreadable-object (instance stream :identity t)
1681                    (format stream "std-instance")))
1682              #'(sb-kernel:instance-lambda (&rest args)
1683                  (declare (ignore args))
1684                  (error "The function of the funcallable-instance ~S~
1685                          has not been set." fin)))))
1686     (setf (gdefinition spec) fin)
1687     (bootstrap-set-slot 'standard-generic-function fin 'name spec)
1688     (bootstrap-set-slot 'standard-generic-function fin 'source *load-truename*)
1689     (set-function-name fin spec)
1690     (let ((arg-info (make-arg-info)))
1691       (setf (early-gf-arg-info fin) arg-info)
1692       (when lambda-list-p
1693         (proclaim (defgeneric-declaration spec lambda-list))
1694         (set-arg-info fin :lambda-list lambda-list)))
1695     fin))
1696
1697 (defun set-dfun (gf &optional dfun cache info)
1698   (when cache
1699     (setf (cache-owner cache) gf))
1700   (let ((new-state (if (and dfun (or cache info))
1701                        (list* dfun cache info)
1702                        dfun)))
1703     (if (eq *boot-state* 'complete)
1704         (setf (gf-dfun-state gf) new-state)
1705         (setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state)))
1706   dfun)
1707
1708 (defun gf-dfun-cache (gf)
1709   (let ((state (if (eq *boot-state* 'complete)
1710                    (gf-dfun-state gf)
1711                    (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
1712     (typecase state
1713       (function nil)
1714       (cons (cadr state)))))
1715
1716 (defun gf-dfun-info (gf)
1717   (let ((state (if (eq *boot-state* 'complete)
1718                    (gf-dfun-state gf)
1719                    (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
1720     (typecase state
1721       (function nil)
1722       (cons (cddr state)))))
1723
1724 (defvar *sgf-name-index*
1725   (bootstrap-slot-index 'standard-generic-function 'name))
1726
1727 (defun early-gf-name (gf)
1728   (instance-ref (get-slots gf) *sgf-name-index*))
1729
1730 (defun gf-lambda-list (gf)
1731   (let ((arg-info (if (eq *boot-state* 'complete)
1732                       (gf-arg-info gf)
1733                       (early-gf-arg-info gf))))
1734     (if (eq ':no-lambda-list (arg-info-lambda-list arg-info))
1735         (let ((methods (if (eq *boot-state* 'complete)
1736                            (generic-function-methods gf)
1737                            (early-gf-methods gf))))
1738           (if (null methods)
1739               (progn
1740                 (warn "no way to determine the lambda list for ~S" gf)
1741                 nil)
1742               (let* ((method (car (last methods)))
1743                      (ll (if (consp method)
1744                              (early-method-lambda-list method)
1745                              (method-lambda-list method)))
1746                      (k (member '&key ll)))
1747                 (if k
1748                     (append (ldiff ll (cdr k)) '(&allow-other-keys))
1749                     ll))))
1750         (arg-info-lambda-list arg-info))))
1751
1752 (defmacro real-ensure-gf-internal (gf-class all-keys env)
1753   `(progn
1754      (cond ((symbolp ,gf-class)
1755             (setq ,gf-class (find-class ,gf-class t ,env)))
1756            ((classp ,gf-class))
1757            (t
1758             (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
1759                     class nor a symbol that names a class."
1760                    ,gf-class)))
1761      (remf ,all-keys :generic-function-class)
1762      (remf ,all-keys :environment)
1763      (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
1764        (unless (eq combin '.shes-not-there.)
1765          (setf (getf ,all-keys :method-combination)
1766                (find-method-combination (class-prototype ,gf-class)
1767                                         (car combin)
1768                                         (cdr combin)))))))
1769
1770 (defun real-ensure-gf-using-class--generic-function
1771        (existing
1772         function-name
1773         &rest all-keys
1774         &key environment (lambda-list nil lambda-list-p)
1775              (generic-function-class 'standard-generic-function gf-class-p)
1776         &allow-other-keys)
1777   (real-ensure-gf-internal generic-function-class all-keys environment)
1778   (unless (or (null gf-class-p)
1779               (eq (class-of existing) generic-function-class))
1780     (change-class existing generic-function-class))
1781   (prog1
1782       (apply #'reinitialize-instance existing all-keys)
1783     (when lambda-list-p
1784       (proclaim (defgeneric-declaration function-name lambda-list)))))
1785
1786 (defun real-ensure-gf-using-class--null
1787        (existing
1788         function-name
1789         &rest all-keys
1790         &key environment (lambda-list nil lambda-list-p)
1791              (generic-function-class 'standard-generic-function)
1792         &allow-other-keys)
1793   (declare (ignore existing))
1794   (real-ensure-gf-internal generic-function-class all-keys environment)
1795   (prog1
1796       (setf (gdefinition function-name)
1797             (apply #'make-instance generic-function-class
1798                    :name function-name all-keys))
1799     (when lambda-list-p
1800       (proclaim (defgeneric-declaration function-name lambda-list)))))
1801 \f
1802 (defun get-generic-function-info (gf)
1803   ;; values   nreq applyp metatypes nkeys arg-info
1804   (multiple-value-bind (applyp metatypes arg-info)
1805       (let* ((arg-info (if (early-gf-p gf)
1806                            (early-gf-arg-info gf)
1807                            (gf-arg-info gf)))
1808              (metatypes (arg-info-metatypes arg-info)))
1809         (values (arg-info-applyp arg-info)
1810                 metatypes
1811                 arg-info))
1812     (values (length metatypes) applyp metatypes
1813             (count-if #'(lambda (x) (neq x 't)) metatypes)
1814             arg-info)))
1815
1816 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
1817                             &optional slot-name)
1818   (initialize-method-function initargs)
1819   (let ((parsed ())
1820         (unparsed ()))
1821     ;; Figure out whether we got class objects or class names as the
1822     ;; specializers and set parsed and unparsed appropriately. If we
1823     ;; got class objects, then we can compute unparsed, but if we got
1824     ;; class names we don't try to compute parsed.
1825     ;;
1826     ;; Note that the use of not symbolp in this call to every should be
1827     ;; read as 'classp' we can't use classp itself because it doesn't
1828     ;; exist yet.
1829     (if (every #'(lambda (s) (not (symbolp s))) specializers)
1830         (setq parsed specializers
1831               unparsed (mapcar #'(lambda (s)
1832                                    (if (eq s 't) 't (class-name s)))
1833                                specializers))
1834         (setq unparsed specializers
1835               parsed ()))
1836     (list :early-method           ;This is an early method dammit!
1837
1838           (getf initargs ':function)
1839           (getf initargs ':fast-function)
1840
1841           parsed                  ;The parsed specializers. This is used
1842                                   ;by early-method-specializers to cache
1843                                   ;the parse. Note that this only comes
1844                                   ;into play when there is more than one
1845                                   ;early method on an early gf.
1846
1847           (list class        ;A list to which real-make-a-method
1848                 qualifiers      ;can be applied to make a real method
1849                 arglist    ;corresponding to this early one.
1850                 unparsed
1851                 initargs
1852                 doc
1853                 slot-name))))
1854
1855 (defun real-make-a-method
1856        (class qualifiers lambda-list specializers initargs doc
1857         &optional slot-name)
1858   (setq specializers (parse-specializers specializers))
1859   (apply #'make-instance class
1860          :qualifiers qualifiers
1861          :lambda-list lambda-list
1862          :specializers specializers
1863          :documentation doc
1864          :slot-name slot-name
1865          :allow-other-keys t
1866          initargs))
1867
1868 (defun early-method-function (early-method)
1869   (values (cadr early-method) (caddr early-method)))
1870
1871 (defun early-method-class (early-method)
1872   (find-class (car (fifth early-method))))
1873
1874 (defun early-method-standard-accessor-p (early-method)
1875   (let ((class (first (fifth early-method))))
1876     (or (eq class 'standard-reader-method)
1877         (eq class 'standard-writer-method)
1878         (eq class 'standard-boundp-method))))
1879
1880 (defun early-method-standard-accessor-slot-name (early-method)
1881   (seventh (fifth early-method)))
1882
1883 ;;; Fetch the specializers of an early method. This is basically just a
1884 ;;; simple accessor except that when the second argument is t, this converts
1885 ;;; the specializers from symbols into class objects. The class objects
1886 ;;; are cached in the early method, this makes bootstrapping faster because
1887 ;;; the class objects only have to be computed once.
1888 ;;; NOTE:
1889 ;;;  the second argument should only be passed as T by early-lookup-method.
1890 ;;;  this is to implement the rule that only when there is more than one
1891 ;;;  early method on a generic function is the conversion from class names
1892 ;;;  to class objects done.
1893 ;;;  the corresponds to the fact that we are only allowed to have one method
1894 ;;;  on any generic function up until the time classes exist.
1895 (defun early-method-specializers (early-method &optional objectsp)
1896   (if (and (listp early-method)
1897            (eq (car early-method) :early-method))
1898       (cond ((eq objectsp 't)
1899              (or (fourth early-method)
1900                  (setf (fourth early-method)
1901                        (mapcar #'find-class (cadddr (fifth early-method))))))
1902             (t
1903              (cadddr (fifth early-method))))
1904       (error "~S is not an early-method." early-method)))
1905
1906 (defun early-method-qualifiers (early-method)
1907   (cadr (fifth early-method)))
1908
1909 (defun early-method-lambda-list (early-method)
1910   (caddr (fifth early-method)))
1911
1912 (defun early-add-named-method (generic-function-name
1913                                qualifiers
1914                                specializers
1915                                arglist
1916                                &rest initargs)
1917   (let* ((gf (ensure-generic-function generic-function-name))
1918          (existing
1919            (dolist (m (early-gf-methods gf))
1920              (when (and (equal (early-method-specializers m) specializers)
1921                         (equal (early-method-qualifiers m) qualifiers))
1922                (return m))))
1923          (new (make-a-method 'standard-method
1924                              qualifiers
1925                              arglist
1926                              specializers
1927                              initargs
1928                              ())))
1929     (when existing (remove-method gf existing))
1930     (add-method gf new)))
1931
1932 ;;; This is the early version of ADD-METHOD. Later this will become a
1933 ;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has special
1934 ;;; knowledge about ADD-METHOD.
1935 (defun add-method (generic-function method)
1936   (when (not (fsc-instance-p generic-function))
1937     (error "Early ADD-METHOD didn't get a funcallable instance."))
1938   (when (not (and (listp method) (eq (car method) :early-method)))
1939     (error "Early ADD-METHOD didn't get an early method."))
1940   (push method (early-gf-methods generic-function))
1941   (set-arg-info generic-function :new-method method)
1942   (unless (assoc (early-gf-name generic-function) *!generic-function-fixups*
1943                  :test #'equal)
1944     (update-dfun generic-function)))
1945
1946 ;;; This is the early version of REMOVE-METHOD. See comments on
1947 ;;; the early version of ADD-METHOD.
1948 (defun remove-method (generic-function method)
1949   (when (not (fsc-instance-p generic-function))
1950     (error "An early remove-method didn't get a funcallable instance."))
1951   (when (not (and (listp method) (eq (car method) :early-method)))
1952     (error "An early remove-method didn't get an early method."))
1953   (setf (early-gf-methods generic-function)
1954         (remove method (early-gf-methods generic-function)))
1955   (set-arg-info generic-function)
1956   (unless (assoc (early-gf-name generic-function) *!generic-function-fixups*
1957                  :test #'equal)
1958     (update-dfun generic-function)))
1959
1960 ;;; This is the early version of GET-METHOD. See comments on the early
1961 ;;; version of ADD-METHOD.
1962 (defun get-method (generic-function qualifiers specializers
1963                                     &optional (errorp t))
1964   (if (early-gf-p generic-function)
1965       (or (dolist (m (early-gf-methods generic-function))
1966             (when (and (or (equal (early-method-specializers m nil)
1967                                   specializers)
1968                            (equal (early-method-specializers m 't)
1969                                   specializers))
1970                        (equal (early-method-qualifiers m) qualifiers))
1971               (return m)))
1972           (if errorp
1973               (error "can't get early method")
1974               nil))
1975       (real-get-method generic-function qualifiers specializers errorp)))
1976
1977 (defun !fix-early-generic-functions ()
1978   (sb-int:/show "entering !FIX-EARLY-GENERIC-FUNCTIONS")
1979   (let ((accessors nil))
1980     ;; Rearrange *!EARLY-GENERIC-FUNCTIONS* to speed up
1981     ;; FIX-EARLY-GENERIC-FUNCTIONS.
1982     (dolist (early-gf-spec *!early-generic-functions*)
1983       (sb-int:/show early-gf-spec)
1984       (when (every #'early-method-standard-accessor-p
1985                    (early-gf-methods (gdefinition early-gf-spec)))
1986         (push early-gf-spec accessors)))
1987     (dolist (spec (nconc accessors
1988                          '(accessor-method-slot-name
1989                            generic-function-methods
1990                            method-specializers
1991                            specializerp
1992                            specializer-type
1993                            specializer-class
1994                            slot-definition-location
1995                            slot-definition-name
1996                            class-slots
1997                            gf-arg-info
1998                            class-precedence-list
1999                            slot-boundp-using-class
2000                            (setf slot-value-using-class)
2001                            slot-value-using-class
2002                            structure-class-p
2003                            standard-class-p
2004                            funcallable-standard-class-p
2005                            specializerp)))
2006       (sb-int:/show spec)
2007       (setq *!early-generic-functions*
2008             (cons spec
2009                   (delete spec *!early-generic-functions* :test #'equal))))
2010
2011     (dolist (early-gf-spec *!early-generic-functions*)
2012       (sb-int:/show early-gf-spec)
2013       (let* ((gf (gdefinition early-gf-spec))
2014              (methods (mapcar #'(lambda (early-method)
2015                                   (let ((args (copy-list (fifth
2016                                                           early-method))))
2017                                     (setf (fourth args)
2018                                           (early-method-specializers
2019                                            early-method t))
2020                                     (apply #'real-make-a-method args)))
2021                               (early-gf-methods gf))))
2022         (setf (generic-function-method-class gf) *the-class-standard-method*)
2023         (setf (generic-function-method-combination gf)
2024               *standard-method-combination*)
2025         (set-methods gf methods)))
2026
2027     (dolist (fn *!early-functions*)
2028       (sb-int:/show fn)
2029       (setf (gdefinition (car fn)) (symbol-function (caddr fn))))
2030
2031     (dolist (fixup *!generic-function-fixups*)
2032       (sb-int:/show fixup)
2033       (let* ((fspec (car fixup))
2034              (gf (gdefinition fspec))
2035              (methods (mapcar #'(lambda (method)
2036                                   (let* ((lambda-list (first method))
2037                                          (specializers (second method))
2038                                          (method-fn-name (third method))
2039                                          (fn-name (or method-fn-name fspec))
2040                                          (fn (symbol-function fn-name))
2041                                          (initargs
2042                                           (list :function
2043                                                 (set-function-name
2044                                                  #'(lambda (args next-methods)
2045                                                      (declare (ignore
2046                                                                next-methods))
2047                                                      (apply fn args))
2048                                                  `(call ,fn-name)))))
2049                                     (declare (type function fn))
2050                                     (make-a-method 'standard-method
2051                                                    ()
2052                                                    lambda-list
2053                                                    specializers
2054                                                    initargs
2055                                                    nil)))
2056                               (cdr fixup))))
2057         (setf (generic-function-method-class gf) *the-class-standard-method*)
2058         (setf (generic-function-method-combination gf)
2059               *standard-method-combination*)
2060         (set-methods gf methods))))
2061   (sb-int:/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
2062 \f
2063 ;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument into
2064 ;;; the 'real' arguments. This is where the syntax of DEFMETHOD is really
2065 ;;; implemented.
2066 (defun parse-defmethod (cdr-of-form)
2067   ;;(declare (values name qualifiers specialized-lambda-list body))
2068   (let ((name (pop cdr-of-form))
2069         (qualifiers ())
2070         (spec-ll ()))
2071     (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
2072               (push (pop cdr-of-form) qualifiers)
2073               (return (setq qualifiers (nreverse qualifiers)))))
2074     (setq spec-ll (pop cdr-of-form))
2075     (values name qualifiers spec-ll cdr-of-form)))
2076
2077 (defun parse-specializers (specializers)
2078   (flet ((parse (spec)
2079            (let ((result (specializer-from-type spec)))
2080              (if (specializerp result)
2081                  result
2082                  (if (symbolp spec)
2083                      (error "~S was used as a specializer,~%~
2084                              but is not the name of a class."
2085                             spec)
2086                      (error "~S is not a legal specializer." spec))))))
2087     (mapcar #'parse specializers)))
2088
2089 (defun unparse-specializers (specializers-or-method)
2090   (if (listp specializers-or-method)
2091       (flet ((unparse (spec)
2092                (if (specializerp spec)
2093                    (let ((type (specializer-type spec)))
2094                      (if (and (consp type)
2095                               (eq (car type) 'class))
2096                          (let* ((class (cadr type))
2097                                 (class-name (class-name class)))
2098                            (if (eq class (find-class class-name nil))
2099                                class-name
2100                                type))
2101                          type))
2102                    (error "~S is not a legal specializer." spec))))
2103         (mapcar #'unparse specializers-or-method))
2104       (unparse-specializers (method-specializers specializers-or-method))))
2105
2106 (defun parse-method-or-spec (spec &optional (errorp t))
2107   ;;(declare (values generic-function method method-name))
2108   (let (gf method name temp)
2109     (if (method-p spec)
2110         (setq method spec
2111               gf (method-generic-function method)
2112               temp (and gf (generic-function-name gf))
2113               name (if temp
2114                        (intern-function-name
2115                          (make-method-spec temp
2116                                            (method-qualifiers method)
2117                                            (unparse-specializers
2118                                              (method-specializers method))))
2119                        (make-symbol (format nil "~S" method))))
2120         (multiple-value-bind (gf-spec quals specls)
2121             (parse-defmethod spec)
2122           (and (setq gf (and (or errorp (gboundp gf-spec))
2123                              (gdefinition gf-spec)))
2124                (let ((nreq (compute-discriminating-function-arglist-info gf)))
2125                  (setq specls (append (parse-specializers specls)
2126                                       (make-list (- nreq (length specls))
2127                                                  :initial-element
2128                                                  *the-class-t*)))
2129                  (and
2130                    (setq method (get-method gf quals specls errorp))
2131                    (setq name
2132                          (intern-function-name (make-method-spec gf-spec
2133                                                                  quals
2134                                                                  specls))))))))
2135     (values gf method name)))
2136 \f
2137 (defun extract-parameters (specialized-lambda-list)
2138   (multiple-value-bind (parameters ignore1 ignore2)
2139       (parse-specialized-lambda-list specialized-lambda-list)
2140     (declare (ignore ignore1 ignore2))
2141     parameters))
2142
2143 (defun extract-lambda-list (specialized-lambda-list)
2144   (multiple-value-bind (ignore1 lambda-list ignore2)
2145       (parse-specialized-lambda-list specialized-lambda-list)
2146     (declare (ignore ignore1 ignore2))
2147     lambda-list))
2148
2149 (defun extract-specializer-names (specialized-lambda-list)
2150   (multiple-value-bind (ignore1 ignore2 specializers)
2151       (parse-specialized-lambda-list specialized-lambda-list)
2152     (declare (ignore ignore1 ignore2))
2153     specializers))
2154
2155 (defun extract-required-parameters (specialized-lambda-list)
2156   (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
2157       (parse-specialized-lambda-list specialized-lambda-list)
2158     (declare (ignore ignore1 ignore2 ignore3))
2159     required-parameters))
2160
2161 (defun parse-specialized-lambda-list (arglist &optional post-keyword)
2162   ;;(declare (values parameters lambda-list specializers required-parameters))
2163   (let ((arg (car arglist)))
2164     (cond ((null arglist) (values nil nil nil nil))
2165           ((eq arg '&aux)
2166            (values nil arglist nil))
2167           ((memq arg lambda-list-keywords)
2168            (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
2169              ;; Warn about non-standard lambda-list-keywords, but then
2170              ;; go on to treat them like a standard lambda-list-keyword
2171              ;; what with the warning its probably ok.
2172              ;;
2173              ;; FIXME: This shouldn't happen now that this is maintained
2174              ;; as part of SBCL, should it? Perhaps this is now
2175              ;; "internal error: unrecognized lambda-list keyword ~S"?
2176              (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
2177                     Assuming that the symbols following it are parameters,~%~
2178                     and not allowing any parameter specializers to follow~%~
2179                     to follow it."
2180                    arg))
2181            ;; When we are at a lambda-list keyword, the parameters don't
2182            ;; include the lambda-list keyword; the lambda-list does include
2183            ;; the lambda-list keyword; and no specializers are allowed to
2184            ;; follow the lambda-list keywords (at least for now).
2185            (multiple-value-bind (parameters lambda-list)
2186                (parse-specialized-lambda-list (cdr arglist) t)
2187              (values parameters
2188                      (cons arg lambda-list)
2189                      ()
2190                      ())))
2191           (post-keyword
2192            ;; After a lambda-list keyword there can be no specializers.
2193            (multiple-value-bind (parameters lambda-list)
2194                (parse-specialized-lambda-list (cdr arglist) t)
2195              (values (cons (if (listp arg) (car arg) arg) parameters)
2196                      (cons arg lambda-list)
2197                      ()
2198                      ())))
2199           (t
2200            (multiple-value-bind (parameters lambda-list specializers required)
2201                (parse-specialized-lambda-list (cdr arglist))
2202              (values (cons (if (listp arg) (car arg) arg) parameters)
2203                      (cons (if (listp arg) (car arg) arg) lambda-list)
2204                      (cons (if (listp arg) (cadr arg) 't) specializers)
2205                      (cons (if (listp arg) (car arg) arg) required)))))))
2206 \f
2207 (eval-when (:load-toplevel :execute)
2208   (setq *boot-state* 'early))
2209 \f
2210 ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET which used
2211 ;;; %WALKER stuff. That suggests to me that maybe the code walker stuff was
2212 ;;; only used for implementing stuff like that; maybe it's not needed any more?
2213 ;;; Hunt down what it was used for and see.
2214
2215 (defmacro with-slots (slots instance &body body)
2216   (let ((in (gensym)))
2217     `(let ((,in ,instance))
2218        (declare (ignorable ,in))
2219        ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
2220                              (third instance)
2221                              instance)))
2222            (and (symbolp instance)
2223                 `((declare (variable-rebinding ,in ,instance)))))
2224        ,in
2225        (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
2226                                      (let ((variable-name
2227                                             (if (symbolp slot-entry)
2228                                                 slot-entry
2229                                                 (car slot-entry)))
2230                                            (slot-name
2231                                             (if (symbolp slot-entry)
2232                                                 slot-entry
2233                                                 (cadr slot-entry))))
2234                                        `(,variable-name
2235                                           (slot-value ,in ',slot-name))))
2236                                  slots)
2237                         ,@body))))
2238
2239 (defmacro with-accessors (slots instance &body body)
2240   (let ((in (gensym)))
2241     `(let ((,in ,instance))
2242        (declare (ignorable ,in))
2243        ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
2244                              (third instance)
2245                              instance)))
2246            (and (symbolp instance)
2247                 `((declare (variable-rebinding ,in ,instance)))))
2248        ,in
2249        (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
2250                                    (let ((variable-name (car slot-entry))
2251                                          (accessor-name (cadr slot-entry)))
2252                                      `(,variable-name
2253                                         (,accessor-name ,in))))
2254                                slots)
2255           ,@body))))