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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Sun Mar 14 01:14:13 1999 UTC (15 years, 1 month ago) by dtc
Branch: MAIN
Changes since 1.15: +3 -43 lines
Further cleanup of the code now that the :SETF feature is assumed standard.
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 #+cmu (progn
76 (c::%%defun name new-definition nil)
77 (c::note-name-defined name :function)
78 new-definition)
79 #-(or cmu)
80 (setf (symbol-function name) new-definition))
81
82
83
84 (proclaim '(special *the-class-t*
85 *the-class-vector* *the-class-symbol*
86 *the-class-string* *the-class-sequence*
87 *the-class-rational* *the-class-ratio*
88 *the-class-number* *the-class-null* *the-class-list*
89 *the-class-integer* *the-class-float* *the-class-cons*
90 *the-class-complex* *the-class-character*
91 *the-class-bit-vector* *the-class-array*
92 *the-class-stream*
93
94 *the-class-slot-object*
95 *the-class-structure-object*
96 *the-class-std-object*
97 *the-class-standard-object*
98 *the-class-funcallable-standard-object*
99 *the-class-class*
100 *the-class-generic-function*
101 *the-class-built-in-class*
102 *the-class-slot-class*
103 *the-class-structure-class*
104 *the-class-std-class*
105 *the-class-standard-class*
106 *the-class-funcallable-standard-class*
107 *the-class-method*
108 *the-class-standard-method*
109 *the-class-standard-reader-method*
110 *the-class-standard-writer-method*
111 *the-class-standard-boundp-method*
112 *the-class-standard-generic-function*
113 *the-class-standard-effective-slot-definition*
114
115 *the-eslotd-standard-class-slots*
116 *the-eslotd-funcallable-standard-class-slots*))
117
118 (proclaim '(special *the-wrapper-of-t*
119 *the-wrapper-of-vector* *the-wrapper-of-symbol*
120 *the-wrapper-of-string* *the-wrapper-of-sequence*
121 *the-wrapper-of-rational* *the-wrapper-of-ratio*
122 *the-wrapper-of-number* *the-wrapper-of-null*
123 *the-wrapper-of-list* *the-wrapper-of-integer*
124 *the-wrapper-of-float* *the-wrapper-of-cons*
125 *the-wrapper-of-complex* *the-wrapper-of-character*
126 *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
127
128 ;;;; Type specifier hackery:
129
130 ;;; internal to this file.
131 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
132 (if (symbolp class)
133 (or (find-class class (not make-forward-referenced-class-p))
134 (ensure-class class))
135 class))
136
137 ;;; Interface
138 (defun specializer-from-type (type &aux args)
139 (when (consp type)
140 (setq args (cdr type) type (car type)))
141 (cond ((symbolp type)
142 (or (and (null args) (find-class type))
143 (ecase type
144 (class (coerce-to-class (car args)))
145 (prototype (make-instance 'class-prototype-specializer
146 :object (coerce-to-class (car args))))
147 (class-eq (class-eq-specializer (coerce-to-class (car args))))
148 (eql (intern-eql-specializer (car args))))))
149 #+cmu17
150 ((and (null args) (typep type 'lisp:class))
151 (or (kernel:class-pcl-class type)
152 (find-structure-class (lisp:class-name type))))
153 ((specializerp type) type)))
154
155 ;;; interface
156 (defun type-from-specializer (specl)
157 (cond ((eq specl 't)
158 't)
159 ((consp specl)
160 (unless (member (car specl) '(class prototype class-eq eql))
161 (error "~S is not a legal specializer type" specl))
162 specl)
163 ((progn
164 (when (symbolp specl)
165 ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
166 (setq specl (find-class specl)))
167 (or (not (eq *boot-state* 'complete))
168 (specializerp specl)))
169 (specializer-type specl))
170 (t
171 (error "~s is neither a type nor a specializer" specl))))
172
173 (defun type-class (type)
174 (declare (special *the-class-t*))
175 (setq type (type-from-specializer type))
176 (if (atom type)
177 (if (eq type 't)
178 *the-class-t*
179 (error "bad argument to type-class"))
180 (case (car type)
181 (eql (class-of (cadr type)))
182 (prototype (class-of (cadr type))) ;?
183 (class-eq (cadr type))
184 (class (cadr type)))))
185
186 (defun class-eq-type (class)
187 (specializer-type (class-eq-specializer class)))
188
189 (defun inform-type-system-about-std-class (name)
190 (let ((predicate-name (make-type-predicate-name name)))
191 (setf (gdefinition predicate-name) (make-type-predicate name))
192 (do-satisfies-deftype name predicate-name)))
193
194 (defun make-type-predicate (name)
195 (let ((cell (find-class-cell name)))
196 #'(lambda (x)
197 (funcall (the function (find-class-cell-predicate cell)) x))))
198
199
200 ;This stuff isn't right. Good thing it isn't used.
201 ;The satisfies predicate has to be a symbol. There is no way to
202 ;construct such a symbol from a class object if class names change.
203 (defun class-predicate (class)
204 (when (symbolp class) (setq class (find-class class)))
205 #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
206
207 (defun make-class-eq-predicate (class)
208 (when (symbolp class) (setq class (find-class class)))
209 #'(lambda (object) (eq class (class-of object))))
210
211 (defun make-eql-predicate (eql-object)
212 #'(lambda (object) (eql eql-object object)))
213
214
215 ;;; Internal to this file.
216 ;;;
217 ;;; These functions are a pale imitiation of their namesake. They accept
218 ;;; class objects or types where they should.
219 ;;;
220 (defun *normalize-type (type)
221 (cond ((consp type)
222 (if (member (car type) '(not and or))
223 `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
224 (if (null (cdr type))
225 (*normalize-type (car type))
226 type)))
227 ((symbolp type)
228 (let ((class (find-class type nil)))
229 (if class
230 (let ((type (specializer-type class)))
231 (if (listp type) type `(,type)))
232 `(,type))))
233 ((or (not (eq *boot-state* 'complete))
234 (specializerp type))
235 (specializer-type type))
236 (t
237 (error "~s is not a type" type))))
238
239 ;;; internal to this file...
240 (defun convert-to-system-type (type)
241 (case (car type)
242 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
243 (cdr type))))
244 ((class class-eq) ; class-eq is impossible to do right
245 #-cmu17 (class-name (cadr type))
246 #+cmu17 (kernel:layout-class (class-wrapper (cadr type))))
247 (eql type)
248 (t (if (null (cdr type))
249 (car type)
250 type))))
251
252
253 ;;; *SUBTYPEP -- Interface
254 ;;;
255 ;Writing the missing NOT and AND clauses will improve
256 ;the quality of code generated by generate-discrimination-net, but
257 ;calling subtypep in place of just returning (values nil nil) can be
258 ;very slow. *subtypep is used by PCL itself, and must be fast.
259 (defun *subtypep (type1 type2)
260 (if (equal type1 type2)
261 (values t t)
262 (if (eq *boot-state* 'early)
263 (values (eq type1 type2) t)
264 (let ((*in-precompute-effective-methods-p* t))
265 (declare (special *in-precompute-effective-methods-p*))
266 ;; *in-precompute-effective-methods-p* is not a good name.
267 ;; It changes the way class-applicable-using-class-p works.
268 (setq type1 (*normalize-type type1))
269 (setq type2 (*normalize-type type2))
270 (case (car type2)
271 (not
272 (values nil nil)) ; Should improve this.
273 (and
274 (values nil nil)) ; Should improve this.
275 ((eql wrapper-eq class-eq class)
276 (multiple-value-bind (app-p maybe-app-p)
277 (specializer-applicable-using-type-p type2 type1)
278 (values app-p (or app-p (not maybe-app-p)))))
279 (t
280 (subtypep (convert-to-system-type type1)
281 (convert-to-system-type type2))))))))
282
283 (defun do-satisfies-deftype (name predicate)
284 #+cmu17 (declare (ignore name predicate))
285 #-(or cmu17)
286 ;; This is the default for ports for which we don't know any
287 ;; better. Note that for most ports, providing this definition
288 ;; should just speed up class definition. It shouldn't have an
289 ;; effect on performance of most user code.
290 (eval `(deftype ,name () '(satisfies ,predicate))))
291
292 (defun make-type-predicate-name (name &optional kind)
293 (if (symbol-package name)
294 (intern (format nil
295 "~@[~A ~]TYPE-PREDICATE ~A ~A"
296 kind
297 (package-name (symbol-package name))
298 (symbol-name name))
299 *the-pcl-package*)
300 (make-symbol (format nil
301 "~@[~A ~]TYPE-PREDICATE ~A"
302 kind
303 (symbol-name name)))))
304
305
306
307 (defvar *built-in-class-symbols* ())
308 (defvar *built-in-wrapper-symbols* ())
309
310 (defun get-built-in-class-symbol (class-name)
311 (or (cadr (assq class-name *built-in-class-symbols*))
312 (let ((symbol (intern (format nil
313 "*THE-CLASS-~A*"
314 (symbol-name class-name))
315 *the-pcl-package*)))
316 (push (list class-name symbol) *built-in-class-symbols*)
317 symbol)))
318
319 (defun get-built-in-wrapper-symbol (class-name)
320 (or (cadr (assq class-name *built-in-wrapper-symbols*))
321 (let ((symbol (intern (format nil
322 "*THE-WRAPPER-OF-~A*"
323 (symbol-name class-name))
324 *the-pcl-package*)))
325 (push (list class-name symbol) *built-in-wrapper-symbols*)
326 symbol)))
327
328
329
330
331 (pushnew 'class *variable-declarations*)
332 (pushnew 'variable-rebinding *variable-declarations*)
333
334 (defun variable-class (var env)
335 (caddr (variable-declaration 'class var env)))
336
337 (defvar *name->class->slotd-table* (make-hash-table))
338
339
340 ;;;
341 ;;; This is used by combined methods to communicate the next methods to
342 ;;; the methods they call. This variable is captured by a lexical variable
343 ;;; of the methods to give it the proper lexical scope.
344 ;;;
345 (defvar *next-methods* nil)
346
347 (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
348
349 (defvar *umi-gfs*)
350 (defvar *umi-complete-classes*)
351 (defvar *umi-reorder*)
352
353 (defvar *invalidate-discriminating-function-force-p* ())
354 (defvar *invalid-dfuns-on-stack* ())
355
356
357 (defvar *standard-method-combination*)
358
359 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
360
361
362 (defmacro define-gf-predicate (predicate-name &rest classes)
363 `(progn
364 (defmethod ,predicate-name ((x t)) nil)
365 ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
366 classes)))
367
368 (defun make-class-predicate-name (name)
369 (intern (format nil "~A::~A class predicate"
370 (package-name (symbol-package name))
371 name)
372 *the-pcl-package*))
373
374 (defun plist-value (object name)
375 (getf (object-plist object) name))
376
377 (defun (setf plist-value) (new-value object name)
378 (if new-value
379 (setf (getf (object-plist object) name) new-value)
380 (progn
381 (remf (object-plist object) name)
382 nil)))
383
384
385
386 (defvar *built-in-classes*
387 ;;
388 ;; name supers subs cdr of cpl
389 ;; prototype
390 '(;(t () (number sequence array character symbol) ())
391 (number (t) (complex float rational) (t))
392 (complex (number) () (number t)
393 #c(1 1))
394 (float (number) () (number t)
395 1.0)
396 (rational (number) (integer ratio) (number t))
397 (integer (rational) () (rational number t)
398 1)
399 (ratio (rational) () (rational number t)
400 1/2)
401
402 (sequence (t) (list vector) (t))
403 (list (sequence) (cons null) (sequence t))
404 (cons (list) () (list sequence t)
405 (nil))
406
407
408 (array (t) (vector) (t)
409 #2A((NIL)))
410 (vector (array
411 sequence) (string bit-vector) (array sequence t)
412 #())
413 (string (vector) () (vector array sequence t)
414 "")
415 (bit-vector (vector) () (vector array sequence t)
416 #*1)
417 (character (t) () (t)
418 #\c)
419
420 (symbol (t) (null) (t)
421 symbol)
422 (null (symbol
423 list) () (symbol list sequence t)
424 nil)))
425
426 #+cmu17
427 (labels ((direct-supers (class)
428 (if (typep class 'lisp:built-in-class)
429 (kernel:built-in-class-direct-superclasses class)
430 (let ((inherits (kernel:layout-inherits
431 (kernel:class-layout class))))
432 (list (svref inherits (1- (length inherits)))))))
433 (direct-subs (class)
434 (ext:collect ((res))
435 (let ((subs (kernel:class-subclasses class)))
436 (when subs
437 (ext:do-hash (sub v subs)
438 (declare (ignore v))
439 (when (member class (direct-supers sub))
440 (res sub)))))
441 (res))))
442 (ext:collect ((res))
443 (dolist (bic kernel::built-in-classes)
444 (let* ((name (car bic))
445 (class (lisp:find-class name)))
446 (unless (member name '(t kernel:instance kernel:funcallable-instance
447 function stream))
448 (res `(,name
449 ,(mapcar #'lisp:class-name (direct-supers class))
450 ,(mapcar #'lisp:class-name (direct-subs class))
451 ,(map 'list #'(lambda (x)
452 (lisp:class-name (kernel:layout-class x)))
453 (reverse
454 (kernel:layout-inherits
455 (kernel:class-layout class))))
456 ,(let ((found (assoc name *built-in-classes*)))
457 (if found (fifth found) 42)))))))
458 (setq *built-in-classes* (res))))
459
460
461 ;;;
462 ;;; The classes that define the kernel of the metabraid.
463 ;;;
464 (defclass t () ()
465 (:metaclass built-in-class))
466
467 #+cmu17
468 (progn
469 (defclass kernel:instance (t) ()
470 (:metaclass built-in-class))
471
472 (defclass function (t) ()
473 (:metaclass built-in-class))
474
475 (defclass kernel:funcallable-instance (function) ()
476 (:metaclass built-in-class))
477
478 (defclass stream (t) ()
479 (:metaclass built-in-class)))
480
481 (defclass slot-object (t) ()
482 (:metaclass slot-class))
483
484 (defclass structure-object (slot-object #+cmu17 kernel:instance) ()
485 (:metaclass structure-class))
486
487 (defstruct (dead-beef-structure-object
488 (:constructor |STRUCTURE-OBJECT class constructor|)))
489
490
491 (defclass std-object (slot-object) ()
492 (:metaclass std-class))
493
494 (defclass standard-object (std-object #+cmu17 kernel:instance) ())
495
496 (defclass funcallable-standard-object (std-object
497 #+cmu17 kernel:funcallable-instance)
498 ()
499 (:metaclass funcallable-standard-class))
500
501 (defclass specializer (standard-object)
502 ((type
503 :initform nil
504 :reader specializer-type)))
505
506 (defclass definition-source-mixin (std-object)
507 ((source
508 :initform (load-truename)
509 :reader definition-source
510 :initarg :definition-source))
511 (:metaclass std-class))
512
513 (defclass plist-mixin (std-object)
514 ((plist
515 :initform ()
516 :accessor object-plist))
517 (:metaclass std-class))
518
519 (defclass documentation-mixin (plist-mixin)
520 ()
521 (:metaclass std-class))
522
523 (defclass dependent-update-mixin (plist-mixin)
524 ()
525 (:metaclass std-class))
526
527 ;;;
528 ;;; The class CLASS is a specified basic class. It is the common superclass
529 ;;; of any kind of class. That is any class that can be a metaclass must
530 ;;; have the class CLASS in its class precedence list.
531 ;;;
532 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
533 specializer)
534 ((name
535 :initform nil
536 :initarg :name
537 :accessor class-name)
538 (class-eq-specializer
539 :initform nil
540 :reader class-eq-specializer)
541 (direct-superclasses
542 :initform ()
543 :reader class-direct-superclasses)
544 (direct-subclasses
545 :initform ()
546 :reader class-direct-subclasses)
547 (direct-methods
548 :initform (cons nil nil))
549 (predicate-name
550 :initform nil
551 :reader class-predicate-name)))
552
553 ;;;
554 ;;; The class PCL-CLASS is an implementation-specific common superclass of
555 ;;; all specified subclasses of the class CLASS.
556 ;;;
557 (defclass pcl-class (class)
558 ((class-precedence-list
559 :reader class-precedence-list)
560 (can-precede-list
561 :initform ()
562 :reader class-can-precede-list)
563 (incompatible-superclass-list
564 :initform ()
565 :accessor class-incompatible-superclass-list)
566 (wrapper
567 :initform nil
568 :reader class-wrapper)
569 (prototype
570 :initform nil
571 :reader class-prototype)))
572
573 (defclass slot-class (pcl-class)
574 ((direct-slots
575 :initform ()
576 :accessor class-direct-slots)
577 (slots
578 :initform ()
579 :accessor class-slots)
580 (initialize-info
581 :initform nil
582 :accessor class-initialize-info)))
583
584 ;;;
585 ;;; The class STD-CLASS is an implementation-specific common superclass of
586 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
587 ;;;
588 (defclass std-class (slot-class)
589 ())
590
591 (defclass standard-class (std-class)
592 ())
593
594 (defclass funcallable-standard-class (std-class)
595 ())
596
597 (defclass forward-referenced-class (pcl-class) ())
598
599 (defclass built-in-class (pcl-class) ())
600
601 (defclass structure-class (slot-class)
602 ((defstruct-form
603 :initform ()
604 :accessor class-defstruct-form)
605 (defstruct-constructor
606 :initform nil
607 :accessor class-defstruct-constructor)
608 (from-defclass-p
609 :initform nil
610 :initarg :from-defclass-p)))
611
612
613 (defclass specializer-with-object (specializer) ())
614
615 (defclass exact-class-specializer (specializer) ())
616
617 (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
618 ((object :initarg :class :reader specializer-class :reader specializer-object)))
619
620 (defclass class-prototype-specializer (specializer-with-object)
621 ((object :initarg :class :reader specializer-class :reader specializer-object)))
622
623 (defclass eql-specializer (exact-class-specializer specializer-with-object)
624 ((object :initarg :object :reader specializer-object
625 :reader eql-specializer-object)))
626
627 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
628
629 (defun intern-eql-specializer (object)
630 (or (gethash object *eql-specializer-table*)
631 (setf (gethash object *eql-specializer-table*)
632 (make-instance 'eql-specializer :object object))))
633
634
635 ;;;
636 ;;; Slot definitions.
637 ;;;
638 (defclass slot-definition (standard-object)
639 ((name
640 :initform nil
641 :initarg :name
642 :accessor slot-definition-name)
643 (initform
644 :initform nil
645 :initarg :initform
646 :accessor slot-definition-initform)
647 (initfunction
648 :initform nil
649 :initarg :initfunction
650 :accessor slot-definition-initfunction)
651 (readers
652 :initform nil
653 :initarg :readers
654 :accessor slot-definition-readers)
655 (writers
656 :initform nil
657 :initarg :writers
658 :accessor slot-definition-writers)
659 (initargs
660 :initform nil
661 :initarg :initargs
662 :accessor slot-definition-initargs)
663 (type
664 :initform t
665 :initarg :type
666 :accessor slot-definition-type)
667 (documentation
668 :initform ""
669 :initarg :documentation)
670 (class
671 :initform nil
672 :initarg :class
673 :accessor slot-definition-class)))
674
675 (defclass standard-slot-definition (slot-definition)
676 ((allocation
677 :initform :instance
678 :initarg :allocation
679 :accessor slot-definition-allocation)))
680
681 (defclass structure-slot-definition (slot-definition)
682 ((defstruct-accessor-symbol
683 :initform nil
684 :initarg :defstruct-accessor-symbol
685 :accessor slot-definition-defstruct-accessor-symbol)
686 (internal-reader-function
687 :initform nil
688 :initarg :internal-reader-function
689 :accessor slot-definition-internal-reader-function)
690 (internal-writer-function
691 :initform nil
692 :initarg :internal-writer-function
693 :accessor slot-definition-internal-writer-function)))
694
695 (defclass direct-slot-definition (slot-definition)
696 ())
697
698 (defclass effective-slot-definition (slot-definition)
699 ((reader-function ; #'(lambda (object) ...)
700 :accessor slot-definition-reader-function)
701 (writer-function ; #'(lambda (new-value object) ...)
702 :accessor slot-definition-writer-function)
703 (boundp-function ; #'(lambda (object) ...)
704 :accessor slot-definition-boundp-function)
705 (accessor-flags
706 :initform 0)))
707
708 (defclass standard-direct-slot-definition (standard-slot-definition
709 direct-slot-definition)
710 ())
711
712 (defclass standard-effective-slot-definition (standard-slot-definition
713 effective-slot-definition)
714 ((location ; nil, a fixnum, a cons: (slot-name . value)
715 :initform nil
716 :accessor slot-definition-location)))
717
718 (defclass structure-direct-slot-definition (structure-slot-definition
719 direct-slot-definition)
720 ())
721
722 (defclass structure-effective-slot-definition (structure-slot-definition
723 effective-slot-definition)
724 ())
725
726 (defclass method (standard-object) ())
727
728 (defclass standard-method (definition-source-mixin plist-mixin method)
729 ((generic-function
730 :initform nil
731 :accessor method-generic-function)
732 ; (qualifiers
733 ; :initform ()
734 ; :initarg :qualifiers
735 ; :reader method-qualifiers)
736 (specializers
737 :initform ()
738 :initarg :specializers
739 :reader method-specializers)
740 (lambda-list
741 :initform ()
742 :initarg :lambda-list
743 :reader method-lambda-list)
744 (function
745 :initform nil
746 :initarg :function) ;no writer
747 (fast-function
748 :initform nil
749 :initarg :fast-function ;no writer
750 :reader method-fast-function)
751 ; (documentation
752 ; :initform nil
753 ; :initarg :documentation
754 ; :reader method-documentation)
755 ))
756
757 (defclass standard-accessor-method (standard-method)
758 ((slot-name :initform nil
759 :initarg :slot-name
760 :reader accessor-method-slot-name)
761 (slot-definition :initform nil
762 :initarg :slot-definition
763 :reader accessor-method-slot-definition)))
764
765 (defclass standard-reader-method (standard-accessor-method) ())
766
767 (defclass standard-writer-method (standard-accessor-method) ())
768
769 (defclass standard-boundp-method (standard-accessor-method) ())
770
771 (defclass generic-function (dependent-update-mixin
772 definition-source-mixin
773 documentation-mixin
774 funcallable-standard-object)
775 ()
776 (:metaclass funcallable-standard-class))
777
778 (defclass standard-generic-function (generic-function)
779 ((name
780 :initform nil
781 :initarg :name
782 :accessor generic-function-name)
783 (methods
784 :initform ()
785 :accessor generic-function-methods)
786 (method-class
787 :initarg :method-class
788 :accessor generic-function-method-class)
789 (method-combination
790 :initarg :method-combination
791 :accessor generic-function-method-combination)
792 (arg-info
793 :initform (make-arg-info)
794 :reader gf-arg-info)
795 (dfun-state
796 :initform ()
797 :accessor gf-dfun-state)
798 (pretty-arglist
799 :initform ()
800 :accessor gf-pretty-arglist)
801 )
802 (:metaclass funcallable-standard-class)
803 (:default-initargs :method-class *the-class-standard-method*
804 :method-combination *standard-method-combination*))
805
806 (defclass method-combination (standard-object) ())
807
808 (defclass standard-method-combination
809 (definition-source-mixin method-combination)
810 ((type :reader method-combination-type
811 :initarg :type)
812 (documentation :reader method-combination-documentation
813 :initarg :documentation)
814 (options :reader method-combination-options
815 :initarg :options)))
816
817 (defparameter *early-class-predicates*
818 '((specializer specializerp)
819 (exact-class-specializer exact-class-specializer-p)
820 (class-eq-specializer class-eq-specializer-p)
821 (eql-specializer eql-specializer-p)
822 (class classp)
823 (slot-class slot-class-p)
824 (std-class std-class-p)
825 (standard-class standard-class-p)
826 (funcallable-standard-class funcallable-standard-class-p)
827 (structure-class structure-class-p)
828 (forward-referenced-class forward-referenced-class-p)
829 (method method-p)
830 (standard-method standard-method-p)
831 (standard-accessor-method standard-accessor-method-p)
832 (standard-reader-method standard-reader-method-p)
833 (standard-writer-method standard-writer-method-p)
834 (standard-boundp-method standard-boundp-method-p)
835 (generic-function generic-function-p)
836 (standard-generic-function standard-generic-function-p)
837 (method-combination method-combination-p)))
838

  ViewVC Help
Powered by ViewVC 1.1.5