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