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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5