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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5