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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5