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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide 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 wlott 1.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 ram 1.6 (defvar *boot-state* ()) ;NIL
38     ;EARLY
39     ;BRAID
40     ;COMPLETE
41    
42 wlott 1.1 )
43    
44 ram 1.6 (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 wlott 1.1 )
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 ram 1.6 `(cond (#-setf (symbolp ,spec) #+setf t
77 wlott 1.1 (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 ram 1.6 #+setf (fdefinition symbol)
102     #-(or Lispm Lucid excl Xerox setf) (symbol-function symbol))
103 wlott 1.1
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 ram 1.6 #+setf (setf (fdefinition symbol) new-definition)
124     #-(or Lispm Lucid excl Xerox setf)
125 wlott 1.1 (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 ram 1.6 (name (or #-setf (macro-function name) ;??
142 wlott 1.1 (unencapsulated-fdefinition name)))
143     (name (unencapsulated-fdefinition (get-setf-function-name name)))))
144    
145 ram 1.6 (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec)
146 wlott 1.1 (parse-gspec spec
147     (name (fdefine-carefully name new-value))
148     (name (fdefine-carefully (get-setf-function-name name) new-value))))
149    
150 ram 1.7
151 ram 1.6 (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 ram 1.7 *the-class-standard-direct-slot-definition*
174     *the-class-standard-effective-slot-definition*))
175 ram 1.6
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 ram 1.7 (declare (type boolean make-forward-referenced-class-p))
188 ram 1.6 (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 ram 1.7 (unless (memq (car specl) '(class class-eq eql))
209 ram 1.6 (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 ram 1.4 (defun type-class (type)
217 ram 1.6 (declare (special *the-class-t*))
218     (setq type (type-from-specializer type))
219     (if (atom type)
220     *the-class-t*
221 ram 1.4 (case (car type)
222 ram 1.6 (eql (class-of (cadr type)))
223     (class-eq (cadr type))
224     (class (cadr type)))))
225 ram 1.4
226 ram 1.6 (defun class-eq-type (class)
227     (specializer-type (class-eq-specializer class)))
228 ram 1.4
229 ram 1.6 (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 ram 1.7 (funcall (the compiled-function (find-class-cell-predicate cell)) x))))
238 ram 1.6
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 ram 1.4 (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 ram 1.6 #|| ; 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 ram 1.4
260 ram 1.6 (deftype class-eq (class)
261     `(satisfies ,(make-class-eq-predicate class)))
262     ||#
263 ram 1.4
264 ram 1.6 (deftype eql (type-object)
265     `(member ,type-object))
266 ram 1.4
267 wlott 1.1 ;;;
268     ;;; These functions are a pale imitiation of their namesake. They accept
269     ;;; class objects or types where they should.
270     ;;;
271 ram 1.6 (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 ram 1.7 (declaim (ftype (function (T T) boolean) *typep))
314 wlott 1.1 (defun *typep (object type)
315 ram 1.6 (setq type (*normalize-type type))
316 ram 1.7 (cond ((memq (car type) '(eql wrapper-eq class-eq class))
317 ram 1.6 (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 wlott 1.1
323 ram 1.7 #-kcl
324     (declaim (ftype (function (T T) (values boolean boolean)) *subtypep))
325 wlott 1.1 (defun *subtypep (type1 type2)
326 ram 1.6 (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 ram 1.7 (declare (type boolean app-p maybe-app-p))
332 ram 1.6 (values app-p (or app-p (not maybe-app-p))))
333     (subtypep (convert-to-system-type type1)
334     (convert-to-system-type type2))))
335 wlott 1.1
336     (defun do-satisfies-deftype (name predicate)
337 ram 1.6 #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
338 wlott 1.1 (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 ram 1.6 (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 wlott 1.1
360 ram 1.6 (defun make-type-predicate-name (name &optional kind)
361 ram 1.7 (when (null name) (error "This shouldn't happen."))
362 ram 1.6 (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 wlott 1.2
374 ram 1.7
375 wlott 1.1
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 ram 1.6 (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 wlott 1.1
438 ram 1.6 (defun make-class-predicate-name (name)
439 ram 1.7 (intern (format nil "~A class predicate" (symbol-name name))
440     (symbol-package name)))
441 wlott 1.1
442 ram 1.7 (defun plist-value (object name &optional default)
443     (getf (object-plist object) name default))
444 wlott 1.1
445 ram 1.6 (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
446 ram 1.7 (setf (getf (object-plist object) name) new-value))
447 ram 1.6
448 wlott 1.1
449    
450     (defvar *built-in-classes*
451     ;;
452     ;; name supers subs cdr of cpl
453 ram 1.7 ;; prototype predicate-name
454 ram 1.6 '(;(t () (number sequence array character symbol) ())
455 ram 1.7 (number (t) (complex float rational) (t)
456     1 numberp)
457 ram 1.6 (complex (number) () (number t)
458 ram 1.7 #c(1 1) complexp)
459 ram 1.6 (float (number) () (number t)
460 ram 1.7 1.0 floatp)
461     (rational (number) (integer ratio) (number t)
462     1 rationalp)
463 ram 1.6 (integer (rational) () (rational number t)
464 ram 1.7 1 integerp)
465 ram 1.6 (ratio (rational) () (rational number t)
466     1/2)
467 wlott 1.1
468 ram 1.7 (sequence (t) (list vector) (t)
469     nil sequencep)
470     (list (sequence) (cons null) (sequence t)
471     () listp)
472 ram 1.6 (cons (list) () (list sequence t)
473 ram 1.7 (nil) consp)
474 wlott 1.1
475    
476 ram 1.6 (array (t) (vector) (t)
477 ram 1.7 #2A((NIL)) arrayp)
478 wlott 1.1 (vector (array
479 ram 1.6 sequence) (string bit-vector) (array sequence t)
480 ram 1.7 #() vectorp)
481 ram 1.6 (string (vector) () (vector array sequence t)
482 ram 1.7 "" stringp)
483 ram 1.6 (bit-vector (vector) () (vector array sequence t)
484 ram 1.7 #*1 bit-vector-p)
485 ram 1.6 (character (t) () (t)
486 ram 1.7 #\c characterp)
487 wlott 1.1
488 ram 1.6 (symbol (t) (null) (t)
489 ram 1.7 symbol symbolp)
490 ram 1.6 (null (symbol) () (symbol list sequence t)
491 ram 1.7 nil null)))
492 wlott 1.1
493    
494     ;;;
495     ;;; The classes that define the kernel of the metabraid.
496     ;;;
497     (defclass t () ()
498     (:metaclass built-in-class))
499    
500 ram 1.6 (defclass slot-object (t) ()
501     (:metaclass slot-class))
502 wlott 1.1
503 ram 1.6 (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 wlott 1.1 (defclass metaobject (standard-object) ())
512    
513 ram 1.6 (defclass specializer (metaobject)
514     ((type
515     :initform nil
516     :reader specializer-type)))
517 wlott 1.1
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 ram 1.6 :initform ()
527     :accessor object-plist)))
528 wlott 1.1
529 ram 1.7 (defclass documentation-mixin ()
530     ((documentation
531     :initform NIL
532     :initarg :documentation)))
533 wlott 1.1
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 ram 1.7 ;;; 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 wlott 1.1 ;;;
543 ram 1.7 (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 ram 1.6 :initform nil
549 ram 1.7 :reader class-direct-default-initargs)
550     (direct-slots
551     :initform nil
552     :reader class-direct-slots)
553 wlott 1.1 (direct-subclasses
554 ram 1.7 :initform nil
555 wlott 1.1 :reader class-direct-subclasses)
556 ram 1.7 (direct-superclasses
557 ram 1.6 :initform nil
558 ram 1.7 :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 wlott 1.1
573 ram 1.7
574 wlott 1.1 ;;;
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 ram 1.7 ((cached-in-generic-functions
580     :initform ()
581     :reader class-cached-in-generic-functions)
582 ram 1.6 (can-precede-list
583     :initform ()
584     :reader class-can-precede-list)
585 ram 1.7 (class-eq-specializer
586     :initform nil
587     :reader class-eq-specializer)
588     (direct-methods
589     :initform (cons nil nil))
590 ram 1.6 (incompatible-superclass-list
591     :initform ()
592     :accessor class-incompatible-superclass-list)
593 ram 1.7 (internal-slotds
594     :reader class-internal-slotds
595     :documentation
596     "List of internal-slotd structure copies of class-slots (for optimization).")
597 wlott 1.1 (wrapper
598 ram 1.6 :initform nil
599     :reader class-wrapper)
600 ram 1.7 (predicate-name
601     :initform nil
602     :reader class-predicate-name))
603     )
604 wlott 1.1
605 ram 1.6 (defclass slot-class (pcl-class)
606 ram 1.7 ((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 ram 1.6
612 wlott 1.1 ;;;
613     ;;; The class STD-CLASS is an implementation-specific common superclass of
614     ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
615     ;;;
616 ram 1.6 (defclass std-class (slot-class)
617 ram 1.7 ())
618 wlott 1.1
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 ram 1.6 (defclass structure-class (slot-class)
630 ram 1.7 ((defstruct-conc-name
631     :initform nil
632     :reader class-defstruct-conc-name)
633 ram 1.6 (defstruct-constructor
634     :initform nil
635 ram 1.7 :reader class-defstruct-constructor)
636 ram 1.6 (from-defclass-p
637     :initform nil
638 ram 1.7 :initarg :from-defclass-p
639     :reader class-from-defclass-p)))
640 ram 1.6
641 ram 1.7
642 ram 1.6 (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 wlott 1.1
661     ;;;
662     ;;; Slot definitions.
663     ;;;
664     ;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".
665     ;;;
666 ram 1.7 (defclass slot-definition (documentation-mixin metaobject)
667 wlott 1.1 ((name
668     :initform nil
669 ram 1.6 :initarg :name
670     :accessor slot-definition-name)
671 wlott 1.1 (initform
672 ram 1.6 :initform nil
673     :initarg :initform
674     :accessor slot-definition-initform)
675 wlott 1.1 (initfunction
676 ram 1.6 :initform nil
677 ram 1.7 :type (or function null)
678 ram 1.6 :initarg :initfunction
679     :accessor slot-definition-initfunction)
680 wlott 1.1 (readers
681     :initform nil
682 ram 1.6 :initarg :readers
683     :accessor slot-definition-readers)
684 wlott 1.1 (writers
685     :initform nil
686 ram 1.6 :initarg :writers
687     :accessor slot-definition-writers)
688 wlott 1.1 (initargs
689     :initform nil
690 ram 1.6 :initarg :initargs
691     :accessor slot-definition-initargs)
692 wlott 1.1 (type
693 ram 1.6 :initform t
694     :initarg :type
695     :accessor slot-definition-type)
696 ram 1.4 (class
697     :initform nil
698 ram 1.6 :initarg :class
699 ram 1.7 :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 wlott 1.1
705 ram 1.7
706 ram 1.6 (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 ram 1.7 ((location ; nil, a fixnum, a cons: (slot-name . value)
731     :initform nil
732     :accessor slot-definition-location)
733     (reader-function ; #'(lambda (object) ...)
734 ram 1.6 :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 ram 1.7 :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 ram 1.6
748 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
749     direct-slot-definition)
750 ram 1.6 ())
751 wlott 1.1
752     (defclass standard-effective-slot-definition (standard-slot-definition
753     effective-slot-definition)
754 ram 1.7 ())
755 wlott 1.1
756 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
757     direct-slot-definition)
758     ())
759 wlott 1.1
760 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
761     effective-slot-definition)
762     ())
763 wlott 1.1
764 ram 1.7
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 ram 1.6 (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 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5