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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Sun May 30 23:13:55 1999 UTC (14 years, 10 months ago) by pw
Branch: MAIN
Changes since 1.16: +17 -33 lines
Remove all #+ and #- conditionals from the source code. What is left
is essentially Common Lisp except for explicit references to things
in CMUCL specific packages.
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 (let ((predicate-name (make-type-predicate-name name)))
185 (setf (gdefinition predicate-name) (make-type-predicate name))
186 (do-satisfies-deftype name predicate-name)))
187
188 (defun make-type-predicate (name)
189 (let ((cell (find-class-cell name)))
190 #'(lambda (x)
191 (funcall (the function (find-class-cell-predicate cell)) x))))
192
193
194 ;This stuff isn't right. Good thing it isn't used.
195 ;The satisfies predicate has to be a symbol. There is no way to
196 ;construct such a symbol from a class object if class names change.
197 (defun class-predicate (class)
198 (when (symbolp class) (setq class (find-class class)))
199 #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
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 (defun do-satisfies-deftype (name predicate)
277 (declare (ignore name predicate)))
278
279 (defun make-type-predicate-name (name &optional kind)
280 (if (symbol-package name)
281 (intern (format nil
282 "~@[~A ~]TYPE-PREDICATE ~A ~A"
283 kind
284 (package-name (symbol-package name))
285 (symbol-name name))
286 *the-pcl-package*)
287 (make-symbol (format nil
288 "~@[~A ~]TYPE-PREDICATE ~A"
289 kind
290 (symbol-name name)))))
291
292
293
294 (defvar *built-in-class-symbols* ())
295 (defvar *built-in-wrapper-symbols* ())
296
297 (defun get-built-in-class-symbol (class-name)
298 (or (cadr (assq class-name *built-in-class-symbols*))
299 (let ((symbol (intern (format nil
300 "*THE-CLASS-~A*"
301 (symbol-name class-name))
302 *the-pcl-package*)))
303 (push (list class-name symbol) *built-in-class-symbols*)
304 symbol)))
305
306 (defun get-built-in-wrapper-symbol (class-name)
307 (or (cadr (assq class-name *built-in-wrapper-symbols*))
308 (let ((symbol (intern (format nil
309 "*THE-WRAPPER-OF-~A*"
310 (symbol-name class-name))
311 *the-pcl-package*)))
312 (push (list class-name symbol) *built-in-wrapper-symbols*)
313 symbol)))
314
315
316
317
318 (pushnew 'class *variable-declarations*)
319 (pushnew 'variable-rebinding *variable-declarations*)
320
321 (defun variable-class (var env)
322 (caddr (variable-declaration 'class var env)))
323
324 (defvar *name->class->slotd-table* (make-hash-table))
325
326
327 ;;;
328 ;;; This is used by combined methods to communicate the next methods to
329 ;;; the methods they call. This variable is captured by a lexical variable
330 ;;; of the methods to give it the proper lexical scope.
331 ;;;
332 (defvar *next-methods* nil)
333
334 (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
335
336 (defvar *umi-gfs*)
337 (defvar *umi-complete-classes*)
338 (defvar *umi-reorder*)
339
340 (defvar *invalidate-discriminating-function-force-p* ())
341 (defvar *invalid-dfuns-on-stack* ())
342
343
344 (defvar *standard-method-combination*)
345
346 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
347
348
349 (defmacro define-gf-predicate (predicate-name &rest classes)
350 `(progn
351 (defmethod ,predicate-name ((x t)) nil)
352 ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
353 classes)))
354
355 (defun make-class-predicate-name (name)
356 (intern (format nil "~A::~A class predicate"
357 (package-name (symbol-package name))
358 name)
359 *the-pcl-package*))
360
361 (defun plist-value (object name)
362 (getf (object-plist object) name))
363
364 (defun (setf plist-value) (new-value object name)
365 (if new-value
366 (setf (getf (object-plist object) name) new-value)
367 (progn
368 (remf (object-plist object) name)
369 nil)))
370
371
372
373 (defvar *built-in-classes*
374 ;;
375 ;; name supers subs cdr of cpl
376 ;; prototype
377 '(;(t () (number sequence array character symbol) ())
378 (number (t) (complex float rational) (t))
379 (complex (number) () (number t)
380 #c(1 1))
381 (float (number) () (number t)
382 1.0)
383 (rational (number) (integer ratio) (number t))
384 (integer (rational) () (rational number t)
385 1)
386 (ratio (rational) () (rational number t)
387 1/2)
388
389 (sequence (t) (list vector) (t))
390 (list (sequence) (cons null) (sequence t))
391 (cons (list) () (list sequence t)
392 (nil))
393
394
395 (array (t) (vector) (t)
396 #2A((NIL)))
397 (vector (array
398 sequence) (string bit-vector) (array sequence t)
399 #())
400 (string (vector) () (vector array sequence t)
401 "")
402 (bit-vector (vector) () (vector array sequence t)
403 #*1)
404 (character (t) () (t)
405 #\c)
406
407 (symbol (t) (null) (t)
408 symbol)
409 (null (symbol
410 list) () (symbol list sequence t)
411 nil)))
412
413 (labels ((direct-supers (class)
414 (if (typep class 'lisp:built-in-class)
415 (kernel:built-in-class-direct-superclasses class)
416 (let ((inherits (kernel:layout-inherits
417 (kernel:class-layout class))))
418 (list (svref inherits (1- (length inherits)))))))
419 (direct-subs (class)
420 (ext:collect ((res))
421 (let ((subs (kernel:class-subclasses class)))
422 (when subs
423 (ext:do-hash (sub v subs)
424 (declare (ignore v))
425 (when (member class (direct-supers sub))
426 (res sub)))))
427 (res))))
428 (ext:collect ((res))
429 (dolist (bic kernel::built-in-classes)
430 (let* ((name (car bic))
431 (class (lisp:find-class name)))
432 (unless (member name '(t kernel:instance kernel:funcallable-instance
433 function stream))
434 (res `(,name
435 ,(mapcar #'lisp:class-name (direct-supers class))
436 ,(mapcar #'lisp:class-name (direct-subs class))
437 ,(map 'list #'(lambda (x)
438 (lisp:class-name (kernel:layout-class x)))
439 (reverse
440 (kernel:layout-inherits
441 (kernel:class-layout class))))
442 ,(let ((found (assoc name *built-in-classes*)))
443 (if found (fifth found) 42)))))))
444 (setq *built-in-classes* (res))))
445
446
447 ;;;
448 ;;; The classes that define the kernel of the metabraid.
449 ;;;
450 (defclass t () ()
451 (:metaclass built-in-class))
452
453 (defclass kernel:instance (t) ()
454 (:metaclass built-in-class))
455
456 (defclass function (t) ()
457 (:metaclass built-in-class))
458
459 (defclass kernel:funcallable-instance (function) ()
460 (:metaclass built-in-class))
461
462 (defclass stream (t) ()
463 (:metaclass built-in-class))
464
465 (defclass slot-object (t) ()
466 (:metaclass slot-class))
467
468 (defclass structure-object (slot-object kernel:instance) ()
469 (:metaclass structure-class))
470
471 (defstruct (dead-beef-structure-object
472 (:constructor |STRUCTURE-OBJECT class constructor|)))
473
474
475 (defclass std-object (slot-object) ()
476 (:metaclass std-class))
477
478 (defclass standard-object (std-object kernel:instance) ())
479
480 (defclass funcallable-standard-object (std-object
481 kernel:funcallable-instance)
482 ()
483 (:metaclass funcallable-standard-class))
484
485 (defclass specializer (standard-object)
486 ((type
487 :initform nil
488 :reader specializer-type)))
489
490 (defclass definition-source-mixin (std-object)
491 ((source
492 :initform (load-truename)
493 :reader definition-source
494 :initarg :definition-source))
495 (:metaclass std-class))
496
497 (defclass plist-mixin (std-object)
498 ((plist
499 :initform ()
500 :accessor object-plist))
501 (:metaclass std-class))
502
503 (defclass documentation-mixin (plist-mixin)
504 ()
505 (:metaclass std-class))
506
507 (defclass dependent-update-mixin (plist-mixin)
508 ()
509 (:metaclass std-class))
510
511 ;;;
512 ;;; The class CLASS is a specified basic class. It is the common superclass
513 ;;; of any kind of class. That is any class that can be a metaclass must
514 ;;; have the class CLASS in its class precedence list.
515 ;;;
516 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
517 specializer)
518 ((name
519 :initform nil
520 :initarg :name
521 :accessor class-name)
522 (class-eq-specializer
523 :initform nil
524 :reader class-eq-specializer)
525 (direct-superclasses
526 :initform ()
527 :reader class-direct-superclasses)
528 (direct-subclasses
529 :initform ()
530 :reader class-direct-subclasses)
531 (direct-methods
532 :initform (cons nil nil))
533 (predicate-name
534 :initform nil
535 :reader class-predicate-name)))
536
537 ;;;
538 ;;; The class PCL-CLASS is an implementation-specific common superclass of
539 ;;; all specified subclasses of the class CLASS.
540 ;;;
541 (defclass pcl-class (class)
542 ((class-precedence-list
543 :reader class-precedence-list)
544 (can-precede-list
545 :initform ()
546 :reader class-can-precede-list)
547 (incompatible-superclass-list
548 :initform ()
549 :accessor class-incompatible-superclass-list)
550 (wrapper
551 :initform nil
552 :reader class-wrapper)
553 (prototype
554 :initform nil
555 :reader class-prototype)))
556
557 (defclass slot-class (pcl-class)
558 ((direct-slots
559 :initform ()
560 :accessor class-direct-slots)
561 (slots
562 :initform ()
563 :accessor class-slots)
564 (initialize-info
565 :initform nil
566 :accessor class-initialize-info)))
567
568 ;;;
569 ;;; The class STD-CLASS is an implementation-specific common superclass of
570 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
571 ;;;
572 (defclass std-class (slot-class)
573 ())
574
575 (defclass standard-class (std-class)
576 ())
577
578 (defclass funcallable-standard-class (std-class)
579 ())
580
581 (defclass forward-referenced-class (pcl-class) ())
582
583 (defclass built-in-class (pcl-class) ())
584
585 (defclass structure-class (slot-class)
586 ((defstruct-form
587 :initform ()
588 :accessor class-defstruct-form)
589 (defstruct-constructor
590 :initform nil
591 :accessor class-defstruct-constructor)
592 (from-defclass-p
593 :initform nil
594 :initarg :from-defclass-p)))
595
596
597 (defclass specializer-with-object (specializer) ())
598
599 (defclass exact-class-specializer (specializer) ())
600
601 (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
602 ((object :initarg :class :reader specializer-class :reader specializer-object)))
603
604 (defclass class-prototype-specializer (specializer-with-object)
605 ((object :initarg :class :reader specializer-class :reader specializer-object)))
606
607 (defclass eql-specializer (exact-class-specializer specializer-with-object)
608 ((object :initarg :object :reader specializer-object
609 :reader eql-specializer-object)))
610
611 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
612
613 (defun intern-eql-specializer (object)
614 (or (gethash object *eql-specializer-table*)
615 (setf (gethash object *eql-specializer-table*)
616 (make-instance 'eql-specializer :object object))))
617
618
619 ;;;
620 ;;; Slot definitions.
621 ;;;
622 (defclass slot-definition (standard-object)
623 ((name
624 :initform nil
625 :initarg :name
626 :accessor slot-definition-name)
627 (initform
628 :initform nil
629 :initarg :initform
630 :accessor slot-definition-initform)
631 (initfunction
632 :initform nil
633 :initarg :initfunction
634 :accessor slot-definition-initfunction)
635 (readers
636 :initform nil
637 :initarg :readers
638 :accessor slot-definition-readers)
639 (writers
640 :initform nil
641 :initarg :writers
642 :accessor slot-definition-writers)
643 (initargs
644 :initform nil
645 :initarg :initargs
646 :accessor slot-definition-initargs)
647 (type
648 :initform t
649 :initarg :type
650 :accessor slot-definition-type)
651 (documentation
652 :initform ""
653 :initarg :documentation)
654 (class
655 :initform nil
656 :initarg :class
657 :accessor slot-definition-class)))
658
659 (defclass standard-slot-definition (slot-definition)
660 ((allocation
661 :initform :instance
662 :initarg :allocation
663 :accessor slot-definition-allocation)))
664
665 (defclass structure-slot-definition (slot-definition)
666 ((defstruct-accessor-symbol
667 :initform nil
668 :initarg :defstruct-accessor-symbol
669 :accessor slot-definition-defstruct-accessor-symbol)
670 (internal-reader-function
671 :initform nil
672 :initarg :internal-reader-function
673 :accessor slot-definition-internal-reader-function)
674 (internal-writer-function
675 :initform nil
676 :initarg :internal-writer-function
677 :accessor slot-definition-internal-writer-function)))
678
679 (defclass direct-slot-definition (slot-definition)
680 ())
681
682 (defclass effective-slot-definition (slot-definition)
683 ((reader-function ; #'(lambda (object) ...)
684 :accessor slot-definition-reader-function)
685 (writer-function ; #'(lambda (new-value object) ...)
686 :accessor slot-definition-writer-function)
687 (boundp-function ; #'(lambda (object) ...)
688 :accessor slot-definition-boundp-function)
689 (accessor-flags
690 :initform 0)))
691
692 (defclass standard-direct-slot-definition (standard-slot-definition
693 direct-slot-definition)
694 ())
695
696 (defclass standard-effective-slot-definition (standard-slot-definition
697 effective-slot-definition)
698 ((location ; nil, a fixnum, a cons: (slot-name . value)
699 :initform nil
700 :accessor slot-definition-location)))
701
702 (defclass structure-direct-slot-definition (structure-slot-definition
703 direct-slot-definition)
704 ())
705
706 (defclass structure-effective-slot-definition (structure-slot-definition
707 effective-slot-definition)
708 ())
709
710 (defclass method (standard-object) ())
711
712 (defclass standard-method (definition-source-mixin plist-mixin method)
713 ((generic-function
714 :initform nil
715 :accessor method-generic-function)
716 ; (qualifiers
717 ; :initform ()
718 ; :initarg :qualifiers
719 ; :reader method-qualifiers)
720 (specializers
721 :initform ()
722 :initarg :specializers
723 :reader method-specializers)
724 (lambda-list
725 :initform ()
726 :initarg :lambda-list
727 :reader method-lambda-list)
728 (function
729 :initform nil
730 :initarg :function) ;no writer
731 (fast-function
732 :initform nil
733 :initarg :fast-function ;no writer
734 :reader method-fast-function)
735 ; (documentation
736 ; :initform nil
737 ; :initarg :documentation
738 ; :reader method-documentation)
739 ))
740
741 (defclass standard-accessor-method (standard-method)
742 ((slot-name :initform nil
743 :initarg :slot-name
744 :reader accessor-method-slot-name)
745 (slot-definition :initform nil
746 :initarg :slot-definition
747 :reader accessor-method-slot-definition)))
748
749 (defclass standard-reader-method (standard-accessor-method) ())
750
751 (defclass standard-writer-method (standard-accessor-method) ())
752
753 (defclass standard-boundp-method (standard-accessor-method) ())
754
755 (defclass generic-function (dependent-update-mixin
756 definition-source-mixin
757 documentation-mixin
758 funcallable-standard-object)
759 ()
760 (:metaclass funcallable-standard-class))
761
762 (defclass standard-generic-function (generic-function)
763 ((name
764 :initform nil
765 :initarg :name
766 :accessor generic-function-name)
767 (methods
768 :initform ()
769 :accessor generic-function-methods)
770 (method-class
771 :initarg :method-class
772 :accessor generic-function-method-class)
773 (method-combination
774 :initarg :method-combination
775 :accessor generic-function-method-combination)
776 (arg-info
777 :initform (make-arg-info)
778 :reader gf-arg-info)
779 (dfun-state
780 :initform ()
781 :accessor gf-dfun-state)
782 (pretty-arglist
783 :initform ()
784 :accessor gf-pretty-arglist)
785 )
786 (:metaclass funcallable-standard-class)
787 (:default-initargs :method-class *the-class-standard-method*
788 :method-combination *standard-method-combination*))
789
790 (defclass method-combination (standard-object) ())
791
792 (defclass standard-method-combination
793 (definition-source-mixin method-combination)
794 ((type :reader method-combination-type
795 :initarg :type)
796 (documentation :reader method-combination-documentation
797 :initarg :documentation)
798 (options :reader method-combination-options
799 :initarg :options)))
800
801 (defparameter *early-class-predicates*
802 '((specializer specializerp)
803 (exact-class-specializer exact-class-specializer-p)
804 (class-eq-specializer class-eq-specializer-p)
805 (eql-specializer eql-specializer-p)
806 (class classp)
807 (slot-class slot-class-p)
808 (std-class std-class-p)
809 (standard-class standard-class-p)
810 (funcallable-standard-class funcallable-standard-class-p)
811 (structure-class structure-class-p)
812 (forward-referenced-class forward-referenced-class-p)
813 (method method-p)
814 (standard-method standard-method-p)
815 (standard-accessor-method standard-accessor-method-p)
816 (standard-reader-method standard-reader-method-p)
817 (standard-writer-method standard-writer-method-p)
818 (standard-boundp-method standard-boundp-method-p)
819 (generic-function generic-function-p)
820 (standard-generic-function standard-generic-function-p)
821 (method-combination method-combination-p)))
822

  ViewVC Help
Powered by ViewVC 1.1.5