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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5