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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (hide annotations)
Thu Feb 6 15:20:12 2003 UTC (11 years, 2 months ago) by gerd
Branch: MAIN
CVS Tags: release-18e-base, release-18e-pre2, cold-pcl-base, release-18e, release-18e-pre1
Branch point for: release-18e-branch, cold-pcl
Changes since 1.32: +1 -1 lines
* pcl/defs.lisp (standard-method): Change superclass
plist-mixin to documentation-mixin so that we don't throw
away the method documentation.

* pcl/cmucl-documentation.lisp (setf documentation): Use
set-random-documentation.

* pcl/defcombin.lisp (set-random-documentation): New function.
(load-short-defcombin, load-long-defcombin): Use it.

* pcl/env.lisp (describe-object) <standard-generic-function>:
Print the generic function doc string, if any.  Print method doc
strings.
(describe-object) <class>: Print slots.

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

  ViewVC Help
Powered by ViewVC 1.1.5