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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11.2.5 - (show annotations)
Tue Aug 8 14:42:30 2000 UTC (13 years, 8 months ago) by pw
Branch: RELENG_18
CVS Tags: RELEASE_18c
Changes since 1.11.2.4: +2 -1 lines
Disable new code in inform-type-system-about-std-class which seems
to trigger trouble when native compiling defcombin.lisp
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 (declare (ignorable name))
195 #+nil ;; This is causing problems with native compile of defcombin.lisp
196 (when (and (eq *boot-state* 'complete)
197 (null (lisp:find-class name nil)))
198 (setf (lisp:find-class name)
199 (lisp::make-standard-class :name name))))
200
201 (defun make-class-eq-predicate (class)
202 (when (symbolp class) (setq class (find-class class)))
203 #'(lambda (object) (eq class (class-of object))))
204
205 (defun make-eql-predicate (eql-object)
206 #'(lambda (object) (eql eql-object object)))
207
208
209 ;;; Internal to this file.
210 ;;;
211 ;;; These functions are a pale imitiation of their namesake. They accept
212 ;;; class objects or types where they should.
213 ;;;
214 (defun *normalize-type (type)
215 (cond ((consp type)
216 (if (member (car type) '(not and or))
217 `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
218 (if (null (cdr type))
219 (*normalize-type (car type))
220 type)))
221 ((symbolp type)
222 (let ((class (find-class type nil)))
223 (if class
224 (let ((type (specializer-type class)))
225 (if (listp type) type `(,type)))
226 `(,type))))
227 ((or (not (eq *boot-state* 'complete))
228 (specializerp type))
229 (specializer-type type))
230 (t
231 (error "~s is not a type" type))))
232
233 ;;; internal to this file...
234 (defun convert-to-system-type (type)
235 (case (car type)
236 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
237 (cdr type))))
238 ((class class-eq) ; class-eq is impossible to do right
239 (kernel:layout-class (class-wrapper (cadr type))))
240 (eql type)
241 (t (if (null (cdr type))
242 (car type)
243 type))))
244
245
246 ;;; *SUBTYPEP -- Interface
247 ;;;
248 ;Writing the missing NOT and AND clauses will improve
249 ;the quality of code generated by generate-discrimination-net, but
250 ;calling subtypep in place of just returning (values nil nil) can be
251 ;very slow. *subtypep is used by PCL itself, and must be fast.
252 (defun *subtypep (type1 type2)
253 (if (equal type1 type2)
254 (values t t)
255 (if (eq *boot-state* 'early)
256 (values (eq type1 type2) t)
257 (let ((*in-precompute-effective-methods-p* t))
258 (declare (special *in-precompute-effective-methods-p*))
259 ;; *in-precompute-effective-methods-p* is not a good name.
260 ;; It changes the way class-applicable-using-class-p works.
261 (setq type1 (*normalize-type type1))
262 (setq type2 (*normalize-type type2))
263 (case (car type2)
264 (not
265 (values nil nil)) ; Should improve this.
266 (and
267 (values nil nil)) ; Should improve this.
268 ((eql wrapper-eq class-eq class)
269 (multiple-value-bind (app-p maybe-app-p)
270 (specializer-applicable-using-type-p type2 type1)
271 (values app-p (or app-p (not maybe-app-p)))))
272 (t
273 (subtypep (convert-to-system-type type1)
274 (convert-to-system-type type2))))))))
275
276
277 (defvar *built-in-class-symbols* ())
278 (defvar *built-in-wrapper-symbols* ())
279
280 (defun get-built-in-class-symbol (class-name)
281 (or (cadr (assq class-name *built-in-class-symbols*))
282 (let ((symbol (intern (format nil
283 "*THE-CLASS-~A*"
284 (symbol-name class-name))
285 *the-pcl-package*)))
286 (push (list class-name symbol) *built-in-class-symbols*)
287 symbol)))
288
289 (defun get-built-in-wrapper-symbol (class-name)
290 (or (cadr (assq class-name *built-in-wrapper-symbols*))
291 (let ((symbol (intern (format nil
292 "*THE-WRAPPER-OF-~A*"
293 (symbol-name class-name))
294 *the-pcl-package*)))
295 (push (list class-name symbol) *built-in-wrapper-symbols*)
296 symbol)))
297
298
299
300
301 (pushnew 'class *variable-declarations*)
302 (pushnew 'variable-rebinding *variable-declarations*)
303
304 (defun variable-class (var env)
305 (caddr (variable-declaration 'class var env)))
306
307 (defvar *name->class->slotd-table* (make-hash-table))
308
309
310 ;;;
311 ;;; This is used by combined methods to communicate the next methods to
312 ;;; the methods they call. This variable is captured by a lexical variable
313 ;;; of the methods to give it the proper lexical scope.
314 ;;;
315 (defvar *next-methods* nil)
316
317 (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
318
319 (defvar *umi-gfs*)
320 (defvar *umi-complete-classes*)
321 (defvar *umi-reorder*)
322
323 (defvar *invalidate-discriminating-function-force-p* ())
324 (defvar *invalid-dfuns-on-stack* ())
325
326
327 (defvar *standard-method-combination*)
328
329 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
330
331
332 (defmacro define-gf-predicate (predicate-name &rest classes)
333 `(progn
334 (defmethod ,predicate-name ((x t)) nil)
335 ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
336 classes)))
337
338 (defun make-class-predicate-name (name)
339 (intern (format nil "~A::~A class predicate"
340 (package-name (symbol-package name))
341 name)
342 *the-pcl-package*))
343
344 (defun plist-value (object name)
345 (getf (object-plist object) name))
346
347 (defun (setf plist-value) (new-value object name)
348 (if new-value
349 (setf (getf (object-plist object) name) new-value)
350 (progn
351 (remf (object-plist object) name)
352 nil)))
353
354
355
356 (defvar *built-in-classes*
357 ;;
358 ;; name supers subs cdr of cpl
359 ;; prototype
360 '(;(t () (number sequence array character symbol) ())
361 (number (t) (complex float rational) (t))
362 (complex (number) () (number t)
363 #c(1 1))
364 (float (number) () (number t)
365 1.0)
366 (rational (number) (integer ratio) (number t))
367 (integer (rational) () (rational number t)
368 1)
369 (ratio (rational) () (rational number t)
370 1/2)
371
372 (sequence (t) (list vector) (t))
373 (list (sequence) (cons null) (sequence t))
374 (cons (list) () (list sequence t)
375 (nil))
376
377
378 (array (t) (vector) (t)
379 #2A((NIL)))
380 (vector (array
381 sequence) (string bit-vector) (array sequence t)
382 #())
383 (string (vector) () (vector array sequence t)
384 "")
385 (bit-vector (vector) () (vector array sequence t)
386 #*1)
387 (character (t) () (t)
388 #\c)
389
390 (symbol (t) (null) (t)
391 symbol)
392 (null (symbol
393 list) () (symbol list sequence t)
394 nil)))
395
396 (labels ((direct-supers (class)
397 (if (typep class 'lisp:built-in-class)
398 (kernel:built-in-class-direct-superclasses class)
399 (let ((inherits (kernel:layout-inherits
400 (kernel:class-layout class))))
401 (list (svref inherits (1- (length inherits)))))))
402 (direct-subs (class)
403 (ext:collect ((res))
404 (let ((subs (kernel:class-subclasses class)))
405 (when subs
406 (ext:do-hash (sub v subs)
407 (declare (ignore v))
408 (when (member class (direct-supers sub))
409 (res sub)))))
410 (res))))
411 (ext:collect ((res))
412 (dolist (bic kernel::built-in-classes)
413 (let* ((name (car bic))
414 (class (lisp:find-class name)))
415 (unless (member name '(t kernel:instance kernel:funcallable-instance
416 function stream))
417 (res `(,name
418 ,(mapcar #'lisp:class-name (direct-supers class))
419 ,(mapcar #'lisp:class-name (direct-subs class))
420 ,(map 'list #'(lambda (x)
421 (lisp:class-name (kernel:layout-class x)))
422 (reverse
423 (kernel:layout-inherits
424 (kernel:class-layout class))))
425 ,(let ((found (assoc name *built-in-classes*)))
426 (if found (fifth found) 42)))))))
427 (setq *built-in-classes* (res))))
428
429
430 ;;;
431 ;;; The classes that define the kernel of the metabraid.
432 ;;;
433 (defclass t () ()
434 (:metaclass built-in-class))
435
436 (defclass kernel:instance (t) ()
437 (:metaclass built-in-class))
438
439 (defclass function (t) ()
440 (:metaclass built-in-class))
441
442 (defclass kernel:funcallable-instance (function) ()
443 (:metaclass built-in-class))
444
445 (defclass stream (kernel:instance) ()
446 (:metaclass built-in-class))
447
448 (defclass slot-object (t) ()
449 (:metaclass slot-class))
450
451 (defclass structure-object (slot-object kernel:instance) ()
452 (:metaclass structure-class))
453
454 (defstruct (dead-beef-structure-object
455 (:constructor |STRUCTURE-OBJECT class constructor|)))
456
457
458 (defclass std-object (slot-object) ()
459 (:metaclass std-class))
460
461 (defclass standard-object (std-object kernel:instance) ())
462
463 (defclass funcallable-standard-object (std-object
464 kernel:funcallable-instance)
465 ()
466 (:metaclass funcallable-standard-class))
467
468 (defclass specializer (standard-object)
469 ((type
470 :initform nil
471 :reader specializer-type)))
472
473 (defclass definition-source-mixin (std-object)
474 ((source
475 :initform (load-truename)
476 :reader definition-source
477 :initarg :definition-source))
478 (:metaclass std-class))
479
480 (defclass plist-mixin (std-object)
481 ((plist
482 :initform ()
483 :accessor object-plist))
484 (:metaclass std-class))
485
486 (defclass documentation-mixin (plist-mixin)
487 ()
488 (:metaclass std-class))
489
490 (defclass dependent-update-mixin (plist-mixin)
491 ()
492 (:metaclass std-class))
493
494 ;;;
495 ;;; The class CLASS is a specified basic class. It is the common superclass
496 ;;; of any kind of class. That is any class that can be a metaclass must
497 ;;; have the class CLASS in its class precedence list.
498 ;;;
499 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
500 specializer)
501 ((name
502 :initform nil
503 :initarg :name
504 :accessor class-name)
505 (class-eq-specializer
506 :initform nil
507 :reader class-eq-specializer)
508 (direct-superclasses
509 :initform ()
510 :reader class-direct-superclasses)
511 (direct-subclasses
512 :initform ()
513 :reader class-direct-subclasses)
514 (direct-methods
515 :initform (cons nil nil))
516 (predicate-name
517 :initform nil
518 :reader class-predicate-name)))
519
520 ;;;
521 ;;; The class PCL-CLASS is an implementation-specific common superclass of
522 ;;; all specified subclasses of the class CLASS.
523 ;;;
524 (defclass pcl-class (class)
525 ((class-precedence-list
526 :reader class-precedence-list)
527 (can-precede-list
528 :initform ()
529 :reader class-can-precede-list)
530 (incompatible-superclass-list
531 :initform ()
532 :accessor class-incompatible-superclass-list)
533 (wrapper
534 :initform nil
535 :reader class-wrapper)
536 (prototype
537 :initform nil
538 :reader class-prototype)))
539
540 (defclass slot-class (pcl-class)
541 ((direct-slots
542 :initform ()
543 :accessor class-direct-slots)
544 (slots
545 :initform ()
546 :accessor class-slots)
547 (initialize-info
548 :initform nil
549 :accessor class-initialize-info)))
550
551 ;;;
552 ;;; The class STD-CLASS is an implementation-specific common superclass of
553 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
554 ;;;
555 (defclass std-class (slot-class)
556 ())
557
558 (defclass standard-class (std-class)
559 ())
560
561 (defclass funcallable-standard-class (std-class)
562 ())
563
564 (defclass forward-referenced-class (pcl-class) ())
565
566 (defclass built-in-class (pcl-class) ())
567
568 (defclass structure-class (slot-class)
569 ((defstruct-form
570 :initform ()
571 :accessor class-defstruct-form)
572 (defstruct-constructor
573 :initform nil
574 :accessor class-defstruct-constructor)
575 (from-defclass-p
576 :initform nil
577 :initarg :from-defclass-p)))
578
579
580 (defclass specializer-with-object (specializer) ())
581
582 (defclass exact-class-specializer (specializer) ())
583
584 (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
585 ((object :initarg :class :reader specializer-class :reader specializer-object)))
586
587 (defclass class-prototype-specializer (specializer-with-object)
588 ((object :initarg :class :reader specializer-class :reader specializer-object)))
589
590 (defclass eql-specializer (exact-class-specializer specializer-with-object)
591 ((object :initarg :object :reader specializer-object
592 :reader eql-specializer-object)))
593
594 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
595
596 (defun intern-eql-specializer (object)
597 (or (gethash object *eql-specializer-table*)
598 (setf (gethash object *eql-specializer-table*)
599 (make-instance 'eql-specializer :object object))))
600
601
602 ;;;
603 ;;; Slot definitions.
604 ;;;
605 (defclass slot-definition (standard-object)
606 ((name
607 :initform nil
608 :initarg :name
609 :accessor slot-definition-name)
610 (initform
611 :initform nil
612 :initarg :initform
613 :accessor slot-definition-initform)
614 (initfunction
615 :initform nil
616 :initarg :initfunction
617 :accessor slot-definition-initfunction)
618 (readers
619 :initform nil
620 :initarg :readers
621 :accessor slot-definition-readers)
622 (writers
623 :initform nil
624 :initarg :writers
625 :accessor slot-definition-writers)
626 (initargs
627 :initform nil
628 :initarg :initargs
629 :accessor slot-definition-initargs)
630 (type
631 :initform t
632 :initarg :type
633 :accessor slot-definition-type)
634 (documentation
635 :initform ""
636 :initarg :documentation)
637 (class
638 :initform nil
639 :initarg :class
640 :accessor slot-definition-class)))
641
642 (defclass standard-slot-definition (slot-definition)
643 ((allocation
644 :initform :instance
645 :initarg :allocation
646 :accessor slot-definition-allocation)))
647
648 (defclass structure-slot-definition (slot-definition)
649 ((defstruct-accessor-symbol
650 :initform nil
651 :initarg :defstruct-accessor-symbol
652 :accessor slot-definition-defstruct-accessor-symbol)
653 (internal-reader-function
654 :initform nil
655 :initarg :internal-reader-function
656 :accessor slot-definition-internal-reader-function)
657 (internal-writer-function
658 :initform nil
659 :initarg :internal-writer-function
660 :accessor slot-definition-internal-writer-function)))
661
662 (defclass direct-slot-definition (slot-definition)
663 ())
664
665 (defclass effective-slot-definition (slot-definition)
666 ((reader-function ; #'(lambda (object) ...)
667 :accessor slot-definition-reader-function)
668 (writer-function ; #'(lambda (new-value object) ...)
669 :accessor slot-definition-writer-function)
670 (boundp-function ; #'(lambda (object) ...)
671 :accessor slot-definition-boundp-function)
672 (accessor-flags
673 :initform 0)))
674
675 (defclass standard-direct-slot-definition (standard-slot-definition
676 direct-slot-definition)
677 ())
678
679 (defclass standard-effective-slot-definition (standard-slot-definition
680 effective-slot-definition)
681 ((location ; nil, a fixnum, a cons: (slot-name . value)
682 :initform nil
683 :accessor slot-definition-location)))
684
685 (defclass structure-direct-slot-definition (structure-slot-definition
686 direct-slot-definition)
687 ())
688
689 (defclass structure-effective-slot-definition (structure-slot-definition
690 effective-slot-definition)
691 ())
692
693 (defclass method (standard-object) ())
694
695 (defclass standard-method (definition-source-mixin plist-mixin method)
696 ((generic-function
697 :initform nil
698 :accessor method-generic-function)
699 ; (qualifiers
700 ; :initform ()
701 ; :initarg :qualifiers
702 ; :reader method-qualifiers)
703 (specializers
704 :initform ()
705 :initarg :specializers
706 :reader method-specializers)
707 (lambda-list
708 :initform ()
709 :initarg :lambda-list
710 :reader method-lambda-list)
711 (function
712 :initform nil
713 :initarg :function) ;no writer
714 (fast-function
715 :initform nil
716 :initarg :fast-function ;no writer
717 :reader method-fast-function)
718 ; (documentation
719 ; :initform nil
720 ; :initarg :documentation
721 ; :reader method-documentation)
722 ))
723
724 (defclass standard-accessor-method (standard-method)
725 ((slot-name :initform nil
726 :initarg :slot-name
727 :reader accessor-method-slot-name)
728 (slot-definition :initform nil
729 :initarg :slot-definition
730 :reader accessor-method-slot-definition)))
731
732 (defclass standard-reader-method (standard-accessor-method) ())
733
734 (defclass standard-writer-method (standard-accessor-method) ())
735
736 (defclass standard-boundp-method (standard-accessor-method) ())
737
738 (defclass generic-function (dependent-update-mixin
739 definition-source-mixin
740 documentation-mixin
741 funcallable-standard-object)
742 ()
743 (:metaclass funcallable-standard-class))
744
745 (defclass standard-generic-function (generic-function)
746 ((name
747 :initform nil
748 :initarg :name
749 :accessor generic-function-name)
750 (methods
751 :initform ()
752 :accessor generic-function-methods)
753 (method-class
754 :initarg :method-class
755 :accessor generic-function-method-class)
756 (method-combination
757 :initarg :method-combination
758 :accessor generic-function-method-combination)
759 (arg-info
760 :initform (make-arg-info)
761 :reader gf-arg-info)
762 (dfun-state
763 :initform ()
764 :accessor gf-dfun-state)
765 (pretty-arglist
766 :initform ()
767 :accessor gf-pretty-arglist)
768 )
769 (:metaclass funcallable-standard-class)
770 (:default-initargs :method-class *the-class-standard-method*
771 :method-combination *standard-method-combination*))
772
773 (defclass method-combination (standard-object) ())
774
775 (defclass standard-method-combination
776 (definition-source-mixin method-combination)
777 ((type :reader method-combination-type
778 :initarg :type)
779 (documentation :reader method-combination-documentation
780 :initarg :documentation)
781 (options :reader method-combination-options
782 :initarg :options)))
783
784 (defparameter *early-class-predicates*
785 '((specializer specializerp)
786 (exact-class-specializer exact-class-specializer-p)
787 (class-eq-specializer class-eq-specializer-p)
788 (eql-specializer eql-specializer-p)
789 (class classp)
790 (slot-class slot-class-p)
791 (std-class std-class-p)
792 (standard-class standard-class-p)
793 (funcallable-standard-class funcallable-standard-class-p)
794 (structure-class structure-class-p)
795 (forward-referenced-class forward-referenced-class-p)
796 (method method-p)
797 (standard-method standard-method-p)
798 (standard-accessor-method standard-accessor-method-p)
799 (standard-reader-method standard-reader-method-p)
800 (standard-writer-method standard-writer-method-p)
801 (standard-boundp-method standard-boundp-method-p)
802 (generic-function generic-function-p)
803 (standard-generic-function standard-generic-function-p)
804 (method-combination method-combination-p)))
805

  ViewVC Help
Powered by ViewVC 1.1.5