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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Sat Aug 1 15:28:32 1992 UTC (21 years, 8 months ago) by ram
Branch: MAIN
Changes since 1.6: +154 -86 lines
This is July 92 PCL
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 *boot-state* ()) ;NIL
38 ;EARLY
39 ;BRAID
40 ;COMPLETE
41
42 )
43
44 (eval-when (load eval)
45 (when (eq *boot-state* 'complete)
46 (error "Trying to load (or compile) PCL in an environment in which it~%~
47 has already been loaded. This doesn't work, you will have to~%~
48 get a fresh lisp (reboot) and then load PCL."))
49 (when *boot-state*
50 (cerror "Try loading (or compiling) PCL anyways."
51 "Trying to load (or compile) PCL in an environment in which it~%~
52 has already been partially loaded. This may not work, you may~%~
53 need to get a fresh lisp (reboot) and then load PCL."))
54 )
55
56
57
58 ;;;
59 ;;; This is like fdefinition on the Lispm. If Common Lisp had something like
60 ;;; function specs I wouldn't need this. On the other hand, I don't like the
61 ;;; way this really works so maybe function specs aren't really right either?
62 ;;;
63 ;;; I also don't understand the real implications of a Lisp-1 on this sort of
64 ;;; thing. Certainly some of the lossage in all of this is because these
65 ;;; SPECs name global definitions.
66 ;;;
67 ;;; Note that this implementation is set up so that an implementation which
68 ;;; has a 'real' function spec mechanism can use that instead and in that way
69 ;;; get rid of setf generic function names.
70 ;;;
71 (defmacro parse-gspec (spec
72 (non-setf-var . non-setf-case)
73 (setf-var . setf-case))
74 (declare (indentation 1 1))
75 (once-only (spec)
76 `(cond (#-setf (symbolp ,spec) #+setf t
77 (let ((,non-setf-var ,spec)) ,@non-setf-case))
78 ((and (listp ,spec)
79 (eq (car ,spec) 'setf)
80 (symbolp (cadr ,spec)))
81 (let ((,setf-var (cadr ,spec))) ,@setf-case))
82 (t
83 (error
84 "Can't understand ~S as a generic function specifier.~%~
85 It must be either a symbol which can name a function or~%~
86 a list like ~S, where the car is the symbol ~S and the cadr~%~
87 is a symbol which can name a generic function."
88 ,spec '(setf <foo>) 'setf)))))
89
90 ;;;
91 ;;; If symbol names a function which is traced or advised, return the
92 ;;; unadvised, traced etc. definition. This lets me get at the generic
93 ;;; function object even when it is traced.
94 ;;;
95 (defun unencapsulated-fdefinition (symbol)
96 #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
97 #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
98 #+excl (or (excl::encapsulated-basic-definition symbol)
99 (symbol-function symbol))
100 #+xerox (il:virginfn symbol)
101 #+setf (fdefinition symbol)
102 #-(or Lispm Lucid excl Xerox setf) (symbol-function symbol))
103
104 ;;;
105 ;;; If symbol names a function which is traced or advised, redefine
106 ;;; the `real' definition without affecting the advise.
107 ;;;
108 (defun fdefine-carefully (symbol new-definition)
109 #+Lispm (si:fdefine symbol new-definition t t)
110 #+Lucid (let ((lucid::*redefinition-action* nil))
111 (setf (symbol-function symbol) new-definition))
112 #+excl (setf (symbol-function symbol) new-definition)
113 #+xerox (let ((advisedp (member symbol il:advisedfns :test #'eq))
114 (brokenp (member symbol il:brokenfns :test #'eq)))
115 ;; In XeroxLisp (late of envos) tracing is implemented
116 ;; as a special case of "breaking". Advising, however,
117 ;; is treated specially.
118 (xcl:unadvise-function symbol :no-error t)
119 (xcl:unbreak-function symbol :no-error t)
120 (setf (symbol-function symbol) new-definition)
121 (when brokenp (xcl:rebreak-function symbol))
122 (when advisedp (xcl:readvise-function symbol)))
123 #+setf (setf (fdefinition symbol) new-definition)
124 #-(or Lispm Lucid excl Xerox setf)
125 (setf (symbol-function symbol) new-definition)
126
127 new-definition)
128
129 (defun gboundp (spec)
130 (parse-gspec spec
131 (name (fboundp name))
132 (name (fboundp (get-setf-function-name name)))))
133
134 (defun gmakunbound (spec)
135 (parse-gspec spec
136 (name (fmakunbound name))
137 (name (fmakunbound (get-setf-function-name name)))))
138
139 (defun gdefinition (spec)
140 (parse-gspec spec
141 (name (or #-setf (macro-function name) ;??
142 (unencapsulated-fdefinition name)))
143 (name (unencapsulated-fdefinition (get-setf-function-name name)))))
144
145 (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec)
146 (parse-gspec spec
147 (name (fdefine-carefully name new-value))
148 (name (fdefine-carefully (get-setf-function-name name) new-value))))
149
150
151 (proclaim '(special *the-class-t*
152 *the-class-vector* *the-class-symbol*
153 *the-class-string* *the-class-sequence*
154 *the-class-rational* *the-class-ratio*
155 *the-class-number* *the-class-null* *the-class-list*
156 *the-class-integer* *the-class-float* *the-class-cons*
157 *the-class-complex* *the-class-character*
158 *the-class-bit-vector* *the-class-array*
159
160 *the-class-slot-object*
161 *the-class-standard-object*
162 *the-class-structure-object*
163 *the-class-class*
164 *the-class-method*
165 *the-class-generic-function*
166 *the-class-built-in-class*
167 *the-class-slot-class*
168 *the-class-structure-class*
169 *the-class-standard-class*
170 *the-class-funcallable-standard-class*
171 *the-class-standard-method*
172 *the-class-standard-generic-function*
173 *the-class-standard-direct-slot-definition*
174 *the-class-standard-effective-slot-definition*))
175
176 (proclaim '(special *the-wrapper-of-t*
177 *the-wrapper-of-vector* *the-wrapper-of-symbol*
178 *the-wrapper-of-string* *the-wrapper-of-sequence*
179 *the-wrapper-of-rational* *the-wrapper-of-ratio*
180 *the-wrapper-of-number* *the-wrapper-of-null*
181 *the-wrapper-of-list* *the-wrapper-of-integer*
182 *the-wrapper-of-float* *the-wrapper-of-cons*
183 *the-wrapper-of-complex* *the-wrapper-of-character*
184 *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
185
186 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
187 (declare (type boolean make-forward-referenced-class-p))
188 (if (symbolp class)
189 (or (find-class class (not make-forward-referenced-class-p))
190 (ensure-class class))
191 class))
192
193 (defun specializer-from-type (type &aux args)
194 (when (consp type)
195 (setq args (cdr type) type (car type)))
196 (cond ((symbolp type)
197 (or (and (null args) (find-class type))
198 (ecase type
199 (class (coerce-to-class (car args)))
200 (class-eq (class-eq-specializer (coerce-to-class (car args))))
201 (eql (intern-eql-specializer (car args))))))
202 ((specializerp type) type)))
203
204 (defun type-from-specializer (specl)
205 (when (symbolp specl)
206 (setq specl (find-class specl))) ;(or (find-class specl nil) (ensure-class specl))
207 (cond ((consp specl)
208 (unless (memq (car specl) '(class class-eq eql))
209 (error "~S is not a legal specializer type" specl))
210 specl)
211 ((specializerp specl)
212 (specializer-type specl))
213 (t
214 (error "~s is neither a type nor a specializer" specl))))
215
216 (defun type-class (type)
217 (declare (special *the-class-t*))
218 (setq type (type-from-specializer type))
219 (if (atom type)
220 *the-class-t*
221 (case (car type)
222 (eql (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 (symbol-function 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 compiled-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 #|| ; The argument to satisfies must be a symbol.
255 (deftype class (&optional class)
256 (if class
257 `(satisfies ,(class-predicate class))
258 `(satisfies ,(class-predicate 'class))))
259
260 (deftype class-eq (class)
261 `(satisfies ,(make-class-eq-predicate class)))
262 ||#
263
264 (deftype eql (type-object)
265 `(member ,type-object))
266
267 ;;;
268 ;;; These functions are a pale imitiation of their namesake. They accept
269 ;;; class objects or types where they should.
270 ;;;
271 (defun *normalize-type (type)
272 (cond ((consp type)
273 (if (member (car type) '(not and or))
274 `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
275 (if (null (cdr type))
276 (*normalize-type (car type))
277 type)))
278 ((symbolp type)
279 (let ((class (find-class type nil)))
280 (if class
281 (let ((type (specializer-type class)))
282 (if (listp type) type `(,type)))
283 `(,type))))
284 ((specializerp type)
285 (specializer-type type))
286 (t
287 (error "~s is not a type" type))))
288
289 (defun unparse-type-list (tlist)
290 (mapcar #'unparse-type tlist))
291
292 (defun unparse-type (type)
293 (if (atom type)
294 (if (specializerp type)
295 (unparse-type (specializer-type type))
296 type)
297 (case (car type)
298 (eql type)
299 (class-eq `(class-eq ,(class-name (cadr type))))
300 (class (class-name (cadr type)))
301 (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
302
303 (defun convert-to-system-type (type)
304 (case (car type)
305 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type))))
306 (class (class-name (cadr type))) ; it had better be a named class
307 (class-eq (class-name (cadr type))) ; this one is impossible to do right
308 (eql type)
309 (t (if (null (cdr type))
310 (car type)
311 type))))
312
313 (declaim (ftype (function (T T) boolean) *typep))
314 (defun *typep (object type)
315 (setq type (*normalize-type type))
316 (cond ((memq (car type) '(eql wrapper-eq class-eq class))
317 (specializer-applicable-using-type-p type `(eql ,object)))
318 ((eq (car type) 'not)
319 (not (*typep object (cadr type))))
320 (t
321 (typep object (convert-to-system-type type)))))
322
323 #-kcl
324 (declaim (ftype (function (T T) (values boolean boolean)) *subtypep))
325 (defun *subtypep (type1 type2)
326 (setq type1 (*normalize-type type1))
327 (setq type2 (*normalize-type type2))
328 (if (member (car type2) '(eql wrapper-eq class-eq class))
329 (multiple-value-bind (app-p maybe-app-p)
330 (specializer-applicable-using-type-p type2 type1)
331 (declare (type boolean app-p maybe-app-p))
332 (values app-p (or app-p (not maybe-app-p))))
333 (subtypep (convert-to-system-type type1)
334 (convert-to-system-type type2))))
335
336 (defun do-satisfies-deftype (name predicate)
337 #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
338 (let* ((specifier `(satisfies ,predicate))
339 (expand-fn #'(lambda (&rest ignore)
340 (declare (ignore ignore))
341 specifier)))
342 ;; Specific ports can insert their own way of doing this. Many
343 ;; ports may find the expand-fn defined above useful.
344 ;;
345 (or #+:Genera
346 (setf (get name 'deftype) expand-fn)
347 #+(and :Lucid (not :Prime))
348 (system::define-macro `(deftype ,name) expand-fn nil)
349 #+ExCL
350 (setf (get name 'excl::deftype-expander) expand-fn)
351 #+:coral
352 (setf (get name 'ccl::deftype-expander) expand-fn)))
353 #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
354 ;; This is the default for ports for which we don't know any
355 ;; better. Note that for most ports, providing this definition
356 ;; should just speed up class definition. It shouldn't have an
357 ;; effect on performance of most user code.
358 (eval `(deftype ,name () '(satisfies ,predicate))))
359
360 (defun make-type-predicate-name (name &optional kind)
361 (when (null name) (error "This shouldn't happen."))
362 (if (symbol-package name)
363 (intern (format nil
364 "~@[~A ~]TYPE-PREDICATE ~A ~A"
365 kind
366 (package-name (symbol-package name))
367 (symbol-name name))
368 *the-pcl-package*)
369 (make-symbol (format nil
370 "~@[~A ~]TYPE-PREDICATE ~A"
371 kind
372 (symbol-name name)))))
373
374
375
376
377 (defvar *built-in-class-symbols* ())
378 (defvar *built-in-wrapper-symbols* ())
379
380 (defun get-built-in-class-symbol (class-name)
381 (or (cadr (assq class-name *built-in-class-symbols*))
382 (let ((symbol (intern (format nil
383 "*THE-CLASS-~A*"
384 (symbol-name class-name))
385 *the-pcl-package*)))
386 (push (list class-name symbol) *built-in-class-symbols*)
387 symbol)))
388
389 (defun get-built-in-wrapper-symbol (class-name)
390 (or (cadr (assq class-name *built-in-wrapper-symbols*))
391 (let ((symbol (intern (format nil
392 "*THE-WRAPPER-OF-~A*"
393 (symbol-name class-name))
394 *the-pcl-package*)))
395 (push (list class-name symbol) *built-in-wrapper-symbols*)
396 symbol)))
397
398
399
400
401 (pushnew 'class *variable-declarations*)
402 (pushnew 'variable-rebinding *variable-declarations*)
403
404 (defun variable-class (var env)
405 (caddr (variable-declaration 'class var env)))
406
407
408
409
410 ;;;
411 ;;; This is used by combined methods to communicate the next methods to
412 ;;; the methods they call. This variable is captured by a lexical variable
413 ;;; of the methods to give it the proper lexical scope.
414 ;;;
415 (defvar *next-methods* nil)
416
417 (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
418
419 (defvar *umi-gfs*)
420 (defvar *umi-complete-classes*)
421 (defvar *umi-reorder*)
422
423 (defvar *invalidate-discriminating-function-force-p* ())
424 (defvar *invalid-dfuns-on-stack* ())
425
426
427 (defvar *standard-method-combination*)
428
429 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
430
431
432 (defmacro define-gf-predicate (predicate-name &rest classes)
433 `(progn
434 (defmethod ,predicate-name ((x t)) nil)
435 ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
436 classes)))
437
438 (defun make-class-predicate-name (name)
439 (intern (format nil "~A class predicate" (symbol-name name))
440 (symbol-package name)))
441
442 (defun plist-value (object name &optional default)
443 (getf (object-plist object) name default))
444
445 (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
446 (setf (getf (object-plist object) name) new-value))
447
448
449
450 (defvar *built-in-classes*
451 ;;
452 ;; name supers subs cdr of cpl
453 ;; prototype predicate-name
454 '(;(t () (number sequence array character symbol) ())
455 (number (t) (complex float rational) (t)
456 1 numberp)
457 (complex (number) () (number t)
458 #c(1 1) complexp)
459 (float (number) () (number t)
460 1.0 floatp)
461 (rational (number) (integer ratio) (number t)
462 1 rationalp)
463 (integer (rational) () (rational number t)
464 1 integerp)
465 (ratio (rational) () (rational number t)
466 1/2)
467
468 (sequence (t) (list vector) (t)
469 nil sequencep)
470 (list (sequence) (cons null) (sequence t)
471 () listp)
472 (cons (list) () (list sequence t)
473 (nil) consp)
474
475
476 (array (t) (vector) (t)
477 #2A((NIL)) arrayp)
478 (vector (array
479 sequence) (string bit-vector) (array sequence t)
480 #() vectorp)
481 (string (vector) () (vector array sequence t)
482 "" stringp)
483 (bit-vector (vector) () (vector array sequence t)
484 #*1 bit-vector-p)
485 (character (t) () (t)
486 #\c characterp)
487
488 (symbol (t) (null) (t)
489 symbol symbolp)
490 (null (symbol) () (symbol list sequence t)
491 nil null)))
492
493
494 ;;;
495 ;;; The classes that define the kernel of the metabraid.
496 ;;;
497 (defclass t () ()
498 (:metaclass built-in-class))
499
500 (defclass slot-object (t) ()
501 (:metaclass slot-class))
502
503 (defclass structure-object (slot-object) ()
504 (:metaclass structure-class))
505
506 (defstruct (structure-object
507 (:constructor |STRUCTURE-OBJECT class constructor|)))
508
509 (defclass standard-object (slot-object) ())
510
511 (defclass metaobject (standard-object) ())
512
513 (defclass specializer (metaobject)
514 ((type
515 :initform nil
516 :reader specializer-type)))
517
518 (defclass definition-source-mixin (standard-object)
519 ((source
520 :initform (load-truename)
521 :reader definition-source
522 :initarg :definition-source)))
523
524 (defclass plist-mixin (standard-object)
525 ((plist
526 :initform ()
527 :accessor object-plist)))
528
529 (defclass documentation-mixin ()
530 ((documentation
531 :initform NIL
532 :initarg :documentation)))
533
534 (defclass dependent-update-mixin (plist-mixin)
535 ())
536
537 ;;;
538 ;;; The class CLASS is a specified basic class. It is the common superclass
539 ;;; of any kind of class. It holds all of the documented reader functions from
540 ;;; the AMOP. Any class that can be a metaclass must have the class CLASS
541 ;;; in its class precedence list.
542 ;;;
543 (defclass class (documentation-mixin dependent-update-mixin
544 definition-source-mixin specializer)
545 ((default-initargs
546 :reader class-default-initargs)
547 (direct-default-initargs
548 :initform nil
549 :reader class-direct-default-initargs)
550 (direct-slots
551 :initform nil
552 :reader class-direct-slots)
553 (direct-subclasses
554 :initform nil
555 :reader class-direct-subclasses)
556 (direct-superclasses
557 :initform nil
558 :reader class-direct-superclasses)
559 (finalized-p
560 :initform nil
561 :reader class-finalized-p)
562 (name
563 :initform nil
564 :initarg :name
565 :reader class-name)
566 (class-precedence-list
567 :reader class-precedence-list)
568 (prototype
569 :reader class-prototype)
570 (slots
571 :reader class-slots)))
572
573
574 ;;;
575 ;;; The class PCL-CLASS is an implementation-specific common superclass of
576 ;;; all specified subclasses of the class CLASS.
577 ;;;
578 (defclass pcl-class (class)
579 ((cached-in-generic-functions
580 :initform ()
581 :reader class-cached-in-generic-functions)
582 (can-precede-list
583 :initform ()
584 :reader class-can-precede-list)
585 (class-eq-specializer
586 :initform nil
587 :reader class-eq-specializer)
588 (direct-methods
589 :initform (cons nil nil))
590 (incompatible-superclass-list
591 :initform ()
592 :accessor class-incompatible-superclass-list)
593 (internal-slotds
594 :reader class-internal-slotds
595 :documentation
596 "List of internal-slotd structure copies of class-slots (for optimization).")
597 (wrapper
598 :initform nil
599 :reader class-wrapper)
600 (predicate-name
601 :initform nil
602 :reader class-predicate-name))
603 )
604
605 (defclass slot-class (pcl-class)
606 ((side-effect-internal-slotds
607 :reader class-side-effect-internal-slotds
608 :documentation
609 "List of internal-slotd structure copies of class-slots whose initfunctions
610 may have side-effects (for optimization).")))
611
612 ;;;
613 ;;; The class STD-CLASS is an implementation-specific common superclass of
614 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
615 ;;;
616 (defclass std-class (slot-class)
617 ())
618
619 (defclass standard-class (std-class)
620 ())
621
622 (defclass funcallable-standard-class (std-class)
623 ())
624
625 (defclass forward-referenced-class (pcl-class) ())
626
627 (defclass built-in-class (pcl-class) ())
628
629 (defclass structure-class (slot-class)
630 ((defstruct-conc-name
631 :initform nil
632 :reader class-defstruct-conc-name)
633 (defstruct-constructor
634 :initform nil
635 :reader class-defstruct-constructor)
636 (from-defclass-p
637 :initform nil
638 :initarg :from-defclass-p
639 :reader class-from-defclass-p)))
640
641
642 (defclass specializer-with-object (specializer) ())
643
644 (defclass exact-class-specializer (specializer) ())
645
646 (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
647 ((object :initarg :class :reader specializer-class :reader specializer-object)))
648
649 (defclass eql-specializer (exact-class-specializer specializer-with-object)
650 ((object :initarg :object :reader specializer-object
651 :reader eql-specializer-object)))
652
653 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
654
655 (defun intern-eql-specializer (object)
656 (or (gethash object *eql-specializer-table*)
657 (setf (gethash object *eql-specializer-table*)
658 (make-instance 'eql-specializer :object object))))
659
660
661 ;;;
662 ;;; Slot definitions.
663 ;;;
664 ;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".
665 ;;;
666 (defclass slot-definition (documentation-mixin metaobject)
667 ((name
668 :initform nil
669 :initarg :name
670 :accessor slot-definition-name)
671 (initform
672 :initform nil
673 :initarg :initform
674 :accessor slot-definition-initform)
675 (initfunction
676 :initform nil
677 :type (or function null)
678 :initarg :initfunction
679 :accessor slot-definition-initfunction)
680 (readers
681 :initform nil
682 :initarg :readers
683 :accessor slot-definition-readers)
684 (writers
685 :initform nil
686 :initarg :writers
687 :accessor slot-definition-writers)
688 (initargs
689 :initform nil
690 :initarg :initargs
691 :accessor slot-definition-initargs)
692 (type
693 :initform t
694 :initarg :type
695 :accessor slot-definition-type)
696 (class
697 :initform nil
698 :initarg :class
699 :accessor slot-definition-class)
700 (initfunction-side-effect-free-p
701 :initform nil
702 :initarg :initfunction-side-effect-free-p
703 :accessor slot-definition-initfunction-side-effect-free-p)))
704
705
706 (defclass standard-slot-definition (slot-definition)
707 ((allocation
708 :initform :instance
709 :initarg :allocation
710 :accessor slot-definition-allocation)))
711
712 (defclass structure-slot-definition (slot-definition)
713 ((defstruct-accessor-symbol
714 :initform nil
715 :initarg :defstruct-accessor-symbol
716 :accessor slot-definition-defstruct-accessor-symbol)
717 (internal-reader-function
718 :initform nil
719 :initarg :internal-reader-function
720 :accessor slot-definition-internal-reader-function)
721 (internal-writer-function
722 :initform nil
723 :initarg :internal-writer-function
724 :accessor slot-definition-internal-writer-function)))
725
726 (defclass direct-slot-definition (slot-definition)
727 ())
728
729 (defclass effective-slot-definition (slot-definition)
730 ((location ; nil, a fixnum, a cons: (slot-name . value)
731 :initform nil
732 :accessor slot-definition-location)
733 (reader-function ; #'(lambda (object) ...)
734 :accessor slot-definition-reader-function)
735 (writer-function ; #'(lambda (new-value object) ...)
736 :accessor slot-definition-writer-function)
737 (boundp-function ; #'(lambda (object) ...)
738 :accessor slot-definition-boundp-function)
739 (accessor-flags
740 :initform 0)
741 (internal-slotd
742 :initform NIL
743 :accessor slot-definition-internal-slotd
744 :documentation
745 "Internal-slotd structure with copies of slot-definition info
746 used for optimizations purposes.")))
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 ())
755
756 (defclass structure-direct-slot-definition (structure-slot-definition
757 direct-slot-definition)
758 ())
759
760 (defclass structure-effective-slot-definition (structure-slot-definition
761 effective-slot-definition)
762 ())
763
764
765
766 (defun slot-reader-undefined (object)
767 (error "slot reader-function undefined for ~S" object))
768
769 (defun slot-writer-undefined (new-value object)
770 (declare (ignore new-value))
771 (error "slot writer-function undefined for ~S" object))
772
773 (defun slot-boundp-undefined (object)
774 (error "slot boundp-function undefined for ~S" object))
775
776 (defstruct (internal-slotd
777 (:print-function print-internal-slotd))
778 (name NIL :type symbol)
779 (slot-definition NIL)
780 (location NIL)
781 (initargs () :type list)
782 (initfunction () :type (or function null))
783 (reader-function #'slot-reader-undefined :type compiled-function)
784 (writer-function #'slot-writer-undefined :type compiled-function)
785 (boundp-function #'slot-boundp-undefined :type compiled-function))
786
787 #+akcl
788 (si::freeze-defstruct 'internal-slotd)
789
790 (defun print-internal-slotd (internal-slotd stream depth)
791 (declare (ignore depth))
792 (printing-random-thing (internal-slotd stream)
793 (format stream "internal-slotd ~S"
794 (internal-slotd-slot-definition internal-slotd))))
795
796
797 (defparameter *early-class-predicates*
798 '((specializer specializerp)
799 (exact-class-specializer exact-class-specializer-p)
800 (class-eq-specializer class-eq-specializer-p)
801 (eql-specializer eql-specializer-p)
802 (class classp)
803 (standard-class standard-class-p)
804 (funcallable-standard-class funcallable-standard-class-p)
805 (structure-class structure-class-p)
806 (forward-referenced-class forward-referenced-class-p)))
807

  ViewVC Help
Powered by ViewVC 1.1.5