[71bc8b]: src / pcl / defs.lisp Maximize Restore History

Download this file

defs.lisp    744 lines (657 with data), 27.7 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;; This software is derived from software originally released by Xerox
;;;; Corporation. Copyright and release statements follow. Later modifications
;;;; to the software are in the public domain and are provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for more
;;;; information.
;;;; copyright information from original PCL sources:
;;;;
;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;;; All rights reserved.
;;;;
;;;; Use and copying of this software and preparation of derivative works based
;;;; upon this software are permitted. Any distribution of this software or
;;;; derivative works must comply with all applicable United States export
;;;; control laws.
;;;;
;;;; This software is made available AS IS, and Xerox Corporation makes no
;;;; warranty about the software, its performance or its conformity to any
;;;; specification.
(in-package "SB-PCL")
;;; (These are left over from the days when PCL was an add-on package
;;; for a pre-CLOS Common Lisp. They shouldn't happen in a normal
;;; build, of course, but they might happen if someone is experimenting
;;; and debugging, and it's probably worth complaining if they do,
;;; so we've left 'em in.)
(when (eq **boot-state** 'complete)
(error "Trying to load (or compile) PCL in an environment in which it~%~
has already been loaded. This doesn't work, you will have to~%~
get a fresh lisp (reboot) and then load PCL."))
(when **boot-state**
(cerror "Try loading (or compiling) PCL anyways."
"Trying to load (or compile) PCL in an environment in which it~%~
has already been partially loaded. This may not work, you may~%~
need to get a fresh lisp (reboot) and then load PCL."))
#-sb-fluid (declaim (inline gdefinition))
(defun gdefinition (spec)
;; This is null layer right now, but once FDEFINITION stops bypasssing
;; fwrappers/encapsulations we can do that here.
(fdefinition spec))
(defun (setf gdefinition) (new-value spec)
;; This is almost a null layer right now, but once (SETF
;; FDEFINITION) stops bypasssing fwrappers/encapsulations we can do
;; that here.
(sb-c::note-name-defined spec :function) ; FIXME: do we need this? Why?
(setf (fdefinition spec) new-value))
;;;; type specifier hackery
;;; internal to this file
(defun coerce-to-class (class &optional make-forward-referenced-class-p)
(if (symbolp class)
(or (find-class class (not make-forward-referenced-class-p))
(ensure-class class))
class))
;;; interface
(defun specializer-from-type (type &aux args)
(when (symbolp type)
(return-from specializer-from-type (find-class type)))
(when (consp type)
(setq args (cdr type) type (car type)))
(cond ((symbolp type)
(or (ecase type
(class (coerce-to-class (car args)))
(prototype (make-instance 'class-prototype-specializer
:object (coerce-to-class (car args))))
(class-eq (class-eq-specializer (coerce-to-class (car args))))
(eql (intern-eql-specializer (car args))))))
;; FIXME: do we still need this?
((and (null args) (typep type 'classoid))
(or (classoid-pcl-class type)
(ensure-non-standard-class (classoid-name type) type)))
((specializerp type) type)))
;;; interface
(defun type-from-specializer (specl)
(cond ((eq specl t)
t)
((consp specl)
(unless (member (car specl) '(class prototype class-eq eql))
(error "~S is not a legal specializer type." specl))
specl)
((progn
(when (symbolp specl)
;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
(setq specl (find-class specl)))
(or (not (eq **boot-state** 'complete))
(specializerp specl)))
(specializer-type specl))
(t
(error "~S is neither a type nor a specializer." specl))))
(defun type-class (type)
(declare (special *the-class-t*))
(setq type (type-from-specializer type))
(if (atom type)
(if (eq type t)
*the-class-t*
(error "bad argument to TYPE-CLASS"))
(case (car type)
(eql (class-of (cadr type)))
(prototype (class-of (cadr type))) ;?
(class-eq (cadr type))
(class (cadr type)))))
(defun class-eq-type (class)
(specializer-type (class-eq-specializer class)))
;;; internal to this file..
;;;
;;; These functions are a pale imitation of their namesake. They accept
;;; class objects or types where they should.
(defun *normalize-type (type)
(cond ((consp type)
(if (member (car type) '(not and or))
`(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
(if (null (cdr type))
(*normalize-type (car type))
type)))
((symbolp type)
(let ((class (find-class type nil)))
(if class
(let ((type (specializer-type class)))
(if (listp type) type `(,type)))
`(,type))))
((or (not (eq **boot-state** 'complete))
(specializerp type))
(specializer-type type))
(t
(error "~S is not a type." type))))
;;; internal to this file...
(defun convert-to-system-type (type)
(case (car type)
((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
(cdr type))))
((class class-eq) ; class-eq is impossible to do right
(layout-classoid (class-wrapper (cadr type))))
(eql type)
(t (if (null (cdr type))
(car type)
type))))
;;; Writing the missing NOT and AND clauses will improve the quality
;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
;;;
;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
;;; in the compiler. Could we share some of it here?
(defvar *in-*subtypep* nil)
(defun *subtypep (type1 type2)
(if (equal type1 type2)
(values t t)
(if (eq **boot-state** 'early)
(values (eq type1 type2) t)
(let ((*in-*subtypep* t))
(setq type1 (*normalize-type type1))
(setq type2 (*normalize-type type2))
(case (car type2)
(not
(values nil nil)) ; XXX We should improve this.
(and
(values nil nil)) ; XXX We should improve this.
((eql wrapper-eq class-eq class)
(multiple-value-bind (app-p maybe-app-p)
(specializer-applicable-using-type-p type2 type1)
(values app-p (or app-p (not maybe-app-p)))))
(t
(subtypep (convert-to-system-type type1)
(convert-to-system-type type2))))))))
(defvar *built-in-class-symbols* ())
(defvar *built-in-wrapper-symbols* ())
(defun get-built-in-class-symbol (class-name)
(or (cadr (assq class-name *built-in-class-symbols*))
(let ((symbol (make-class-symbol class-name)))
(push (list class-name symbol) *built-in-class-symbols*)
symbol)))
(defun get-built-in-wrapper-symbol (class-name)
(or (cadr (assq class-name *built-in-wrapper-symbols*))
(let ((symbol (make-wrapper-symbol class-name)))
(push (list class-name symbol) *built-in-wrapper-symbols*)
symbol)))
(defvar *standard-method-combination*)
(defun plist-value (object name)
(getf (object-plist object) name))
(defun (setf plist-value) (new-value object name)
(if new-value
(setf (getf (object-plist object) name) new-value)
(progn
(remf (object-plist object) name)
nil)))
;;;; built-in classes
;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
;;; SB-PCL:*BUILT-IN-CLASSES*.
(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(defvar *built-in-classes*
(labels ((direct-supers (class)
(/noshow "entering DIRECT-SUPERS" (classoid-name class))
(if (typep class 'built-in-classoid)
(built-in-classoid-direct-superclasses class)
(let ((inherits (layout-inherits
(classoid-layout class))))
(/noshow inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
(/noshow "entering DIRECT-SUBS" (classoid-name class))
(collect ((res))
(let ((subs (classoid-subclasses class)))
(/noshow subs)
(when subs
(dohash ((sub v) subs)
(declare (ignore v))
(/noshow sub)
(when (member class (direct-supers sub) :test #'eq)
(res sub)))))
(res))))
(mapcar (lambda (kernel-bic-entry)
(/noshow "setting up" kernel-bic-entry)
(let* ((name (car kernel-bic-entry))
(class (find-classoid name))
(prototype-form
(getf (cdr kernel-bic-entry) :prototype-form)))
(/noshow name class)
`(,name
,(mapcar #'classoid-name (direct-supers class))
,(mapcar #'classoid-name (direct-subs class))
,(map 'list
(lambda (x)
(classoid-name
(layout-classoid x)))
(reverse
(layout-inherits
(classoid-layout class))))
,(if prototype-form
(eval prototype-form)
;; This is the default prototype value which
;; was used, without explanation, by the CMU CL
;; code we're derived from. Evidently it's safe
;; in all relevant cases.
42))))
(remove-if (lambda (kernel-bic-entry)
(member (first kernel-bic-entry)
;; I'm not sure why these are removed from
;; the list, but that's what the original
;; CMU CL code did. -- WHN 20000715
'(t function stream
file-stream string-stream)))
sb-kernel::*built-in-classes*))))
(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
;;;; the classes that define the kernel of the metabraid
(defclass t () ()
(:metaclass built-in-class))
(defclass function (t) ()
(:metaclass built-in-class))
(defclass stream (t) ()
(:metaclass built-in-class))
(defclass file-stream (stream) ()
(:metaclass built-in-class))
(defclass string-stream (stream) ()
(:metaclass built-in-class))
(defclass slot-object (t) ()
(:metaclass slot-class))
(defclass condition (slot-object) ()
(:metaclass condition-class))
(defclass structure-object (slot-object) ()
(:metaclass structure-class))
(defstruct (dead-beef-structure-object
(:constructor |STRUCTURE-OBJECT class constructor|)
(:copier nil)))
(defclass standard-object (slot-object) ())
(defclass funcallable-standard-object (function standard-object)
()
(:metaclass funcallable-standard-class))
(defclass metaobject (standard-object) ())
(defclass generic-function (dependent-update-mixin
definition-source-mixin
metaobject
funcallable-standard-object)
((%documentation
:initform nil
:initarg :documentation)
;; We need to make a distinction between the methods initially set
;; up by :METHOD options to DEFGENERIC and the ones set up later by
;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
;; an already-DEFGENERICed function clears the methods set by the
;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
;; this distinction seems a little kludgy, but it has the positive
;; effect of making it so that loading a file a.lisp containing
;; DEFGENERIC, then loading a second file b.lisp containing
;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
;; tends to leave the generic function in a state consistent with
;; the most-recently-loaded state of a.lisp and b.lisp.)
(initial-methods
:initform ()
:accessor generic-function-initial-methods))
(:metaclass funcallable-standard-class))
(defclass standard-generic-function (generic-function)
((name
:initform nil
:initarg :name
:reader generic-function-name)
(methods
:initform ()
:accessor generic-function-methods
:type list)
(method-class
:initarg :method-class
:accessor generic-function-method-class)
(%method-combination
:initarg :method-combination
:accessor generic-function-method-combination)
(declarations
;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
;; :DECLARE. Allow either (but FIXME: maybe a note or a warning
;; might be appropriate).
:initarg :declarations
:initarg :declare
:initform ()
:accessor generic-function-declarations)
(arg-info
:initform (make-arg-info)
:reader gf-arg-info)
(dfun-state
:initform ()
:accessor gf-dfun-state)
;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
(%lock
:initform (sb-thread::make-spinlock :name "GF lock")
:reader gf-lock)
;; Set to true by ADD-METHOD, REMOVE-METHOD; to false by
;; MAYBE-UPDATE-INFO-FOR-GF.
(info-needs-update
:initform nil
:accessor gf-info-needs-update))
(:metaclass funcallable-standard-class)
(:default-initargs :method-class *the-class-standard-method*
:method-combination *standard-method-combination*))
(defclass method (metaobject) ())
(defclass standard-method (plist-mixin definition-source-mixin method)
((%generic-function :initform nil :accessor method-generic-function)
(qualifiers :initform () :initarg :qualifiers :reader method-qualifiers)
(specializers :initform () :initarg :specializers
:reader method-specializers)
(lambda-list :initform () :initarg :lambda-list :reader method-lambda-list)
(%function :initform nil :initarg :function :reader method-function)
(%documentation :initform nil :initarg :documentation)
;; True IFF method is known to have no CALL-NEXT-METHOD in it, or
;; just a plain (CALL-NEXT-METHOD).
(simple-next-method-call
:initform nil
:initarg simple-next-method-call
:reader simple-next-method-call-p)))
(defclass accessor-method (standard-method)
((slot-name :initform nil :initarg :slot-name
:reader accessor-method-slot-name)))
(defclass standard-accessor-method (accessor-method)
((%slot-definition :initform nil :initarg :slot-definition
:reader accessor-method-slot-definition)))
(defclass standard-reader-method (standard-accessor-method) ())
(defclass standard-writer-method (standard-accessor-method) ())
;;; an extension, apparently.
(defclass standard-boundp-method (standard-accessor-method) ())
;;; for (SLOT-VALUE X 'FOO) / ACCESSOR-SLOT-VALUE optimization, which
;;; can't be STANDARD-READER-METHOD because there is no associated
;;; slot definition.
(defclass global-reader-method (accessor-method) ())
(defclass global-writer-method (accessor-method) ())
(defclass global-boundp-method (accessor-method) ())
(defclass method-combination (metaobject)
((%documentation :initform nil :initarg :documentation)))
(defclass standard-method-combination (definition-source-mixin
method-combination)
((type-name
:reader method-combination-type-name
:initarg :type-name)
(options
:reader method-combination-options
:initarg :options)))
(defclass long-method-combination (standard-method-combination)
((function
:initarg :function
:reader long-method-combination-function)
(args-lambda-list
:initarg :args-lambda-list
:reader long-method-combination-args-lambda-list)))
(defclass short-method-combination (standard-method-combination)
((operator
:reader short-combination-operator
:initarg :operator)
(identity-with-one-argument
:reader short-combination-identity-with-one-argument
:initarg :identity-with-one-argument)))
(defclass slot-definition (metaobject)
((name
:initform nil
:initarg :name
:accessor slot-definition-name)
(initform
:initform nil
:initarg :initform
:accessor slot-definition-initform)
(initfunction
:initform nil
:initarg :initfunction
:accessor slot-definition-initfunction)
(readers
:initform nil
:initarg :readers
:accessor slot-definition-readers)
(writers
:initform nil
:initarg :writers
:accessor slot-definition-writers)
(initargs
:initform nil
:initarg :initargs
:accessor slot-definition-initargs)
(%type :initform t :initarg :type :accessor slot-definition-type)
(%documentation
:initform nil :initarg :documentation
;; KLUDGE: we need a reader for bootstrapping purposes, in
;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS.
:reader %slot-definition-documentation)
(%class :initform nil :initarg :class :accessor slot-definition-class)))
(defclass standard-slot-definition (slot-definition)
((allocation
:initform :instance
:initarg :allocation
:accessor slot-definition-allocation)
(allocation-class
:initform nil
:initarg :allocation-class
:accessor slot-definition-allocation-class)))
(defclass condition-slot-definition (slot-definition)
((allocation
:initform :instance
:initarg :allocation
:accessor slot-definition-allocation)
(allocation-class
:initform nil
:initarg :allocation-class
:accessor slot-definition-allocation-class)))
(defclass structure-slot-definition (slot-definition)
((defstruct-accessor-symbol
:initform nil
:initarg :defstruct-accessor-symbol
:accessor slot-definition-defstruct-accessor-symbol)
(internal-reader-function
:initform nil
:initarg :internal-reader-function
:accessor slot-definition-internal-reader-function)
(internal-writer-function
:initform nil
:initarg :internal-writer-function
:accessor slot-definition-internal-writer-function)))
(defclass direct-slot-definition (slot-definition)
())
(defclass effective-slot-definition (slot-definition)
((accessor-flags
:initform 0)
(info
:accessor slot-definition-info)))
;;; We use a structure here, because fast slot-accesses to this information
;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
;;; these functions can access the SLOT-INFO directly, avoiding the overhead
;;; of accessing a standard-instance.
(defstruct (slot-info (:constructor make-slot-info
(&key slotd
typecheck
(type t)
(reader
(uninitialized-accessor-function :reader slotd))
(writer
(uninitialized-accessor-function :writer slotd))
(boundp
(uninitialized-accessor-function :boundp slotd)))))
(typecheck nil :type (or null function))
(reader (missing-arg) :type function)
(writer (missing-arg) :type function)
(boundp (missing-arg) :type function))
(defclass standard-direct-slot-definition (standard-slot-definition
direct-slot-definition)
())
(defclass standard-effective-slot-definition (standard-slot-definition
effective-slot-definition)
((location ; nil, a fixnum, a cons: (slot-name . value)
:initform nil
:accessor slot-definition-location)))
(defclass condition-direct-slot-definition (condition-slot-definition
direct-slot-definition)
())
(defclass condition-effective-slot-definition (condition-slot-definition
effective-slot-definition)
())
(defclass structure-direct-slot-definition (structure-slot-definition
direct-slot-definition)
())
(defclass structure-effective-slot-definition (structure-slot-definition
effective-slot-definition)
())
(defclass specializer (metaobject)
;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an
;; external symbol of the CL package and hence potentially collides
;; with user code. Renaming this to %TYPE, however, is the coward's
;; way out, because the objects that PCL puts in this slot aren't
;; (quite) types: they are closer to kinds of specializer. However,
;; the wholesale renaming and disentangling of specializers didn't
;; appeal. (See also message <sqd5hrclb2.fsf@cam.ac.uk> and
;; responses in comp.lang.lisp). -- CSR, 2006-02-27
((%type :initform nil :reader specializer-type)))
;;; STANDARD in this name doesn't mean "blessed by a standard" but
;;; "comes as standard with PCL"; that is, it includes CLASS-EQ
;;; and vestiges of PROTOTYPE specializers
(defclass standard-specializer (specializer) ())
(defclass specializer-with-object (specializer) ())
(defclass exact-class-specializer (specializer) ())
(defclass class-eq-specializer (standard-specializer
exact-class-specializer
specializer-with-object)
((object :initarg :class
:reader specializer-class
:reader specializer-object)))
(defclass class-prototype-specializer (standard-specializer specializer-with-object)
((object :initarg :class
:reader specializer-class
:reader specializer-object)))
(defclass eql-specializer (standard-specializer exact-class-specializer specializer-with-object)
((object :initarg :object :reader specializer-object
:reader eql-specializer-object)))
(defvar *eql-specializer-table* (make-hash-table :test 'eql))
(defun intern-eql-specializer (object)
;; Need to lock, so that two threads don't get non-EQ specializers
;; for an EQL object.
(with-locked-system-table (*eql-specializer-table*)
(or (gethash object *eql-specializer-table*)
(setf (gethash object *eql-specializer-table*)
(make-instance 'eql-specializer :object object)))))
(defclass class (dependent-update-mixin
definition-source-mixin
standard-specializer)
((name
:initform nil
:initarg :name
:reader class-name)
(class-eq-specializer
:initform nil
:reader class-eq-specializer)
(direct-superclasses
:initform ()
:reader class-direct-superclasses)
;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
;; CONDITION-CLASSes are lazily computed whenever the subclass info
;; becomes available, i.e. when the PCL class is created.
(direct-subclasses
:initform ()
:reader class-direct-subclasses)
(direct-methods
:initform (cons nil nil))
(%documentation
:initform nil
:initarg :documentation)
;; True if the class definition was compiled with a (SAFETY 3)
;; optimization policy.
(safe-p
:initform nil
:initarg safe-p
:accessor safe-p)
(finalized-p
:initform nil
:reader class-finalized-p)))
(def!method make-load-form ((class class) &optional env)
;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably
;; doesn't matter while all our environments are the same...
(declare (ignore env))
(let ((name (class-name class)))
(unless (and name (eq (find-class name nil) class))
(error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
class))
`(find-class ',name)))
;;; The class PCL-CLASS is an implementation-specific common
;;; superclass of all specified subclasses of the class CLASS.
(defclass pcl-class (class)
((%class-precedence-list
:reader class-precedence-list)
;; KLUDGE: see note in CPL-OR-NIL
(cpl-available-p
:reader cpl-available-p
:initform nil)
(can-precede-list
:initform ()
:reader class-can-precede-list)
(incompatible-superclass-list
:initform ()
:accessor class-incompatible-superclass-list)
(wrapper
:initform nil
:reader class-wrapper)
(prototype
:initform nil
:reader class-prototype)))
(defclass slot-class (pcl-class)
((direct-slots
:initform ()
:reader class-direct-slots)
(slots
:initform ()
:reader class-slots)))
;;; The class STD-CLASS is an implementation-specific common
;;; superclass of the classes STANDARD-CLASS and
;;; FUNCALLABLE-STANDARD-CLASS.
(defclass std-class (slot-class)
())
(defclass standard-class (std-class)
()
(:default-initargs
:direct-superclasses (list *the-class-standard-object*)))
(defclass funcallable-standard-class (std-class)
()
(:default-initargs
:direct-superclasses (list *the-class-funcallable-standard-object*)))
(defclass forward-referenced-class (pcl-class) ())
(defclass built-in-class (pcl-class) ())
(defclass condition-class (slot-class) ())
(defclass structure-class (slot-class)
((defstruct-form :initform () :accessor class-defstruct-form)
(defstruct-constructor :initform nil :accessor class-defstruct-constructor)
(from-defclass-p :initform nil :initarg :from-defclass-p)))
(defclass definition-source-mixin (standard-object)
((source
:initform nil
:reader definition-source
:initarg :definition-source)))
(defclass plist-mixin (standard-object)
((plist :initform () :accessor object-plist :initarg plist)))
(defclass dependent-update-mixin (plist-mixin) ())
(defparameter *early-class-predicates*
'((specializer specializerp)
(standard-specializer standard-specializer-p)
(exact-class-specializer exact-class-specializer-p)
(class-eq-specializer class-eq-specializer-p)
(eql-specializer eql-specializer-p)
(class classp)
(slot-class slot-class-p)
(std-class std-class-p)
(standard-class standard-class-p)
(funcallable-standard-class funcallable-standard-class-p)
(condition-class condition-class-p)
(structure-class structure-class-p)
(forward-referenced-class forward-referenced-class-p)
(method method-p)
(standard-method standard-method-p)
(accessor-method accessor-method-p)
(standard-accessor-method standard-accessor-method-p)
(standard-reader-method standard-reader-method-p)
(standard-writer-method standard-writer-method-p)
(standard-boundp-method standard-boundp-method-p)
(global-reader-method global-reader-method-p)
(global-writer-method global-writer-method-p)
(global-boundp-method global-boundp-method-p)
(generic-function generic-function-p)
(standard-generic-function standard-generic-function-p)
(method-combination method-combination-p)
(long-method-combination long-method-combination-p)
(short-method-combination short-method-combination-p)))