/[cmucl]/src/pcl/defs.lisp
ViewVC logotype

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Thu Aug 3 16:58:56 2000 UTC (13 years, 8 months ago) by pw
Branch: MAIN
Changes since 1.17: +16 -34 lines
These changes remove some obsolete and unused type system interface codes,
and introduces code to "inform-type-system-about-std-class". The effect
of this new code is to put minimal class definitions into the compile-time
environment to prevent undefined-type warnings. These definitions are
replaced with the correct class defs at load-time.
1 ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26 ;;;
27
28 (in-package :pcl)
29
30 (eval-when (compile load eval)
31
32 (defvar *defclass-times* '(load eval)) ;Probably have to change this
33 ;if you use defconstructor.
34 (defvar *defmethod-times* '(load eval))
35 (defvar *defgeneric-times* '(load eval))
36
37 ; defvar is now actually in macros
38 ;(defvar *boot-state* ()) ;NIL
39 ;EARLY
40 ;BRAID
41 ;COMPLETE
42 (defvar *fegf-started-p* nil)
43
44
45 )
46
47 (eval-when (load eval)
48 (when (eq *boot-state* 'complete)
49 (error "Trying to load (or compile) PCL in an environment in which it~%~
50 has already been loaded. This doesn't work, you will have to~%~
51 get a fresh lisp (reboot) and then load PCL."))
52 (when *boot-state*
53 (cerror "Try loading (or compiling) PCL anyways."
54 "Trying to load (or compile) PCL in an environment in which it~%~
55 has already been partially loaded. This may not work, you may~%~
56 need to get a fresh lisp (reboot) and then load PCL."))
57 )
58
59
60
61 ;;;
62 ;;; If symbol names a function which is traced or advised, return the
63 ;;; unadvised, traced etc. definition. This lets me get at the generic
64 ;;; function object even when it is traced.
65 ;;;
66 (declaim (inline gdefinition))
67 (defun gdefinition (symbol)
68 (fdefinition symbol))
69
70 ;;;
71 ;;; If symbol names a function which is traced or advised, redefine
72 ;;; the `real' definition without affecting the advise.
73 ;;
74 (defun (setf gdefinition) (new-definition name)
75 (c::%%defun name new-definition nil)
76 (c::note-name-defined name :function)
77 new-definition)
78
79 (proclaim '(special *the-class-t*
80 *the-class-vector* *the-class-symbol*
81 *the-class-string* *the-class-sequence*
82 *the-class-rational* *the-class-ratio*
83 *the-class-number* *the-class-null* *the-class-list*
84 *the-class-integer* *the-class-float* *the-class-cons*
85 *the-class-complex* *the-class-character*
86 *the-class-bit-vector* *the-class-array*
87 *the-class-stream*
88
89 *the-class-slot-object*
90 *the-class-structure-object*
91 *the-class-std-object*
92 *the-class-standard-object*
93 *the-class-funcallable-standard-object*
94 *the-class-class*
95 *the-class-generic-function*
96 *the-class-built-in-class*
97 *the-class-slot-class*
98 *the-class-structure-class*
99 *the-class-std-class*
100 *the-class-standard-class*
101 *the-class-funcallable-standard-class*
102 *the-class-method*
103 *the-class-standard-method*
104 *the-class-standard-reader-method*
105 *the-class-standard-writer-method*
106 *the-class-standard-boundp-method*
107 *the-class-standard-generic-function*
108 *the-class-standard-effective-slot-definition*
109
110 *the-eslotd-standard-class-slots*
111 *the-eslotd-funcallable-standard-class-slots*))
112
113 (proclaim '(special *the-wrapper-of-t*
114 *the-wrapper-of-vector* *the-wrapper-of-symbol*
115 *the-wrapper-of-string* *the-wrapper-of-sequence*
116 *the-wrapper-of-rational* *the-wrapper-of-ratio*
117 *the-wrapper-of-number* *the-wrapper-of-null*
118 *the-wrapper-of-list* *the-wrapper-of-integer*
119 *the-wrapper-of-float* *the-wrapper-of-cons*
120 *the-wrapper-of-complex* *the-wrapper-of-character*
121 *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
122
123 ;;;; Type specifier hackery:
124
125 ;;; internal to this file.
126 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
127 (if (symbolp class)
128 (or (find-class class (not make-forward-referenced-class-p))
129 (ensure-class class))
130 class))
131
132 ;;; Interface
133 (defun specializer-from-type (type &aux args)
134 (when (consp type)
135 (setq args (cdr type) type (car type)))
136 (cond ((symbolp type)
137 (or (and (null args) (find-class type))
138 (ecase type
139 (class (coerce-to-class (car args)))
140 (prototype (make-instance 'class-prototype-specializer
141 :object (coerce-to-class (car args))))
142 (class-eq (class-eq-specializer (coerce-to-class (car args))))
143 (eql (intern-eql-specializer (car args))))))
144 ((and (null args) (typep type 'lisp:class))
145 (or (kernel:class-pcl-class type)
146 (find-structure-class (lisp:class-name type))))
147 ((specializerp type) type)))
148
149 ;;; interface
150 (defun type-from-specializer (specl)
151 (cond ((eq specl 't)
152 't)
153 ((consp specl)
154 (unless (member (car specl) '(class prototype class-eq eql))
155 (error "~S is not a legal specializer type" specl))
156 specl)
157 ((progn
158 (when (symbolp specl)
159 ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
160 (setq specl (find-class specl)))
161 (or (not (eq *boot-state* 'complete))
162 (specializerp specl)))
163 (specializer-type specl))
164 (t
165 (error "~s is neither a type nor a specializer" specl))))
166
167 (defun type-class (type)
168 (declare (special *the-class-t*))
169 (setq type (type-from-specializer type))
170 (if (atom type)
171 (if (eq type 't)
172 *the-class-t*
173 (error "bad argument to type-class"))
174 (case (car type)
175 (eql (class-of (cadr type)))
176 (prototype (class-of (cadr type))) ;?
177 (class-eq (cadr type))
178 (class (cadr type)))))
179
180 (defun class-eq-type (class)
181 (specializer-type (class-eq-specializer class)))
182
183 (defun inform-type-system-about-std-class (name)
184 ;; This should only be called if metaclass is standard-class.
185 ;; Compiler problems have been seen if the metaclass is
186 ;; funcallable-standard-class and this is called from the defclass macro
187 ;; expander. However, bootstrap-meta-braid calls this for funcallable-
188 ;; standard-class metaclasses but *boot-state* is not 'complete then.
189 ;;
190 ;; The only effect of this code is to ensure a lisp:standard-class class
191 ;; exists so as to avoid undefined-function compiler warnings. The
192 ;; skeleton class will be replaced at load-time with the correct object.
193 ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.
194
195 (when (and (eq *boot-state* 'complete)
196 (null (lisp:find-class name nil)))
197 (setf (lisp:find-class name)
198 (lisp::make-standard-class :name name))))
199
200 (defun make-class-eq-predicate (class)
201 (when (symbolp class) (setq class (find-class class)))
202 #'(lambda (object) (eq class (class-of object))))
203
204 (defun make-eql-predicate (eql-object)
205 #'(lambda (object) (eql eql-object object)))
206
207
208 ;;; Internal to this file.
209 ;;;
210 ;;; These functions are a pale imitiation of their namesake. They accept
211 ;;; class objects or types where they should.
212 ;;;
213 (defun *normalize-type (type)
214 (cond ((consp type)
215 (if (member (car type) '(not and or))
216 `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
217 (if (null (cdr type))
218 (*normalize-type (car type))
219 type)))
220 ((symbolp type)
221 (let ((class (find-class type nil)))
222 (if class
223 (let ((type (specializer-type class)))
224 (if (listp type) type `(,type)))
225 `(,type))))
226 ((or (not (eq *boot-state* 'complete))
227 (specializerp type))
228 (specializer-type type))
229 (t
230 (error "~s is not a type" type))))
231
232 ;;; internal to this file...
233 (defun convert-to-system-type (type)
234 (case (car type)
235 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
236 (cdr type))))
237 ((class class-eq) ; class-eq is impossible to do right
238 (kernel:layout-class (class-wrapper (cadr type))))
239 (eql type)
240 (t (if (null (cdr type))
241 (car type)
242 type))))
243
244
245 ;;; *SUBTYPEP -- Interface
246 ;;;
247 ;Writing the missing NOT and AND clauses will improve
248 ;the quality of code generated by generate-discrimination-net, but
249 ;calling subtypep in place of just returning (values nil nil) can be
250 ;very slow. *subtypep is used by PCL itself, and must be fast.
251 (defun *subtypep (type1 type2)
252 (if (equal type1 type2)
253 (values t t)
254 (if (eq *boot-state* 'early)
255 (values (eq type1 type2) t)
256 (let ((*in-precompute-effective-methods-p* t))
257 (declare (special *in-precompute-effective-methods-p*))
258 ;; *in-precompute-effective-methods-p* is not a good name.
259 ;; It changes the way class-applicable-using-class-p works.
260 (setq type1 (*normalize-type type1))
261 (setq type2 (*normalize-type type2))
262 (case (car type2)
263 (not
264 (values nil nil)) ; Should improve this.
265 (and
266 (values nil nil)) ; Should improve this.
267 ((eql wrapper-eq class-eq class)
268 (multiple-value-bind (app-p maybe-app-p)
269 (specializer-applicable-using-type-p type2 type1)
270 (values app-p (or app-p (not maybe-app-p)))))
271 (t
272 (subtypep (convert-to-system-type type1)
273 (convert-to-system-type type2))))))))
274
275
276 (defvar *built-in-class-symbols* ())
277 (defvar *built-in-wrapper-symbols* ())
278
279 (defun get-built-in-class-symbol (class-name)
280 (or (cadr (assq class-name *built-in-class-symbols*))
281 (let ((symbol (intern (format nil
282 "*THE-CLASS-~A*"
283 (symbol-name class-name))
284 *the-pcl-package*)))
285 (push (list class-name symbol) *built-in-class-symbols*)
286 symbol)))
287
288 (defun get-built-in-wrapper-symbol (class-name)
289 (or (cadr (assq class-name *built-in-wrapper-symbols*))
290 (let ((symbol (intern (format nil
291 "*THE-WRAPPER-OF-~A*"
292 (symbol-name class-name))
293 *the-pcl-package*)))
294 (push (list class-name symbol) *built-in-wrapper-symbols*)
295 symbol)))
296
297
298
299
300 (pushnew 'class *variable-declarations*)
301 (pushnew 'variable-rebinding *variable-declarations*)
302
303 (defun variable-class (var env)
304 (caddr (variable-declaration 'class var env)))
305
306 (defvar *name->class->slotd-table* (make-hash-table))
307
308
309 ;;;
310 ;;; This is used by combined methods to communicate the next methods to
311 ;;; the methods they call. This variable is captured by a lexical variable
312 ;;; of the methods to give it the proper lexical scope.
313 ;;;
314 (defvar *next-methods* nil)
315
316 (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
317
318 (defvar *umi-gfs*)
319 (defvar *umi-complete-classes*)
320 (defvar *umi-reorder*)
321
322 (defvar *invalidate-discriminating-function-force-p* ())
323 (defvar *invalid-dfuns-on-stack* ())
324
325
326 (defvar *standard-method-combination*)
327
328 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
329
330
331 (defmacro define-gf-predicate (predicate-name &rest classes)
332 `(progn
333 (defmethod ,predicate-name ((x t)) nil)
334 ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
335 classes)))
336
337 (defun make-class-predicate-name (name)
338 (intern (format nil "~A::~A class predicate"
339 (package-name (symbol-package name))
340 name)
341 *the-pcl-package*))
342
343 (defun plist-value (object name)
344 (getf (object-plist object) name))
345
346 (defun (setf plist-value) (new-value object name)
347 (if new-value
348 (setf (getf (object-plist object) name) new-value)
349 (progn
350 (remf (object-plist object) name)
351 nil)))
352
353
354
355 (defvar *built-in-classes*
356 ;;
357 ;; name supers subs cdr of cpl
358 ;; prototype
359 '(;(t () (number sequence array character symbol) ())
360 (number (t) (complex float rational) (t))
361 (complex (number) () (number t)
362 #c(1 1))
363 (float (number) () (number t)
364 1.0)
365 (rational (number) (integer ratio) (number t))
366 (integer (rational) () (rational number t)
367 1)
368 (ratio (rational) () (rational number t)
369 1/2)
370
371 (sequence (t) (list vector) (t))
372 (list (sequence) (cons null) (sequence t))
373 (cons (list) () (list sequence t)
374 (nil))
375
376
377 (array (t) (vector) (t)
378 #2A((NIL)))
379 (vector (array
380 sequence) (string bit-vector) (array sequence t)
381 #())
382 (string (vector) () (vector array sequence t)
383 "")
384 (bit-vector (vector) () (vector array sequence t)
385 #*1)
386 (character (t) () (t)
387 #\c)
388
389 (symbol (t) (null) (t)
390 symbol)
391 (null (symbol
392 list) () (symbol list sequence t)
393 nil)))
394
395 (labels ((direct-supers (class)
396 (if (typep class 'lisp:built-in-class)
397 (kernel:built-in-class-direct-superclasses class)
398 (let ((inherits (kernel:layout-inherits
399 (kernel:class-layout class))))
400 (list (svref inherits (1- (length inherits)))))))
401 (direct-subs (class)
402 (ext:collect ((res))
403 (let ((subs (kernel:class-subclasses class)))
404 (when subs
405 (ext:do-hash (sub v subs)
406 (declare (ignore v))
407 (when (member class (direct-supers sub))
408 (res sub)))))
409 (res))))
410 (ext:collect ((res))
411 (dolist (bic kernel::built-in-classes)
412 (let* ((name (car bic))
413 (class (lisp:find-class name)))
414 (unless (member name '(t kernel:instance kernel:funcallable-instance
415 function stream))
416 (res `(,name
417 ,(mapcar #'lisp:class-name (direct-supers class))
418 ,(mapcar #'lisp:class-name (direct-subs class))
419 ,(map 'list #'(lambda (x)
420 (lisp:class-name (kernel:layout-class x)))
421 (reverse
422 (kernel:layout-inherits
423 (kernel:class-layout class))))
424 ,(let ((found (assoc name *built-in-classes*)))
425 (if found (fifth found) 42)))))))
426 (setq *built-in-classes* (res))))
427
428
429 ;;;
430 ;;; The classes that define the kernel of the metabraid.
431 ;;;
432 (defclass t () ()
433 (:metaclass built-in-class))
434
435 (defclass kernel:instance (t) ()
436 (:metaclass built-in-class))
437
438 (defclass function (t) ()
439 (:metaclass built-in-class))
440
441 (defclass kernel:funcallable-instance (function) ()
442 (:metaclass built-in-class))
443
444 (defclass stream (t) ()
445 (:metaclass built-in-class))
446
447 (defclass slot-object (t) ()
448 (:metaclass slot-class))
449
450 (defclass structure-object (slot-object kernel:instance) ()
451 (:metaclass structure-class))
452
453 (defstruct (dead-beef-structure-object
454 (:constructor |STRUCTURE-OBJECT class constructor|)))
455
456
457 (defclass std-object (slot-object) ()
458 (:metaclass std-class))
459
460 (defclass standard-object (std-object kernel:instance) ())
461
462 (defclass funcallable-standard-object (std-object
463 kernel:funcallable-instance)
464 ()
465 (:metaclass funcallable-standard-class))
466
467 (defclass specializer (standard-object)
468 ((type
469 :initform nil
470 :reader specializer-type)))
471
472 (defclass definition-source-mixin (std-object)
473 ((source
474 :initform (load-truename)
475 :reader definition-source
476 :initarg :definition-source))
477 (:metaclass std-class))
478
479 (defclass plist-mixin (std-object)
480 ((plist
481 :initform ()
482 :accessor object-plist))
483 (:metaclass std-class))
484
485 (defclass documentation-mixin (plist-mixin)
486 ()
487 (:metaclass std-class))
488
489 (defclass dependent-update-mixin (plist-mixin)
490 ()
491 (:metaclass std-class))
492
493 ;;;
494 ;;; The class CLASS is a specified basic class. It is the common superclass
495 ;;; of any kind of class. That is any class that can be a metaclass must
496 ;;; have the class CLASS in its class precedence list.
497 ;;;
498 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
499 specializer)
500 ((name
501 :initform nil
502 :initarg :name
503 :accessor class-name)
504 (class-eq-specializer
505 :initform nil
506 :reader class-eq-specializer)
507 (direct-superclasses
508 :initform ()
509 :reader class-direct-superclasses)
510 (direct-subclasses
511 :initform ()
512 :reader class-direct-subclasses)
513 (direct-methods
514 :initform (cons nil nil))
515 (predicate-name
516 :initform nil
517 :reader class-predicate-name)))
518
519 ;;;
520 ;;; The class PCL-CLASS is an implementation-specific common superclass of
521 ;;; all specified subclasses of the class CLASS.
522 ;;;
523 (defclass pcl-class (class)
524 ((class-precedence-list
525 :reader class-precedence-list)
526 (can-precede-list
527 :initform ()
528 :reader class-can-precede-list)
529 (incompatible-superclass-list
530 :initform ()
531 :accessor class-incompatible-superclass-list)
532 (wrapper
533 :initform nil
534 :reader class-wrapper)
535 (prototype
536 :initform nil
537 :reader class-prototype)))
538
539 (defclass slot-class (pcl-class)
540 ((direct-slots
541 :initform ()
542 :accessor class-direct-slots)
543 (slots
544 :initform ()
545 :accessor class-slots)
546 (initialize-info
547 :initform nil
548 :accessor class-initialize-info)))
549
550 ;;;
551 ;;; The class STD-CLASS is an implementation-specific common superclass of
552 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
553 ;;;
554 (defclass std-class (slot-class)
555 ())
556
557 (defclass standard-class (std-class)
558 ())
559
560 (defclass funcallable-standard-class (std-class)
561 ())
562
563 (defclass forward-referenced-class (pcl-class) ())
564
565 (defclass built-in-class (pcl-class) ())
566
567 (defclass structure-class (slot-class)
568 ((defstruct-form
569 :initform ()
570 :accessor class-defstruct-form)
571 (defstruct-constructor
572 :initform nil
573 :accessor class-defstruct-constructor)
574 (from-defclass-p
575 :initform nil
576 :initarg :from-defclass-p)))
577
578
579 (defclass specializer-with-object (specializer) ())
580
581 (defclass exact-class-specializer (specializer) ())
582
583 (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
584 ((object :initarg :class :reader specializer-class :reader specializer-object)))
585
586 (defclass class-prototype-specializer (specializer-with-object)
587 ((object :initarg :class :reader specializer-class :reader specializer-object)))
588
589 (defclass eql-specializer (exact-class-specializer specializer-with-object)
590 ((object :initarg :object :reader specializer-object
591 :reader eql-specializer-object)))
592
593 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
594
595 (defun intern-eql-specializer (object)
596 (or (gethash object *eql-specializer-table*)
597 (setf (gethash object *eql-specializer-table*)
598 (make-instance 'eql-specializer :object object))))
599
600
601 ;;;
602 ;;; Slot definitions.
603 ;;;
604 (defclass slot-definition (standard-object)
605 ((name
606 :initform nil
607 :initarg :name
608 :accessor slot-definition-name)
609 (initform
610 :initform nil
611 :initarg :initform
612 :accessor slot-definition-initform)
613 (initfunction
614 :initform nil
615 :initarg :initfunction
616 :accessor slot-definition-initfunction)
617 (readers
618 :initform nil
619 :initarg :readers
620 :accessor slot-definition-readers)
621 (writers
622 :initform nil
623 :initarg :writers
624 :accessor slot-definition-writers)
625 (initargs
626 :initform nil
627 :initarg :initargs
628 :accessor slot-definition-initargs)
629 (type
630 :initform t
631 :initarg :type
632 :accessor slot-definition-type)
633 (documentation
634 :initform ""
635 :initarg :documentation)
636 (class
637 :initform nil
638 :initarg :class
639 :accessor slot-definition-class)))
640
641 (defclass standard-slot-definition (slot-definition)
642 ((allocation
643 :initform :instance
644 :initarg :allocation
645 :accessor slot-definition-allocation)))
646
647 (defclass structure-slot-definition (slot-definition)
648 ((defstruct-accessor-symbol
649 :initform nil
650 :initarg :defstruct-accessor-symbol
651 :accessor slot-definition-defstruct-accessor-symbol)
652 (internal-reader-function
653 :initform nil
654 :initarg :internal-reader-function
655 :accessor slot-definition-internal-reader-function)
656 (internal-writer-function
657 :initform nil
658 :initarg :internal-writer-function
659 :accessor slot-definition-internal-writer-function)))
660
661 (defclass direct-slot-definition (slot-definition)
662 ())
663
664 (defclass effective-slot-definition (slot-definition)
665 ((reader-function ; #'(lambda (object) ...)
666 :accessor slot-definition-reader-function)
667 (writer-function ; #'(lambda (new-value object) ...)
668 :accessor slot-definition-writer-function)
669 (boundp-function ; #'(lambda (object) ...)
670 :accessor slot-definition-boundp-function)
671 (accessor-flags
672 :initform 0)))
673
674 (defclass standard-direct-slot-definition (standard-slot-definition
675 direct-slot-definition)
676 ())
677
678 (defclass standard-effective-slot-definition (standard-slot-definition
679 effective-slot-definition)
680 ((location ; nil, a fixnum, a cons: (slot-name . value)
681 :initform nil
682 :accessor slot-definition-location)))
683
684 (defclass structure-direct-slot-definition (structure-slot-definition
685 direct-slot-definition)
686 ())
687
688 (defclass structure-effective-slot-definition (structure-slot-definition
689 effective-slot-definition)
690 ())
691
692 (defclass method (standard-object) ())
693
694 (defclass standard-method (definition-source-mixin plist-mixin method)
695 ((generic-function
696 :initform nil
697 :accessor method-generic-function)
698 ; (qualifiers
699 ; :initform ()
700 ; :initarg :qualifiers
701 ; :reader method-qualifiers)
702 (specializers
703 :initform ()
704 :initarg :specializers
705 :reader method-specializers)
706 (lambda-list
707 :initform ()
708 :initarg :lambda-list
709 :reader method-lambda-list)
710 (function
711 :initform nil
712 :initarg :function) ;no writer
713 (fast-function
714 :initform nil
715 :initarg :fast-function ;no writer
716 :reader method-fast-function)
717 ; (documentation
718 ; :initform nil
719 ; :initarg :documentation
720 ; :reader method-documentation)
721 ))
722
723 (defclass standard-accessor-method (standard-method)
724 ((slot-name :initform nil
725 :initarg :slot-name
726 :reader accessor-method-slot-name)
727 (slot-definition :initform nil
728 :initarg :slot-definition
729 :reader accessor-method-slot-definition)))
730
731 (defclass standard-reader-method (standard-accessor-method) ())
732
733 (defclass standard-writer-method (standard-accessor-method) ())
734
735 (defclass standard-boundp-method (standard-accessor-method) ())
736
737 (defclass generic-function (dependent-update-mixin
738 definition-source-mixin
739 documentation-mixin
740 funcallable-standard-object)
741 ()
742 (:metaclass funcallable-standard-class))
743
744 (defclass standard-generic-function (generic-function)
745 ((name
746 :initform nil
747 :initarg :name
748 :accessor generic-function-name)
749 (methods
750 :initform ()
751 :accessor generic-function-methods)
752 (method-class
753 :initarg :method-class
754 :accessor generic-function-method-class)
755 (method-combination
756 :initarg :method-combination
757 :accessor generic-function-method-combination)
758 (arg-info
759 :initform (make-arg-info)
760 :reader gf-arg-info)
761 (dfun-state
762 :initform ()
763 :accessor gf-dfun-state)
764 (pretty-arglist
765 :initform ()
766 :accessor gf-pretty-arglist)
767 )
768 (:metaclass funcallable-standard-class)
769 (:default-initargs :method-class *the-class-standard-method*
770 :method-combination *standard-method-combination*))
771
772 (defclass method-combination (standard-object) ())
773
774 (defclass standard-method-combination
775 (definition-source-mixin method-combination)
776 ((type :reader method-combination-type
777 :initarg :type)
778 (documentation :reader method-combination-documentation
779 :initarg :documentation)
780 (options :reader method-combination-options
781 :initarg :options)))
782
783 (defparameter *early-class-predicates*
784 '((specializer specializerp)
785 (exact-class-specializer exact-class-specializer-p)
786 (class-eq-specializer class-eq-specializer-p)
787 (eql-specializer eql-specializer-p)
788 (class classp)
789 (slot-class slot-class-p)
790 (std-class std-class-p)
791 (standard-class standard-class-p)
792 (funcallable-standard-class funcallable-standard-class-p)
793 (structure-class structure-class-p)
794 (forward-referenced-class forward-referenced-class-p)
795 (method method-p)
796 (standard-method standard-method-p)
797 (standard-accessor-method standard-accessor-method-p)
798 (standard-reader-method standard-reader-method-p)
799 (standard-writer-method standard-writer-method-p)
800 (standard-boundp-method standard-boundp-method-p)
801 (generic-function generic-function-p)
802 (standard-generic-function standard-generic-function-p)
803 (method-combination method-combination-p)))
804

  ViewVC Help
Powered by ViewVC 1.1.5