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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5