0.pre8.54
[sbcl.git] / src / pcl / defs.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 ;;; (These are left over from the days when PCL was an add-on package
27 ;;; for a pre-CLOS Common Lisp. They shouldn't happen in a normal
28 ;;; build, of course, but they might happen if someone is experimenting
29 ;;; and debugging, and it's probably worth complaining if they do,
30 ;;; so we've left 'em in.)
31 (when (eq *boot-state* 'complete)
32   (error "Trying to load (or compile) PCL in an environment in which it~%~
33           has already been loaded. This doesn't work, you will have to~%~
34           get a fresh lisp (reboot) and then load PCL."))
35 (when *boot-state*
36   (cerror "Try loading (or compiling) PCL anyways."
37           "Trying to load (or compile) PCL in an environment in which it~%~
38            has already been partially loaded. This may not work, you may~%~
39            need to get a fresh lisp (reboot) and then load PCL."))
40 \f
41 ;;; comments from CMU CL version of PCL:
42 ;;;     This is like fdefinition on the Lispm. If Common Lisp had
43 ;;;   something like function specs I wouldn't need this. On the other
44 ;;;   hand, I don't like the way this really works so maybe function
45 ;;;   specs aren't really right either?
46 ;;;     I also don't understand the real implications of a Lisp-1 on this
47 ;;;   sort of thing. Certainly some of the lossage in all of this is
48 ;;;   because these SPECs name global definitions.
49 ;;;     Note that this implementation is set up so that an implementation
50 ;;;   which has a 'real' function spec mechanism can use that instead
51 ;;;   and in that way get rid of setf generic function names.
52 (defmacro parse-gspec (spec
53                        (non-setf-var . non-setf-case))
54   `(let ((,non-setf-var ,spec)) ,@non-setf-case))
55
56 ;;; If symbol names a function which is traced, return the untraced
57 ;;; definition. This lets us get at the generic function object even
58 ;;; when it is traced.
59 (defun unencapsulated-fdefinition (symbol)
60   (fdefinition symbol))
61
62 ;;; If symbol names a function which is traced, redefine the `real'
63 ;;; definition without affecting the trace.
64 (defun fdefine-carefully (name new-definition)
65   (progn
66     (sb-c::note-name-defined name :function)
67     new-definition)
68   (setf (fdefinition name) new-definition))
69
70 (defun gboundp (spec)
71   (parse-gspec spec
72     (name (fboundp name))))
73
74 (defun gmakunbound (spec)
75   (parse-gspec spec
76     (name (fmakunbound name))))
77
78 (defun gdefinition (spec)
79   (parse-gspec spec
80     (name (unencapsulated-fdefinition name))))
81
82 (defun (setf gdefinition) (new-value spec)
83   (parse-gspec spec
84     (name (fdefine-carefully name new-value))))
85 \f
86 (declaim (special *the-class-t*
87                   *the-class-vector* *the-class-symbol*
88                   *the-class-string* *the-class-sequence*
89                   *the-class-rational* *the-class-ratio*
90                   *the-class-number* *the-class-null* *the-class-list*
91                   *the-class-integer* *the-class-float* *the-class-cons*
92                   *the-class-complex* *the-class-character*
93                   *the-class-bit-vector* *the-class-array*
94                   *the-class-stream*
95
96                   *the-class-slot-object*
97                   *the-class-structure-object*
98                   *the-class-std-object*
99                   *the-class-standard-object*
100                   *the-class-funcallable-standard-object*
101                   *the-class-class*
102                   *the-class-generic-function*
103                   *the-class-built-in-class*
104                   *the-class-slot-class*
105                   *the-class-structure-class*
106                   *the-class-std-class*
107                   *the-class-standard-class*
108                   *the-class-funcallable-standard-class*
109                   *the-class-method*
110                   *the-class-standard-method*
111                   *the-class-standard-reader-method*
112                   *the-class-standard-writer-method*
113                   *the-class-standard-boundp-method*
114                   *the-class-standard-generic-function*
115                   *the-class-standard-effective-slot-definition*
116
117                   *the-eslotd-standard-class-slots*
118                   *the-eslotd-funcallable-standard-class-slots*))
119
120 (declaim (special *the-wrapper-of-t*
121                   *the-wrapper-of-vector* *the-wrapper-of-symbol*
122                   *the-wrapper-of-string* *the-wrapper-of-sequence*
123                   *the-wrapper-of-rational* *the-wrapper-of-ratio*
124                   *the-wrapper-of-number* *the-wrapper-of-null*
125                   *the-wrapper-of-list* *the-wrapper-of-integer*
126                   *the-wrapper-of-float* *the-wrapper-of-cons*
127                   *the-wrapper-of-complex* *the-wrapper-of-character*
128                   *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
129 \f
130 ;;;; type specifier hackery
131
132 ;;; internal to this file
133 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
134   (if (symbolp class)
135       (or (find-class class (not make-forward-referenced-class-p))
136           (ensure-class class))
137       class))
138
139 ;;; interface
140 (defun specializer-from-type (type &aux args)
141   (when (consp type)
142     (setq args (cdr type) type (car type)))
143   (cond ((symbolp type)
144          (or (and (null args) (find-class type))
145              (ecase type
146                (class    (coerce-to-class (car args)))
147                (prototype (make-instance 'class-prototype-specializer
148                                          :object (coerce-to-class (car args))))
149                (class-eq (class-eq-specializer (coerce-to-class (car args))))
150                (eql      (intern-eql-specializer (car args))))))
151         ;; FIXME: do we still need this?
152         ((and (null args) (typep type 'classoid))
153          (or (classoid-pcl-class type)
154              (ensure-non-standard-class (classoid-name type))))
155         ((specializerp type) type)))
156
157 ;;; interface
158 (defun type-from-specializer (specl)
159   (cond ((eq specl t)
160          t)
161         ((consp specl)
162          (unless (member (car specl) '(class prototype class-eq eql))
163            (error "~S is not a legal specializer type." specl))
164          specl)
165         ((progn
166            (when (symbolp specl)
167              ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
168              (setq specl (find-class specl)))
169            (or (not (eq *boot-state* 'complete))
170                (specializerp specl)))
171          (specializer-type specl))
172         (t
173          (error "~S is neither a type nor a specializer." specl))))
174
175 (defun type-class (type)
176   (declare (special *the-class-t*))
177   (setq type (type-from-specializer type))
178   (if (atom type)
179       (if (eq type t)
180           *the-class-t*
181           (error "bad argument to TYPE-CLASS"))
182       (case (car type)
183         (eql (class-of (cadr type)))
184         (prototype (class-of (cadr type))) ;?
185         (class-eq (cadr type))
186         (class (cadr type)))))
187
188 (defun class-eq-type (class)
189   (specializer-type (class-eq-specializer class)))
190
191 ;;; internal to this file..
192 ;;;
193 ;;; These functions are a pale imitation of their namesake. They accept
194 ;;; class objects or types where they should.
195 (defun *normalize-type (type)
196   (cond ((consp type)
197          (if (member (car type) '(not and or))
198              `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
199              (if (null (cdr type))
200                  (*normalize-type (car type))
201                  type)))
202         ((symbolp type)
203          (let ((class (find-class type nil)))
204            (if class
205                (let ((type (specializer-type class)))
206                  (if (listp type) type `(,type)))
207                `(,type))))
208         ((or (not (eq *boot-state* 'complete))
209              (specializerp type))
210          (specializer-type type))
211         (t
212          (error "~S is not a type." type))))
213
214 ;;; internal to this file...
215 (defun convert-to-system-type (type)
216   (case (car type)
217     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
218                                           (cdr type))))
219     ((class class-eq) ; class-eq is impossible to do right
220      (layout-classoid (class-wrapper (cadr type))))
221     (eql type)
222     (t (if (null (cdr type))
223            (car type)
224            type))))
225
226 ;;; Writing the missing NOT and AND clauses will improve the quality
227 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
228 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
229 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
230 ;;;
231 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
232 ;;; in the compiler. Could we share some of it here? 
233 (defun *subtypep (type1 type2)
234   (if (equal type1 type2)
235       (values t t)
236       (if (eq *boot-state* 'early)
237           (values (eq type1 type2) t)
238           (let ((*in-precompute-effective-methods-p* t))
239             (declare (special *in-precompute-effective-methods-p*))
240             ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
241             ;; good name. It changes the way
242             ;; CLASS-APPLICABLE-USING-CLASS-P works.
243             (setq type1 (*normalize-type type1))
244             (setq type2 (*normalize-type type2))
245             (case (car type2)
246               (not
247                (values nil nil)) ; XXX We should improve this.
248               (and
249                (values nil nil)) ; XXX We should improve this.
250               ((eql wrapper-eq class-eq class)
251                (multiple-value-bind (app-p maybe-app-p)
252                    (specializer-applicable-using-type-p type2 type1)
253                  (values app-p (or app-p (not maybe-app-p)))))
254               (t
255                (subtypep (convert-to-system-type type1)
256                          (convert-to-system-type type2))))))))
257 \f
258 (defvar *built-in-class-symbols* ())
259 (defvar *built-in-wrapper-symbols* ())
260
261 (defun get-built-in-class-symbol (class-name)
262   (or (cadr (assq class-name *built-in-class-symbols*))
263       (let ((symbol (intern (format nil
264                                     "*THE-CLASS-~A*"
265                                     (symbol-name class-name))
266                             *pcl-package*)))
267         (push (list class-name symbol) *built-in-class-symbols*)
268         symbol)))
269
270 (defun get-built-in-wrapper-symbol (class-name)
271   (or (cadr (assq class-name *built-in-wrapper-symbols*))
272       (let ((symbol (intern (format nil
273                                     "*THE-WRAPPER-OF-~A*"
274                                     (symbol-name class-name))
275                             *pcl-package*)))
276         (push (list class-name symbol) *built-in-wrapper-symbols*)
277         symbol)))
278 \f
279 (pushnew '%class *var-declarations*)
280 (pushnew '%variable-rebinding *var-declarations*)
281
282 (defun variable-class (var env)
283   (caddr (var-declaration 'class var env)))
284
285 (defvar *name->class->slotd-table* (make-hash-table))
286
287 (defvar *standard-method-combination*)
288 \f
289 (defun make-class-predicate-name (name)
290   (list 'class-predicate name))
291   
292 (defun plist-value (object name)
293   (getf (object-plist object) name))
294
295 (defun (setf plist-value) (new-value object name)
296   (if new-value
297       (setf (getf (object-plist object) name) new-value)
298       (progn
299         (remf (object-plist object) name)
300         nil)))
301 \f
302 ;;;; built-in classes
303
304 ;;; FIXME: This was the portable PCL way of setting up
305 ;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost
306 ;;; entirely wasted motion, since it's immediately overwritten by a
307 ;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However,
308 ;;; we can't just delete it, since the fifth element from each entry
309 ;;; (a prototype of the class) is still in the final result. It would
310 ;;; be nice to clean this up so that the other, never-used stuff is
311 ;;; gone, perhaps finding a tidier way to represent examples of each
312 ;;; class, too.
313 ;;;
314 ;;; FIXME: This can probably be blown away after bootstrapping.
315 ;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too..
316 #|
317 (defvar *built-in-classes*
318   ;; name       supers     subs              cdr of cpl
319   ;; prototype
320   '(;(t  ()      (number sequence array character symbol) ())
321     (number     (t)     (complex float rational) (t))
322     (complex    (number)   ()                  (number t)
323      #c(1 1))
324     (float      (number)   ()                  (number t)
325      1.0)
326     (rational   (number)   (integer ratio)        (number t))
327     (integer    (rational) ()                  (rational number t)
328      1)
329     (ratio      (rational) ()                  (rational number t)
330      1/2)
331
332     (sequence   (t)     (list vector)       (t))
333     (list       (sequence) (cons null)        (sequence t))
334     (cons       (list)     ()                  (list sequence t)
335      (nil))
336
337     (array      (t)     (vector)                 (t)
338      #2A((nil)))
339     (vector     (array
340                  sequence) (string bit-vector)      (array sequence t)
341      #())
342     (string     (vector)   ()                  (vector array sequence t)
343      "")
344     (bit-vector (vector)   ()                  (vector array sequence t)
345      #*1)
346     (character  (t)     ()                     (t)
347      #\c)
348
349     (symbol     (t)     (null)             (t)
350      symbol)
351     (null       (symbol
352                  list)     ()                  (symbol list sequence t)
353      nil)))
354 |#
355
356 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
357 ;;; SB-PCL:*BUILT-IN-CLASSES*.
358 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
359 (defvar *built-in-classes*
360   (labels ((direct-supers (class)
361              (/noshow "entering DIRECT-SUPERS" (classoid-name class))
362              (if (typep class 'built-in-classoid)
363                  (built-in-classoid-direct-superclasses class)
364                  (let ((inherits (layout-inherits
365                                   (classoid-layout class))))
366                    (/noshow inherits)
367                    (list (svref inherits (1- (length inherits)))))))
368            (direct-subs (class)
369              (/noshow "entering DIRECT-SUBS" (classoid-name class))
370              (collect ((res))
371                (let ((subs (classoid-subclasses class)))
372                  (/noshow subs)
373                  (when subs
374                    (dohash (sub v subs)
375                      (declare (ignore v))
376                      (/noshow sub)
377                      (when (member class (direct-supers sub))
378                        (res sub)))))
379                (res)))
380            (prototype (class-name)
381              (let ((assoc (assoc class-name
382                                  '((complex    . #c(1 1))
383                                    (float      . 1.0)
384                                    (integer    . 1)
385                                    (ratio      . 1/2)
386                                    (sequence   . nil)
387                                    (list       . nil)
388                                    (cons       . (nil))
389                                    (array      . #2a((nil)))
390                                    (vector     . #())
391                                    (string     . "")
392                                    (bit-vector . #*1)
393                                    (character  . #\c)
394                                    (symbol     . symbol)
395                                    (null       . nil)))))
396                (if assoc
397                    (cdr assoc)
398                    ;; This is the default prototype value which was
399                    ;; used, without explanation, by the CMU CL code
400                    ;; we're derived from. Evidently it's safe in all
401                    ;; relevant cases.
402                    42))))
403     (mapcar (lambda (kernel-bic-entry)
404               (/noshow "setting up" kernel-bic-entry)
405               (let* ((name (car kernel-bic-entry))
406                      (class (find-classoid name)))
407                 (/noshow name class)
408                 `(,name
409                   ,(mapcar #'classoid-name (direct-supers class))
410                   ,(mapcar #'classoid-name (direct-subs class))
411                   ,(map 'list
412                         (lambda (x)
413                           (classoid-name
414                            (layout-classoid x)))
415                         (reverse
416                          (layout-inherits
417                           (classoid-layout class))))
418                   ,(prototype name))))
419             (remove-if (lambda (kernel-bic-entry)
420                          (member (first kernel-bic-entry)
421                                  ;; I'm not sure why these are removed from
422                                  ;; the list, but that's what the original
423                                  ;; CMU CL code did. -- WHN 20000715
424                                  '(t instance
425                                      funcallable-instance
426                                      function stream)))
427                        sb-kernel::*built-in-classes*))))
428 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
429 \f
430 ;;;; the classes that define the kernel of the metabraid
431
432 (defclass t () ()
433   (:metaclass built-in-class))
434
435 (defclass instance (t) ()
436   (:metaclass built-in-class))
437
438 (defclass function (t) ()
439   (:metaclass built-in-class))
440
441 (defclass funcallable-instance (function) ()
442   (:metaclass built-in-class))
443
444 (defclass stream (instance) ()
445   (:metaclass built-in-class))
446
447 (defclass slot-object (t) ()
448   (:metaclass slot-class))
449
450 (defclass structure-object (slot-object instance) ()
451   (:metaclass structure-class))
452
453 (defstruct (dead-beef-structure-object
454             (:constructor |STRUCTURE-OBJECT class constructor|)
455             (:copier nil)))
456
457 (defclass std-object (slot-object) ()
458   (:metaclass std-class))
459
460 (defclass standard-object (std-object instance) ())
461
462 (defclass funcallable-standard-object (std-object funcallable-instance)
463   ()
464   (:metaclass funcallable-standard-class))
465
466 (defclass specializer (standard-object)
467   ((type
468     :initform nil
469     :reader specializer-type)))
470
471 (defclass definition-source-mixin (std-object)
472   ((source
473     :initform *load-pathname*
474     :reader definition-source
475     :initarg :definition-source))
476   (:metaclass std-class))
477
478 (defclass plist-mixin (std-object)
479   ((plist
480     :initform ()
481     :accessor object-plist))
482   (:metaclass std-class))
483
484 (defclass documentation-mixin (plist-mixin)
485   ()
486   (:metaclass std-class))
487
488 (defclass dependent-update-mixin (plist-mixin)
489   ()
490   (:metaclass std-class))
491
492 ;;; The class CLASS is a specified basic class. It is the common
493 ;;; superclass of any kind of class. That is, any class that can be a
494 ;;; metaclass must have the class CLASS in its class precedence list.
495 (defclass class (documentation-mixin
496                  dependent-update-mixin
497                  definition-source-mixin
498                  specializer)
499   ((name
500     :initform nil
501     :initarg  :name
502     :accessor class-name)
503    (class-eq-specializer
504     :initform nil
505     :reader class-eq-specializer)
506    (direct-superclasses
507     :initform ()
508     :reader class-direct-superclasses)
509    ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
510    ;; CONDITION-CLASSes are lazily computed whenever the subclass info
511    ;; becomes available, i.e. when the PCL class is created.
512    (direct-subclasses
513     :initform ()
514     :reader class-direct-subclasses)
515    (direct-methods
516     :initform (cons nil nil))
517    (predicate-name
518     :initform nil
519     :reader class-predicate-name)))
520
521 (def!method make-load-form ((class class) &optional env)
522   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
523   ;; doesn't matter while all our environments are the same...
524   (declare (ignore env))
525   (let ((name (class-name class)))
526     (unless (and name (eq (find-class name nil) class))
527       (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
528              class))
529     `(find-class ',name)))
530
531 ;;; The class PCL-CLASS is an implementation-specific common
532 ;;; superclass of all specified subclasses of the class CLASS.
533 (defclass pcl-class (class)
534   ((class-precedence-list
535     :reader class-precedence-list)
536    (can-precede-list
537     :initform ()
538     :reader class-can-precede-list)
539    (incompatible-superclass-list
540     :initform ()
541     :accessor class-incompatible-superclass-list)
542    (wrapper
543     :initform nil
544     :reader class-wrapper)
545    (prototype
546     :initform nil
547     :reader class-prototype)))
548
549 (defclass slot-class (pcl-class)
550   ((direct-slots
551     :initform ()
552     :accessor class-direct-slots)
553    (slots
554     :initform ()
555     :accessor class-slots)
556    (initialize-info
557     :initform nil
558     :accessor class-initialize-info)))
559
560 ;;; The class STD-CLASS is an implementation-specific common
561 ;;; superclass of the classes STANDARD-CLASS and
562 ;;; FUNCALLABLE-STANDARD-CLASS.
563 (defclass std-class (slot-class)
564   ())
565
566 (defclass standard-class (std-class)
567   ())
568
569 (defclass funcallable-standard-class (std-class)
570   ())
571
572 (defclass forward-referenced-class (pcl-class) ())
573
574 (defclass built-in-class (pcl-class) ())
575
576 (defclass condition-class (pcl-class) ())
577
578 (defclass structure-class (slot-class)
579   ((defstruct-form
580      :initform ()
581      :accessor class-defstruct-form)
582    (defstruct-constructor
583      :initform nil
584      :accessor class-defstruct-constructor)
585    (from-defclass-p
586     :initform nil
587     :initarg :from-defclass-p)))
588
589 (defclass specializer-with-object (specializer) ())
590
591 (defclass exact-class-specializer (specializer) ())
592
593 (defclass class-eq-specializer (exact-class-specializer
594                                 specializer-with-object)
595   ((object :initarg :class
596            :reader specializer-class
597            :reader specializer-object)))
598
599 (defclass class-prototype-specializer (specializer-with-object)
600   ((object :initarg :class
601            :reader specializer-class
602            :reader specializer-object)))
603
604 (defclass eql-specializer (exact-class-specializer specializer-with-object)
605   ((object :initarg :object :reader specializer-object
606            :reader eql-specializer-object)))
607
608 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
609
610 (defun intern-eql-specializer (object)
611   (or (gethash object *eql-specializer-table*)
612       (setf (gethash object *eql-specializer-table*)
613             (make-instance 'eql-specializer :object object))))
614 \f
615 ;;;; slot definitions
616
617 (defclass slot-definition (standard-object)
618   ((name
619     :initform nil
620     :initarg :name
621     :accessor slot-definition-name)
622    (initform
623     :initform nil
624     :initarg :initform
625     :accessor slot-definition-initform)
626    (initfunction
627     :initform nil
628     :initarg :initfunction
629     :accessor slot-definition-initfunction)
630    (readers
631     :initform nil
632     :initarg :readers
633     :accessor slot-definition-readers)
634    (writers
635     :initform nil
636     :initarg :writers
637     :accessor slot-definition-writers)
638    (initargs
639     :initform nil
640     :initarg :initargs
641     :accessor slot-definition-initargs)
642    (type
643     :initform t
644     :initarg :type
645     :accessor slot-definition-type)
646    (documentation
647     :initform ""
648     :initarg :documentation)
649    (class
650     :initform nil
651     :initarg :class
652     :accessor slot-definition-class)))
653
654 (defclass standard-slot-definition (slot-definition)
655   ((allocation
656     :initform :instance
657     :initarg :allocation
658     :accessor slot-definition-allocation)
659    (allocation-class
660     :initform nil
661     :initarg :allocation-class
662     :accessor slot-definition-allocation-class)))
663
664 (defclass structure-slot-definition (slot-definition)
665   ((defstruct-accessor-symbol
666      :initform nil
667      :initarg :defstruct-accessor-symbol
668      :accessor slot-definition-defstruct-accessor-symbol)
669    (internal-reader-function
670      :initform nil
671      :initarg :internal-reader-function
672      :accessor slot-definition-internal-reader-function)
673    (internal-writer-function
674      :initform nil
675      :initarg :internal-writer-function
676      :accessor slot-definition-internal-writer-function)))
677
678 (defclass direct-slot-definition (slot-definition)
679   ())
680
681 (defclass effective-slot-definition (slot-definition)
682   ((reader-function ; (lambda (object) ...)
683     :accessor slot-definition-reader-function)
684    (writer-function ; (lambda (new-value object) ...)
685     :accessor slot-definition-writer-function)
686    (boundp-function ; (lambda (object) ...)
687     :accessor slot-definition-boundp-function)
688    (accessor-flags
689     :initform 0)))
690
691 (defclass standard-direct-slot-definition (standard-slot-definition
692                                            direct-slot-definition)
693   ())
694
695 (defclass standard-effective-slot-definition (standard-slot-definition
696                                               effective-slot-definition)
697   ((location ; nil, a fixnum, a cons: (slot-name . value)
698     :initform nil
699     :accessor slot-definition-location)))
700
701 (defclass structure-direct-slot-definition (structure-slot-definition
702                                             direct-slot-definition)
703   ())
704
705 (defclass structure-effective-slot-definition (structure-slot-definition
706                                                effective-slot-definition)
707   ())
708
709 (defclass method (standard-object) ())
710
711 (defclass standard-method (definition-source-mixin plist-mixin method)
712   ((generic-function
713     :initform nil       
714     :accessor method-generic-function)
715 ;;;     (qualifiers
716 ;;;     :initform ()
717 ;;;     :initarg  :qualifiers
718 ;;;     :reader method-qualifiers)
719    (specializers
720     :initform ()
721     :initarg  :specializers
722     :reader method-specializers)
723    (lambda-list
724     :initform ()
725     :initarg  :lambda-list
726     :reader method-lambda-list)
727    (function
728     :initform nil
729     :initarg :function)                 ;no writer
730    (fast-function
731     :initform nil
732     :initarg :fast-function             ;no writer
733     :reader method-fast-function)
734 ;;;     (documentation
735 ;;;     :initform nil
736 ;;;     :initarg  :documentation
737 ;;;     :reader method-documentation)
738   ))
739
740 (defclass standard-accessor-method (standard-method)
741   ((slot-name :initform nil
742               :initarg :slot-name
743               :reader accessor-method-slot-name)
744    (slot-definition :initform nil
745                     :initarg :slot-definition
746                     :reader accessor-method-slot-definition)))
747
748 (defclass standard-reader-method (standard-accessor-method) ())
749
750 (defclass standard-writer-method (standard-accessor-method) ())
751
752 (defclass standard-boundp-method (standard-accessor-method) ())
753
754 (defclass generic-function (dependent-update-mixin
755                             definition-source-mixin
756                             documentation-mixin
757                             funcallable-standard-object)
758   (;; We need to make a distinction between the methods initially set
759    ;; up by :METHOD options to DEFGENERIC and the ones set up later by
760    ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on
761    ;; an already-DEFGENERICed function clears the methods set by the
762    ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
763    ;; this distinction seems a little kludgy, but it has the positive
764    ;; effect of making it so that loading a file a.lisp containing
765    ;; DEFGENERIC, then loading a second file b.lisp containing
766    ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
767    ;; tends to leave the generic function in a state consistent with
768    ;; the most-recently-loaded state of a.lisp and b.lisp.)
769    (initial-methods
770     :initform ()
771     :accessor generic-function-initial-methods))
772   (:metaclass funcallable-standard-class))
773
774 (defclass standard-generic-function (generic-function)
775   ((name
776     :initform nil
777     :initarg :name
778     :accessor generic-function-name)
779    (methods
780     :initform ()
781     :accessor generic-function-methods
782     :type list)
783    (method-class
784     :initarg :method-class
785     :accessor generic-function-method-class)
786    (method-combination
787     :initarg :method-combination
788     :accessor generic-function-method-combination)
789    (declarations
790     :initarg :declarations
791     :initform ()
792     :accessor generic-function-declarations)
793    (arg-info
794     :initform (make-arg-info)
795     :reader gf-arg-info)
796    (dfun-state
797     :initform ()
798     :accessor gf-dfun-state))
799   (:metaclass funcallable-standard-class)
800   (:default-initargs :method-class *the-class-standard-method*
801                      :method-combination *standard-method-combination*))
802
803 (defclass method-combination (standard-object) ())
804
805 (defclass standard-method-combination (definition-source-mixin
806                                         method-combination)
807   ((type
808     :reader method-combination-type
809     :initarg :type)
810    (documentation
811     :reader method-combination-documentation
812     :initarg :documentation)
813    (options
814     :reader method-combination-options
815     :initarg :options)))
816
817 (defclass long-method-combination (standard-method-combination)
818   ((function
819     :initarg :function
820     :reader long-method-combination-function)
821    (args-lambda-list
822     :initarg :args-lambda-list
823     :reader long-method-combination-args-lambda-list)))
824
825 (defparameter *early-class-predicates*
826   '((specializer specializerp)
827     (exact-class-specializer exact-class-specializer-p)
828     (class-eq-specializer class-eq-specializer-p)
829     (eql-specializer eql-specializer-p)
830     (class classp)
831     (slot-class slot-class-p)
832     (std-class std-class-p)
833     (standard-class standard-class-p)
834     (funcallable-standard-class funcallable-standard-class-p)
835     (structure-class structure-class-p)
836     (forward-referenced-class forward-referenced-class-p)
837     (method method-p)
838     (standard-method standard-method-p)
839     (standard-accessor-method standard-accessor-method-p)
840     (standard-reader-method standard-reader-method-p)
841     (standard-writer-method standard-writer-method-p)
842     (standard-boundp-method standard-boundp-method-p)
843     (generic-function generic-function-p)
844     (standard-generic-function standard-generic-function-p)
845     (method-combination method-combination-p)
846     (long-method-combination long-method-combination-p)))
847