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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Mon Aug 7 13:50:21 2000 UTC (13 years, 8 months ago) by pw
Branch: MAIN
Changes since 1.19: +2 -1 lines
Disable new code in inform-type-system-about-std-class which seems
to trigger trouble when native compiling defcombin.lisp
1 wlott 1.1 ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
2     ;;;
3     ;;; *************************************************************************
4     ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5     ;;; All rights reserved.
6     ;;;
7     ;;; Use and copying of this software and preparation of derivative works
8     ;;; based upon this software are permitted. Any distribution of this
9     ;;; software or derivative works must comply with all applicable United
10     ;;; States export control laws.
11     ;;;
12     ;;; This software is made available AS IS, and Xerox Corporation makes no
13     ;;; warranty about the software, its performance or its conformity to any
14     ;;; specification.
15     ;;;
16     ;;; Any person obtaining a copy of this software is requested to send their
17     ;;; name and post office or electronic mail address to:
18     ;;; CommonLoops Coordinator
19     ;;; Xerox PARC
20     ;;; 3333 Coyote Hill Rd.
21     ;;; Palo Alto, CA 94304
22     ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23     ;;;
24     ;;; Suggestions, comments and requests for improvements are also welcome.
25     ;;; *************************************************************************
26     ;;;
27    
28 phg 1.9 (in-package :pcl)
29 wlott 1.1
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 pw 1.11 ; defvar is now actually in macros
38     ;(defvar *boot-state* ()) ;NIL
39 ram 1.6 ;EARLY
40     ;BRAID
41     ;COMPLETE
42 ram 1.8 (defvar *fegf-started-p* nil)
43 ram 1.6
44 ram 1.8
45 wlott 1.1 )
46    
47 ram 1.6 (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 wlott 1.1 )
58    
59    
60    
61     ;;;
62     ;;; If symbol names a function which is traced or advised, return the
63     ;;; unadvised, traced etc. definition. This lets me get at the generic
64     ;;; function object even when it is traced.
65     ;;;
66 dtc 1.16 (declaim (inline gdefinition))
67     (defun gdefinition (symbol)
68 pw 1.15 (fdefinition symbol))
69 wlott 1.1
70     ;;;
71     ;;; If symbol names a function which is traced or advised, redefine
72     ;;; the `real' definition without affecting the advise.
73 pw 1.18 ;;
74 dtc 1.16 (defun (setf gdefinition) (new-definition name)
75 pw 1.17 (c::%%defun name new-definition nil)
76     (c::note-name-defined name :function)
77     new-definition)
78 ram 1.8
79 ram 1.6 (proclaim '(special *the-class-t*
80 ram 1.8 *the-class-vector* *the-class-symbol*
81 ram 1.6 *the-class-string* *the-class-sequence*
82     *the-class-rational* *the-class-ratio*
83     *the-class-number* *the-class-null* *the-class-list*
84     *the-class-integer* *the-class-float* *the-class-cons*
85     *the-class-complex* *the-class-character*
86     *the-class-bit-vector* *the-class-array*
87 dtc 1.12 *the-class-stream*
88 ram 1.6
89     *the-class-slot-object*
90 dtc 1.14 *the-class-structure-object*
91     *the-class-std-object*
92 ram 1.6 *the-class-standard-object*
93 dtc 1.14 *the-class-funcallable-standard-object*
94 ram 1.6 *the-class-class*
95     *the-class-generic-function*
96     *the-class-built-in-class*
97     *the-class-slot-class*
98     *the-class-structure-class*
99 dtc 1.14 *the-class-std-class*
100 ram 1.6 *the-class-standard-class*
101     *the-class-funcallable-standard-class*
102 ram 1.8 *the-class-method*
103 ram 1.6 *the-class-standard-method*
104 ram 1.8 *the-class-standard-reader-method*
105     *the-class-standard-writer-method*
106     *the-class-standard-boundp-method*
107 ram 1.6 *the-class-standard-generic-function*
108 ram 1.8 *the-class-standard-effective-slot-definition*
109 ram 1.6
110 ram 1.8 *the-eslotd-standard-class-slots*
111     *the-eslotd-funcallable-standard-class-slots*))
112    
113 ram 1.6 (proclaim '(special *the-wrapper-of-t*
114     *the-wrapper-of-vector* *the-wrapper-of-symbol*
115     *the-wrapper-of-string* *the-wrapper-of-sequence*
116     *the-wrapper-of-rational* *the-wrapper-of-ratio*
117     *the-wrapper-of-number* *the-wrapper-of-null*
118     *the-wrapper-of-list* *the-wrapper-of-integer*
119     *the-wrapper-of-float* *the-wrapper-of-cons*
120     *the-wrapper-of-complex* *the-wrapper-of-character*
121     *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
122    
123 pw 1.11 ;;;; Type specifier hackery:
124    
125     ;;; internal to this file.
126 ram 1.6 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
127     (if (symbolp class)
128     (or (find-class class (not make-forward-referenced-class-p))
129     (ensure-class class))
130     class))
131    
132 pw 1.11 ;;; Interface
133 ram 1.6 (defun specializer-from-type (type &aux args)
134     (when (consp type)
135     (setq args (cdr type) type (car type)))
136     (cond ((symbolp type)
137     (or (and (null args) (find-class type))
138     (ecase type
139     (class (coerce-to-class (car args)))
140 ram 1.8 (prototype (make-instance 'class-prototype-specializer
141     :object (coerce-to-class (car args))))
142 ram 1.6 (class-eq (class-eq-specializer (coerce-to-class (car args))))
143     (eql (intern-eql-specializer (car args))))))
144 pw 1.11 ((and (null args) (typep type 'lisp:class))
145     (or (kernel:class-pcl-class type)
146     (find-structure-class (lisp:class-name type))))
147 ram 1.6 ((specializerp type) type)))
148    
149 pw 1.11 ;;; interface
150 ram 1.6 (defun type-from-specializer (specl)
151 ram 1.8 (cond ((eq specl 't)
152     't)
153     ((consp specl)
154     (unless (member (car specl) '(class prototype class-eq eql))
155 ram 1.6 (error "~S is not a legal specializer type" specl))
156     specl)
157 ram 1.8 ((progn
158     (when (symbolp specl)
159     ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
160     (setq specl (find-class specl)))
161     (or (not (eq *boot-state* 'complete))
162     (specializerp specl)))
163     (specializer-type specl))
164 ram 1.6 (t
165     (error "~s is neither a type nor a specializer" specl))))
166    
167 ram 1.4 (defun type-class (type)
168 ram 1.6 (declare (special *the-class-t*))
169     (setq type (type-from-specializer type))
170     (if (atom type)
171 ram 1.8 (if (eq type 't)
172     *the-class-t*
173     (error "bad argument to type-class"))
174 ram 1.4 (case (car type)
175 ram 1.6 (eql (class-of (cadr type)))
176 ram 1.8 (prototype (class-of (cadr type))) ;?
177 ram 1.6 (class-eq (cadr type))
178     (class (cadr type)))))
179 ram 1.4
180 ram 1.6 (defun class-eq-type (class)
181     (specializer-type (class-eq-specializer class)))
182 ram 1.4
183 ram 1.6 (defun inform-type-system-about-std-class (name)
184 pw 1.18 ;; This should only be called if metaclass is standard-class.
185     ;; Compiler problems have been seen if the metaclass is
186     ;; funcallable-standard-class and this is called from the defclass macro
187     ;; expander. However, bootstrap-meta-braid calls this for funcallable-
188     ;; standard-class metaclasses but *boot-state* is not 'complete then.
189     ;;
190     ;; The only effect of this code is to ensure a lisp:standard-class class
191     ;; exists so as to avoid undefined-function compiler warnings. The
192     ;; skeleton class will be replaced at load-time with the correct object.
193     ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.
194 pw 1.20 (declare (ignorable name))
195     #+nil ;; This is causing problems with native compile of defcombin.lisp
196 pw 1.18 (when (and (eq *boot-state* 'complete)
197     (null (lisp:find-class name nil)))
198     (setf (lisp:find-class name)
199     (lisp::make-standard-class :name name))))
200 ram 1.6
201 ram 1.4 (defun make-class-eq-predicate (class)
202     (when (symbolp class) (setq class (find-class class)))
203     #'(lambda (object) (eq class (class-of object))))
204    
205     (defun make-eql-predicate (eql-object)
206     #'(lambda (object) (eql eql-object object)))
207    
208 ram 1.8
209 pw 1.11 ;;; Internal to this file.
210 wlott 1.1 ;;;
211     ;;; These functions are a pale imitiation of their namesake. They accept
212     ;;; class objects or types where they should.
213     ;;;
214 ram 1.6 (defun *normalize-type (type)
215     (cond ((consp type)
216     (if (member (car type) '(not and or))
217     `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
218     (if (null (cdr type))
219     (*normalize-type (car type))
220     type)))
221     ((symbolp type)
222     (let ((class (find-class type nil)))
223     (if class
224     (let ((type (specializer-type class)))
225     (if (listp type) type `(,type)))
226     `(,type))))
227 ram 1.8 ((or (not (eq *boot-state* 'complete))
228     (specializerp type))
229     (specializer-type type))
230 ram 1.6 (t
231     (error "~s is not a type" type))))
232    
233 pw 1.11 ;;; internal to this file...
234 ram 1.6 (defun convert-to-system-type (type)
235     (case (car type)
236 pw 1.11 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
237     (cdr type))))
238     ((class class-eq) ; class-eq is impossible to do right
239 pw 1.17 (kernel:layout-class (class-wrapper (cadr type))))
240 ram 1.6 (eql type)
241     (t (if (null (cdr type))
242     (car type)
243     type))))
244    
245 pw 1.11
246     ;;; *SUBTYPEP -- Interface
247     ;;;
248 phg 1.10 ;Writing the missing NOT and AND clauses will improve
249     ;the quality of code generated by generate-discrimination-net, but
250     ;calling subtypep in place of just returning (values nil nil) can be
251     ;very slow. *subtypep is used by PCL itself, and must be fast.
252 wlott 1.1 (defun *subtypep (type1 type2)
253 ram 1.8 (if (equal type1 type2)
254     (values t t)
255     (if (eq *boot-state* 'early)
256     (values (eq type1 type2) t)
257 phg 1.10 (let ((*in-precompute-effective-methods-p* t))
258 ram 1.8 (declare (special *in-precompute-effective-methods-p*))
259 phg 1.10 ;; *in-precompute-effective-methods-p* is not a good name.
260     ;; It changes the way class-applicable-using-class-p works.
261 ram 1.8 (setq type1 (*normalize-type type1))
262     (setq type2 (*normalize-type type2))
263 phg 1.10 (case (car type2)
264     (not
265     (values nil nil)) ; Should improve this.
266     (and
267     (values nil nil)) ; Should improve this.
268     ((eql wrapper-eq class-eq class)
269     (multiple-value-bind (app-p maybe-app-p)
270     (specializer-applicable-using-type-p type2 type1)
271     (values app-p (or app-p (not maybe-app-p)))))
272     (t
273     (subtypep (convert-to-system-type type1)
274     (convert-to-system-type type2))))))))
275 wlott 1.1
276    
277     (defvar *built-in-class-symbols* ())
278     (defvar *built-in-wrapper-symbols* ())
279    
280     (defun get-built-in-class-symbol (class-name)
281     (or (cadr (assq class-name *built-in-class-symbols*))
282     (let ((symbol (intern (format nil
283     "*THE-CLASS-~A*"
284     (symbol-name class-name))
285     *the-pcl-package*)))
286     (push (list class-name symbol) *built-in-class-symbols*)
287     symbol)))
288    
289     (defun get-built-in-wrapper-symbol (class-name)
290     (or (cadr (assq class-name *built-in-wrapper-symbols*))
291     (let ((symbol (intern (format nil
292     "*THE-WRAPPER-OF-~A*"
293     (symbol-name class-name))
294     *the-pcl-package*)))
295     (push (list class-name symbol) *built-in-wrapper-symbols*)
296     symbol)))
297    
298    
299    
300    
301     (pushnew 'class *variable-declarations*)
302     (pushnew 'variable-rebinding *variable-declarations*)
303    
304     (defun variable-class (var env)
305     (caddr (variable-declaration 'class var env)))
306    
307 ram 1.8 (defvar *name->class->slotd-table* (make-hash-table))
308 wlott 1.1
309    
310     ;;;
311     ;;; This is used by combined methods to communicate the next methods to
312     ;;; the methods they call. This variable is captured by a lexical variable
313     ;;; of the methods to give it the proper lexical scope.
314     ;;;
315     (defvar *next-methods* nil)
316    
317     (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
318    
319     (defvar *umi-gfs*)
320     (defvar *umi-complete-classes*)
321     (defvar *umi-reorder*)
322    
323     (defvar *invalidate-discriminating-function-force-p* ())
324     (defvar *invalid-dfuns-on-stack* ())
325    
326    
327     (defvar *standard-method-combination*)
328    
329     (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
330    
331    
332 ram 1.6 (defmacro define-gf-predicate (predicate-name &rest classes)
333     `(progn
334     (defmethod ,predicate-name ((x t)) nil)
335     ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
336     classes)))
337 wlott 1.1
338 ram 1.6 (defun make-class-predicate-name (name)
339 ram 1.8 (intern (format nil "~A::~A class predicate"
340     (package-name (symbol-package name))
341     name)
342     *the-pcl-package*))
343 wlott 1.1
344 ram 1.8 (defun plist-value (object name)
345     (getf (object-plist object) name))
346 wlott 1.1
347 pw 1.15 (defun (setf plist-value) (new-value object name)
348 ram 1.8 (if new-value
349     (setf (getf (object-plist object) name) new-value)
350     (progn
351     (remf (object-plist object) name)
352     nil)))
353 ram 1.6
354 wlott 1.1
355    
356     (defvar *built-in-classes*
357     ;;
358     ;; name supers subs cdr of cpl
359 ram 1.8 ;; prototype
360 ram 1.6 '(;(t () (number sequence array character symbol) ())
361 ram 1.8 (number (t) (complex float rational) (t))
362 ram 1.6 (complex (number) () (number t)
363 ram 1.8 #c(1 1))
364 ram 1.6 (float (number) () (number t)
365 ram 1.8 1.0)
366     (rational (number) (integer ratio) (number t))
367 ram 1.6 (integer (rational) () (rational number t)
368 ram 1.8 1)
369 ram 1.6 (ratio (rational) () (rational number t)
370     1/2)
371 wlott 1.1
372 ram 1.8 (sequence (t) (list vector) (t))
373     (list (sequence) (cons null) (sequence t))
374 ram 1.6 (cons (list) () (list sequence t)
375 ram 1.8 (nil))
376 wlott 1.1
377    
378 ram 1.6 (array (t) (vector) (t)
379 ram 1.8 #2A((NIL)))
380 wlott 1.1 (vector (array
381 ram 1.6 sequence) (string bit-vector) (array sequence t)
382 ram 1.8 #())
383 ram 1.6 (string (vector) () (vector array sequence t)
384 ram 1.8 "")
385 ram 1.6 (bit-vector (vector) () (vector array sequence t)
386 ram 1.8 #*1)
387 ram 1.6 (character (t) () (t)
388 ram 1.8 #\c)
389 wlott 1.1
390 ram 1.6 (symbol (t) (null) (t)
391 ram 1.8 symbol)
392     (null (symbol
393     list) () (symbol list sequence t)
394     nil)))
395 wlott 1.1
396 pw 1.11 (labels ((direct-supers (class)
397     (if (typep class 'lisp:built-in-class)
398     (kernel:built-in-class-direct-superclasses class)
399     (let ((inherits (kernel:layout-inherits
400     (kernel:class-layout class))))
401     (list (svref inherits (1- (length inherits)))))))
402     (direct-subs (class)
403     (ext:collect ((res))
404     (let ((subs (kernel:class-subclasses class)))
405     (when subs
406     (ext:do-hash (sub v subs)
407     (declare (ignore v))
408     (when (member class (direct-supers sub))
409     (res sub)))))
410     (res))))
411     (ext:collect ((res))
412     (dolist (bic kernel::built-in-classes)
413     (let* ((name (car bic))
414     (class (lisp:find-class name)))
415     (unless (member name '(t kernel:instance kernel:funcallable-instance
416 dtc 1.12 function stream))
417 pw 1.11 (res `(,name
418     ,(mapcar #'lisp:class-name (direct-supers class))
419     ,(mapcar #'lisp:class-name (direct-subs class))
420     ,(map 'list #'(lambda (x)
421     (lisp:class-name (kernel:layout-class x)))
422     (reverse
423     (kernel:layout-inherits
424     (kernel:class-layout class))))
425     ,(let ((found (assoc name *built-in-classes*)))
426     (if found (fifth found) 42)))))))
427     (setq *built-in-classes* (res))))
428    
429 wlott 1.1
430     ;;;
431     ;;; The classes that define the kernel of the metabraid.
432     ;;;
433     (defclass t () ()
434     (:metaclass built-in-class))
435    
436 pw 1.17 (defclass kernel:instance (t) ()
437     (:metaclass built-in-class))
438 pw 1.11
439 pw 1.17 (defclass function (t) ()
440     (:metaclass built-in-class))
441 dtc 1.12
442 pw 1.17 (defclass kernel:funcallable-instance (function) ()
443     (:metaclass built-in-class))
444    
445 dtc 1.19 (defclass stream (kernel:instance) ()
446 pw 1.17 (:metaclass built-in-class))
447 pw 1.11
448 dtc 1.14 (defclass slot-object (t) ()
449 ram 1.6 (:metaclass slot-class))
450 wlott 1.1
451 pw 1.17 (defclass structure-object (slot-object kernel:instance) ()
452 ram 1.6 (:metaclass structure-class))
453    
454 pw 1.15 (defstruct (dead-beef-structure-object
455 ram 1.6 (:constructor |STRUCTURE-OBJECT class constructor|)))
456    
457 pw 1.11
458 dtc 1.14 (defclass std-object (slot-object) ()
459     (:metaclass std-class))
460    
461 pw 1.17 (defclass standard-object (std-object kernel:instance) ())
462 ram 1.6
463 dtc 1.14 (defclass funcallable-standard-object (std-object
464 pw 1.17 kernel:funcallable-instance)
465 dtc 1.14 ()
466     (:metaclass funcallable-standard-class))
467 wlott 1.1
468 dtc 1.14 (defclass specializer (standard-object)
469 ram 1.6 ((type
470     :initform nil
471     :reader specializer-type)))
472 wlott 1.1
473 dtc 1.14 (defclass definition-source-mixin (std-object)
474 wlott 1.1 ((source
475     :initform (load-truename)
476     :reader definition-source
477 dtc 1.14 :initarg :definition-source))
478     (:metaclass std-class))
479 wlott 1.1
480 dtc 1.14 (defclass plist-mixin (std-object)
481 wlott 1.1 ((plist
482 ram 1.6 :initform ()
483 dtc 1.14 :accessor object-plist))
484     (:metaclass std-class))
485 wlott 1.1
486 ram 1.8 (defclass documentation-mixin (plist-mixin)
487 dtc 1.14 ()
488     (:metaclass std-class))
489 wlott 1.1
490     (defclass dependent-update-mixin (plist-mixin)
491 dtc 1.14 ()
492     (:metaclass std-class))
493 wlott 1.1
494     ;;;
495     ;;; The class CLASS is a specified basic class. It is the common superclass
496 ram 1.8 ;;; of any kind of class. That is any class that can be a metaclass must
497     ;;; have the class CLASS in its class precedence list.
498 wlott 1.1 ;;;
499 ram 1.8 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
500     specializer)
501     ((name
502     :initform nil
503     :initarg :name
504     :accessor class-name)
505     (class-eq-specializer
506 ram 1.6 :initform nil
507 ram 1.8 :reader class-eq-specializer)
508     (direct-superclasses
509     :initform ()
510     :reader class-direct-superclasses)
511 wlott 1.1 (direct-subclasses
512 ram 1.8 :initform ()
513 wlott 1.1 :reader class-direct-subclasses)
514 ram 1.8 (direct-methods
515     :initform (cons nil nil))
516     (predicate-name
517 ram 1.6 :initform nil
518 ram 1.8 :reader class-predicate-name)))
519 wlott 1.1
520     ;;;
521     ;;; The class PCL-CLASS is an implementation-specific common superclass of
522     ;;; all specified subclasses of the class CLASS.
523     ;;;
524     (defclass pcl-class (class)
525 ram 1.8 ((class-precedence-list
526     :reader class-precedence-list)
527 ram 1.6 (can-precede-list
528     :initform ()
529     :reader class-can-precede-list)
530     (incompatible-superclass-list
531     :initform ()
532     :accessor class-incompatible-superclass-list)
533 wlott 1.1 (wrapper
534 ram 1.6 :initform nil
535     :reader class-wrapper)
536 ram 1.8 (prototype
537     :initform nil
538     :reader class-prototype)))
539 wlott 1.1
540 ram 1.6 (defclass slot-class (pcl-class)
541 ram 1.8 ((direct-slots
542     :initform ()
543     :accessor class-direct-slots)
544     (slots
545     :initform ()
546     :accessor class-slots)
547     (initialize-info
548     :initform nil
549     :accessor class-initialize-info)))
550 ram 1.6
551 wlott 1.1 ;;;
552     ;;; The class STD-CLASS is an implementation-specific common superclass of
553     ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
554     ;;;
555 ram 1.6 (defclass std-class (slot-class)
556 ram 1.8 ())
557 wlott 1.1
558     (defclass standard-class (std-class)
559     ())
560    
561     (defclass funcallable-standard-class (std-class)
562     ())
563    
564     (defclass forward-referenced-class (pcl-class) ())
565    
566     (defclass built-in-class (pcl-class) ())
567    
568 ram 1.6 (defclass structure-class (slot-class)
569 ram 1.8 ((defstruct-form
570     :initform ()
571     :accessor class-defstruct-form)
572 ram 1.6 (defstruct-constructor
573     :initform nil
574 ram 1.8 :accessor class-defstruct-constructor)
575 ram 1.6 (from-defclass-p
576     :initform nil
577 ram 1.8 :initarg :from-defclass-p)))
578    
579 ram 1.6
580     (defclass specializer-with-object (specializer) ())
581    
582     (defclass exact-class-specializer (specializer) ())
583    
584     (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
585     ((object :initarg :class :reader specializer-class :reader specializer-object)))
586    
587 ram 1.8 (defclass class-prototype-specializer (specializer-with-object)
588     ((object :initarg :class :reader specializer-class :reader specializer-object)))
589    
590 ram 1.6 (defclass eql-specializer (exact-class-specializer specializer-with-object)
591     ((object :initarg :object :reader specializer-object
592     :reader eql-specializer-object)))
593    
594     (defvar *eql-specializer-table* (make-hash-table :test 'eql))
595    
596     (defun intern-eql-specializer (object)
597     (or (gethash object *eql-specializer-table*)
598     (setf (gethash object *eql-specializer-table*)
599     (make-instance 'eql-specializer :object object))))
600    
601 wlott 1.1
602     ;;;
603     ;;; Slot definitions.
604     ;;;
605 dtc 1.14 (defclass slot-definition (standard-object)
606 wlott 1.1 ((name
607     :initform nil
608 ram 1.6 :initarg :name
609     :accessor slot-definition-name)
610 wlott 1.1 (initform
611 ram 1.6 :initform nil
612     :initarg :initform
613     :accessor slot-definition-initform)
614 wlott 1.1 (initfunction
615 ram 1.6 :initform nil
616     :initarg :initfunction
617     :accessor slot-definition-initfunction)
618 wlott 1.1 (readers
619     :initform nil
620 ram 1.6 :initarg :readers
621     :accessor slot-definition-readers)
622 wlott 1.1 (writers
623     :initform nil
624 ram 1.6 :initarg :writers
625     :accessor slot-definition-writers)
626 wlott 1.1 (initargs
627     :initform nil
628 ram 1.6 :initarg :initargs
629     :accessor slot-definition-initargs)
630 wlott 1.1 (type
631 ram 1.6 :initform t
632     :initarg :type
633     :accessor slot-definition-type)
634 ram 1.8 (documentation
635     :initform ""
636     :initarg :documentation)
637 ram 1.4 (class
638     :initform nil
639 ram 1.6 :initarg :class
640 ram 1.8 :accessor slot-definition-class)))
641 wlott 1.1
642 ram 1.6 (defclass standard-slot-definition (slot-definition)
643     ((allocation
644     :initform :instance
645     :initarg :allocation
646     :accessor slot-definition-allocation)))
647    
648     (defclass structure-slot-definition (slot-definition)
649     ((defstruct-accessor-symbol
650     :initform nil
651     :initarg :defstruct-accessor-symbol
652     :accessor slot-definition-defstruct-accessor-symbol)
653     (internal-reader-function
654     :initform nil
655     :initarg :internal-reader-function
656     :accessor slot-definition-internal-reader-function)
657     (internal-writer-function
658     :initform nil
659     :initarg :internal-writer-function
660     :accessor slot-definition-internal-writer-function)))
661    
662     (defclass direct-slot-definition (slot-definition)
663     ())
664    
665     (defclass effective-slot-definition (slot-definition)
666 ram 1.8 ((reader-function ; #'(lambda (object) ...)
667 ram 1.6 :accessor slot-definition-reader-function)
668     (writer-function ; #'(lambda (new-value object) ...)
669     :accessor slot-definition-writer-function)
670     (boundp-function ; #'(lambda (object) ...)
671     :accessor slot-definition-boundp-function)
672     (accessor-flags
673 ram 1.8 :initform 0)))
674 ram 1.6
675 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
676     direct-slot-definition)
677 ram 1.6 ())
678 wlott 1.1
679     (defclass standard-effective-slot-definition (standard-slot-definition
680     effective-slot-definition)
681 ram 1.8 ((location ; nil, a fixnum, a cons: (slot-name . value)
682     :initform nil
683     :accessor slot-definition-location)))
684 wlott 1.1
685 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
686     direct-slot-definition)
687     ())
688 wlott 1.1
689 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
690     effective-slot-definition)
691     ())
692 wlott 1.1
693 dtc 1.14 (defclass method (standard-object) ())
694 ram 1.7
695 ram 1.8 (defclass standard-method (definition-source-mixin plist-mixin method)
696     ((generic-function
697     :initform nil
698     :accessor method-generic-function)
699     ; (qualifiers
700     ; :initform ()
701     ; :initarg :qualifiers
702     ; :reader method-qualifiers)
703     (specializers
704     :initform ()
705     :initarg :specializers
706     :reader method-specializers)
707     (lambda-list
708     :initform ()
709     :initarg :lambda-list
710     :reader method-lambda-list)
711     (function
712     :initform nil
713     :initarg :function) ;no writer
714     (fast-function
715     :initform nil
716     :initarg :fast-function ;no writer
717     :reader method-fast-function)
718     ; (documentation
719     ; :initform nil
720     ; :initarg :documentation
721     ; :reader method-documentation)
722     ))
723 ram 1.7
724 ram 1.8 (defclass standard-accessor-method (standard-method)
725     ((slot-name :initform nil
726     :initarg :slot-name
727     :reader accessor-method-slot-name)
728     (slot-definition :initform nil
729     :initarg :slot-definition
730     :reader accessor-method-slot-definition)))
731 ram 1.7
732 ram 1.8 (defclass standard-reader-method (standard-accessor-method) ())
733 ram 1.7
734 ram 1.8 (defclass standard-writer-method (standard-accessor-method) ())
735 ram 1.7
736 ram 1.8 (defclass standard-boundp-method (standard-accessor-method) ())
737 ram 1.7
738 ram 1.8 (defclass generic-function (dependent-update-mixin
739     definition-source-mixin
740     documentation-mixin
741 dtc 1.14 funcallable-standard-object)
742 ram 1.8 ()
743     (:metaclass funcallable-standard-class))
744    
745     (defclass standard-generic-function (generic-function)
746     ((name
747     :initform nil
748     :initarg :name
749     :accessor generic-function-name)
750     (methods
751     :initform ()
752     :accessor generic-function-methods)
753     (method-class
754     :initarg :method-class
755     :accessor generic-function-method-class)
756     (method-combination
757     :initarg :method-combination
758     :accessor generic-function-method-combination)
759     (arg-info
760     :initform (make-arg-info)
761     :reader gf-arg-info)
762     (dfun-state
763     :initform ()
764     :accessor gf-dfun-state)
765     (pretty-arglist
766     :initform ()
767     :accessor gf-pretty-arglist)
768     )
769     (:metaclass funcallable-standard-class)
770     (:default-initargs :method-class *the-class-standard-method*
771     :method-combination *standard-method-combination*))
772 ram 1.7
773 dtc 1.14 (defclass method-combination (standard-object) ())
774 ram 1.7
775 ram 1.8 (defclass standard-method-combination
776     (definition-source-mixin method-combination)
777     ((type :reader method-combination-type
778     :initarg :type)
779     (documentation :reader method-combination-documentation
780     :initarg :documentation)
781     (options :reader method-combination-options
782     :initarg :options)))
783 ram 1.7
784 ram 1.6 (defparameter *early-class-predicates*
785     '((specializer specializerp)
786     (exact-class-specializer exact-class-specializer-p)
787     (class-eq-specializer class-eq-specializer-p)
788     (eql-specializer eql-specializer-p)
789     (class classp)
790 ram 1.8 (slot-class slot-class-p)
791 dtc 1.14 (std-class std-class-p)
792 ram 1.6 (standard-class standard-class-p)
793     (funcallable-standard-class funcallable-standard-class-p)
794     (structure-class structure-class-p)
795 ram 1.8 (forward-referenced-class forward-referenced-class-p)
796     (method method-p)
797     (standard-method standard-method-p)
798     (standard-accessor-method standard-accessor-method-p)
799     (standard-reader-method standard-reader-method-p)
800     (standard-writer-method standard-writer-method-p)
801     (standard-boundp-method standard-boundp-method-p)
802     (generic-function generic-function-p)
803     (standard-generic-function standard-generic-function-p)
804     (method-combination method-combination-p)))
805 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5