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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (hide annotations)
Mon Sep 9 16:08:58 2002 UTC (11 years, 7 months ago) by pmai
Branch: MAIN
Changes since 1.24: +0 -36 lines
Patch by Gerd Moellmann to remove further unused code from defs.lisp.
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 wlott 1.1
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 pmai 1.24 (eval-when (:load-toplevel :execute)
48 ram 1.6 (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 pw 1.21 (declaim (special *the-class-t*
80     *the-class-vector* *the-class-symbol*
81     *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     *the-class-stream*
88 ram 1.6
89 pw 1.21 *the-class-slot-object*
90     *the-class-structure-object*
91     *the-class-std-object*
92     *the-class-standard-object*
93     *the-class-funcallable-standard-object*
94     *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     *the-class-std-class*
100     *the-class-standard-class*
101     *the-class-funcallable-standard-class*
102     *the-class-method*
103     *the-class-standard-method*
104     *the-class-standard-reader-method*
105     *the-class-standard-writer-method*
106     *the-class-standard-boundp-method*
107     *the-class-standard-generic-function*
108     *the-class-standard-effective-slot-definition*
109    
110     *the-eslotd-standard-class-slots*
111     *the-eslotd-funcallable-standard-class-slots*))
112 ram 1.6
113 pw 1.21 (declaim (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 ram 1.6
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 pmai 1.23 (cond ((eq specl t)
152     t)
153 ram 1.8 ((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 pmai 1.23 (if (eq type t)
172 ram 1.8 *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 pw 1.18 (when (and (eq *boot-state* 'complete)
196     (null (lisp:find-class name nil)))
197     (setf (lisp:find-class name)
198     (lisp::make-standard-class :name name))))
199 ram 1.6
200 pw 1.11 ;;; Internal to this file.
201 wlott 1.1 ;;;
202     ;;; These functions are a pale imitiation of their namesake. They accept
203     ;;; class objects or types where they should.
204     ;;;
205 ram 1.6 (defun *normalize-type (type)
206     (cond ((consp type)
207     (if (member (car type) '(not and or))
208     `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
209     (if (null (cdr type))
210     (*normalize-type (car type))
211     type)))
212     ((symbolp type)
213     (let ((class (find-class type nil)))
214     (if class
215     (let ((type (specializer-type class)))
216     (if (listp type) type `(,type)))
217     `(,type))))
218 ram 1.8 ((or (not (eq *boot-state* 'complete))
219     (specializerp type))
220     (specializer-type type))
221 ram 1.6 (t
222     (error "~s is not a type" type))))
223    
224 pw 1.11 ;;; internal to this file...
225 ram 1.6 (defun convert-to-system-type (type)
226     (case (car type)
227 pw 1.11 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
228     (cdr type))))
229     ((class class-eq) ; class-eq is impossible to do right
230 pw 1.17 (kernel:layout-class (class-wrapper (cadr type))))
231 ram 1.6 (eql type)
232     (t (if (null (cdr type))
233     (car type)
234     type))))
235    
236 pw 1.11
237     ;;; *SUBTYPEP -- Interface
238     ;;;
239 phg 1.10 ;Writing the missing NOT and AND clauses will improve
240     ;the quality of code generated by generate-discrimination-net, but
241     ;calling subtypep in place of just returning (values nil nil) can be
242     ;very slow. *subtypep is used by PCL itself, and must be fast.
243 wlott 1.1 (defun *subtypep (type1 type2)
244 ram 1.8 (if (equal type1 type2)
245     (values t t)
246     (if (eq *boot-state* 'early)
247     (values (eq type1 type2) t)
248 phg 1.10 (let ((*in-precompute-effective-methods-p* t))
249 ram 1.8 (declare (special *in-precompute-effective-methods-p*))
250 phg 1.10 ;; *in-precompute-effective-methods-p* is not a good name.
251     ;; It changes the way class-applicable-using-class-p works.
252 ram 1.8 (setq type1 (*normalize-type type1))
253     (setq type2 (*normalize-type type2))
254 phg 1.10 (case (car type2)
255     (not
256     (values nil nil)) ; Should improve this.
257     (and
258     (values nil nil)) ; Should improve this.
259     ((eql wrapper-eq class-eq class)
260     (multiple-value-bind (app-p maybe-app-p)
261     (specializer-applicable-using-type-p type2 type1)
262     (values app-p (or app-p (not maybe-app-p)))))
263     (t
264     (subtypep (convert-to-system-type type1)
265     (convert-to-system-type type2))))))))
266 wlott 1.1
267    
268     (defvar *built-in-class-symbols* ())
269     (defvar *built-in-wrapper-symbols* ())
270    
271     (defun get-built-in-class-symbol (class-name)
272     (or (cadr (assq class-name *built-in-class-symbols*))
273     (let ((symbol (intern (format nil
274     "*THE-CLASS-~A*"
275     (symbol-name class-name))
276     *the-pcl-package*)))
277     (push (list class-name symbol) *built-in-class-symbols*)
278     symbol)))
279    
280     (defun get-built-in-wrapper-symbol (class-name)
281     (or (cadr (assq class-name *built-in-wrapper-symbols*))
282     (let ((symbol (intern (format nil
283     "*THE-WRAPPER-OF-~A*"
284     (symbol-name class-name))
285     *the-pcl-package*)))
286     (push (list class-name symbol) *built-in-wrapper-symbols*)
287     symbol)))
288    
289    
290    
291    
292     (pushnew 'class *variable-declarations*)
293     (pushnew 'variable-rebinding *variable-declarations*)
294    
295 ram 1.8 (defvar *name->class->slotd-table* (make-hash-table))
296 wlott 1.1
297     (defvar *standard-method-combination*)
298    
299    
300    
301 ram 1.6 (defun make-class-predicate-name (name)
302 ram 1.8 (intern (format nil "~A::~A class predicate"
303     (package-name (symbol-package name))
304     name)
305     *the-pcl-package*))
306 wlott 1.1
307 ram 1.8 (defun plist-value (object name)
308     (getf (object-plist object) name))
309 wlott 1.1
310 pw 1.15 (defun (setf plist-value) (new-value object name)
311 ram 1.8 (if new-value
312     (setf (getf (object-plist object) name) new-value)
313     (progn
314     (remf (object-plist object) name)
315     nil)))
316 ram 1.6
317 wlott 1.1
318    
319     (defvar *built-in-classes*
320     ;;
321     ;; name supers subs cdr of cpl
322 ram 1.8 ;; prototype
323 ram 1.6 '(;(t () (number sequence array character symbol) ())
324 ram 1.8 (number (t) (complex float rational) (t))
325 ram 1.6 (complex (number) () (number t)
326 ram 1.8 #c(1 1))
327 ram 1.6 (float (number) () (number t)
328 ram 1.8 1.0)
329     (rational (number) (integer ratio) (number t))
330 ram 1.6 (integer (rational) () (rational number t)
331 ram 1.8 1)
332 ram 1.6 (ratio (rational) () (rational number t)
333     1/2)
334 wlott 1.1
335 ram 1.8 (sequence (t) (list vector) (t))
336     (list (sequence) (cons null) (sequence t))
337 ram 1.6 (cons (list) () (list sequence t)
338 ram 1.8 (nil))
339 wlott 1.1
340    
341 ram 1.6 (array (t) (vector) (t)
342 ram 1.8 #2A((NIL)))
343 wlott 1.1 (vector (array
344 ram 1.6 sequence) (string bit-vector) (array sequence t)
345 ram 1.8 #())
346 ram 1.6 (string (vector) () (vector array sequence t)
347 ram 1.8 "")
348 ram 1.6 (bit-vector (vector) () (vector array sequence t)
349 ram 1.8 #*1)
350 ram 1.6 (character (t) () (t)
351 ram 1.8 #\c)
352 wlott 1.1
353 ram 1.6 (symbol (t) (null) (t)
354 ram 1.8 symbol)
355     (null (symbol
356     list) () (symbol list sequence t)
357     nil)))
358 wlott 1.1
359 pw 1.11 (labels ((direct-supers (class)
360     (if (typep class 'lisp:built-in-class)
361     (kernel:built-in-class-direct-superclasses class)
362     (let ((inherits (kernel:layout-inherits
363     (kernel:class-layout class))))
364     (list (svref inherits (1- (length inherits)))))))
365     (direct-subs (class)
366     (ext:collect ((res))
367     (let ((subs (kernel:class-subclasses class)))
368     (when subs
369     (ext:do-hash (sub v subs)
370     (declare (ignore v))
371     (when (member class (direct-supers sub))
372     (res sub)))))
373     (res))))
374     (ext:collect ((res))
375     (dolist (bic kernel::built-in-classes)
376     (let* ((name (car bic))
377     (class (lisp:find-class name)))
378     (unless (member name '(t kernel:instance kernel:funcallable-instance
379 dtc 1.12 function stream))
380 pw 1.11 (res `(,name
381     ,(mapcar #'lisp:class-name (direct-supers class))
382     ,(mapcar #'lisp:class-name (direct-subs class))
383 pmai 1.23 ,(map 'list (lambda (x)
384     (lisp:class-name (kernel:layout-class x)))
385 pw 1.11 (reverse
386     (kernel:layout-inherits
387     (kernel:class-layout class))))
388     ,(let ((found (assoc name *built-in-classes*)))
389     (if found (fifth found) 42)))))))
390     (setq *built-in-classes* (res))))
391    
392 wlott 1.1
393     ;;;
394     ;;; The classes that define the kernel of the metabraid.
395     ;;;
396     (defclass t () ()
397     (:metaclass built-in-class))
398    
399 pw 1.17 (defclass kernel:instance (t) ()
400     (:metaclass built-in-class))
401 pw 1.11
402 pw 1.17 (defclass function (t) ()
403     (:metaclass built-in-class))
404 dtc 1.12
405 pw 1.17 (defclass kernel:funcallable-instance (function) ()
406     (:metaclass built-in-class))
407    
408 dtc 1.19 (defclass stream (kernel:instance) ()
409 pw 1.17 (:metaclass built-in-class))
410 pw 1.11
411 dtc 1.14 (defclass slot-object (t) ()
412 ram 1.6 (:metaclass slot-class))
413 wlott 1.1
414 pw 1.17 (defclass structure-object (slot-object kernel:instance) ()
415 ram 1.6 (:metaclass structure-class))
416    
417 pw 1.15 (defstruct (dead-beef-structure-object
418 ram 1.6 (:constructor |STRUCTURE-OBJECT class constructor|)))
419    
420 pw 1.11
421 dtc 1.14 (defclass std-object (slot-object) ()
422     (:metaclass std-class))
423    
424 pw 1.17 (defclass standard-object (std-object kernel:instance) ())
425 ram 1.6
426 dtc 1.14 (defclass funcallable-standard-object (std-object
427 pw 1.17 kernel:funcallable-instance)
428 dtc 1.14 ()
429     (:metaclass funcallable-standard-class))
430 wlott 1.1
431 dtc 1.14 (defclass specializer (standard-object)
432 ram 1.6 ((type
433     :initform nil
434     :reader specializer-type)))
435 wlott 1.1
436 dtc 1.14 (defclass definition-source-mixin (std-object)
437 wlott 1.1 ((source
438     :initform (load-truename)
439     :reader definition-source
440 dtc 1.14 :initarg :definition-source))
441     (:metaclass std-class))
442 wlott 1.1
443 dtc 1.14 (defclass plist-mixin (std-object)
444 wlott 1.1 ((plist
445 ram 1.6 :initform ()
446 dtc 1.14 :accessor object-plist))
447     (:metaclass std-class))
448 wlott 1.1
449 ram 1.8 (defclass documentation-mixin (plist-mixin)
450 dtc 1.14 ()
451     (:metaclass std-class))
452 wlott 1.1
453     (defclass dependent-update-mixin (plist-mixin)
454 dtc 1.14 ()
455     (:metaclass std-class))
456 wlott 1.1
457     ;;;
458     ;;; The class CLASS is a specified basic class. It is the common superclass
459 ram 1.8 ;;; of any kind of class. That is any class that can be a metaclass must
460     ;;; have the class CLASS in its class precedence list.
461 wlott 1.1 ;;;
462 ram 1.8 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
463     specializer)
464     ((name
465     :initform nil
466     :initarg :name
467     :accessor class-name)
468     (class-eq-specializer
469 ram 1.6 :initform nil
470 ram 1.8 :reader class-eq-specializer)
471     (direct-superclasses
472     :initform ()
473     :reader class-direct-superclasses)
474 wlott 1.1 (direct-subclasses
475 ram 1.8 :initform ()
476 wlott 1.1 :reader class-direct-subclasses)
477 ram 1.8 (direct-methods
478     :initform (cons nil nil))
479     (predicate-name
480 ram 1.6 :initform nil
481 ram 1.8 :reader class-predicate-name)))
482 wlott 1.1
483     ;;;
484     ;;; The class PCL-CLASS is an implementation-specific common superclass of
485     ;;; all specified subclasses of the class CLASS.
486     ;;;
487     (defclass pcl-class (class)
488 ram 1.8 ((class-precedence-list
489     :reader class-precedence-list)
490 ram 1.6 (can-precede-list
491     :initform ()
492     :reader class-can-precede-list)
493     (incompatible-superclass-list
494     :initform ()
495     :accessor class-incompatible-superclass-list)
496 wlott 1.1 (wrapper
497 ram 1.6 :initform nil
498     :reader class-wrapper)
499 ram 1.8 (prototype
500     :initform nil
501     :reader class-prototype)))
502 wlott 1.1
503 ram 1.6 (defclass slot-class (pcl-class)
504 ram 1.8 ((direct-slots
505     :initform ()
506     :accessor class-direct-slots)
507     (slots
508     :initform ()
509     :accessor class-slots)
510     (initialize-info
511     :initform nil
512     :accessor class-initialize-info)))
513 ram 1.6
514 wlott 1.1 ;;;
515     ;;; The class STD-CLASS is an implementation-specific common superclass of
516     ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
517     ;;;
518 ram 1.6 (defclass std-class (slot-class)
519 ram 1.8 ())
520 wlott 1.1
521     (defclass standard-class (std-class)
522     ())
523    
524     (defclass funcallable-standard-class (std-class)
525     ())
526    
527     (defclass forward-referenced-class (pcl-class) ())
528    
529     (defclass built-in-class (pcl-class) ())
530    
531 ram 1.6 (defclass structure-class (slot-class)
532 ram 1.8 ((defstruct-form
533     :initform ()
534     :accessor class-defstruct-form)
535 ram 1.6 (defstruct-constructor
536     :initform nil
537 ram 1.8 :accessor class-defstruct-constructor)
538 ram 1.6 (from-defclass-p
539     :initform nil
540 ram 1.8 :initarg :from-defclass-p)))
541    
542 ram 1.6
543     (defclass specializer-with-object (specializer) ())
544    
545     (defclass exact-class-specializer (specializer) ())
546    
547     (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
548     ((object :initarg :class :reader specializer-class :reader specializer-object)))
549    
550 ram 1.8 (defclass class-prototype-specializer (specializer-with-object)
551     ((object :initarg :class :reader specializer-class :reader specializer-object)))
552    
553 ram 1.6 (defclass eql-specializer (exact-class-specializer specializer-with-object)
554     ((object :initarg :object :reader specializer-object
555     :reader eql-specializer-object)))
556    
557     (defvar *eql-specializer-table* (make-hash-table :test 'eql))
558    
559     (defun intern-eql-specializer (object)
560     (or (gethash object *eql-specializer-table*)
561     (setf (gethash object *eql-specializer-table*)
562     (make-instance 'eql-specializer :object object))))
563    
564 wlott 1.1
565     ;;;
566     ;;; Slot definitions.
567     ;;;
568 dtc 1.14 (defclass slot-definition (standard-object)
569 wlott 1.1 ((name
570     :initform nil
571 ram 1.6 :initarg :name
572     :accessor slot-definition-name)
573 wlott 1.1 (initform
574 ram 1.6 :initform nil
575     :initarg :initform
576     :accessor slot-definition-initform)
577 wlott 1.1 (initfunction
578 ram 1.6 :initform nil
579     :initarg :initfunction
580     :accessor slot-definition-initfunction)
581 wlott 1.1 (readers
582     :initform nil
583 ram 1.6 :initarg :readers
584     :accessor slot-definition-readers)
585 wlott 1.1 (writers
586     :initform nil
587 ram 1.6 :initarg :writers
588     :accessor slot-definition-writers)
589 wlott 1.1 (initargs
590     :initform nil
591 ram 1.6 :initarg :initargs
592     :accessor slot-definition-initargs)
593 wlott 1.1 (type
594 ram 1.6 :initform t
595     :initarg :type
596     :accessor slot-definition-type)
597 ram 1.8 (documentation
598     :initform ""
599     :initarg :documentation)
600 ram 1.4 (class
601     :initform nil
602 ram 1.6 :initarg :class
603 ram 1.8 :accessor slot-definition-class)))
604 wlott 1.1
605 ram 1.6 (defclass standard-slot-definition (slot-definition)
606     ((allocation
607     :initform :instance
608     :initarg :allocation
609     :accessor slot-definition-allocation)))
610    
611     (defclass structure-slot-definition (slot-definition)
612     ((defstruct-accessor-symbol
613     :initform nil
614     :initarg :defstruct-accessor-symbol
615     :accessor slot-definition-defstruct-accessor-symbol)
616     (internal-reader-function
617     :initform nil
618     :initarg :internal-reader-function
619     :accessor slot-definition-internal-reader-function)
620     (internal-writer-function
621     :initform nil
622     :initarg :internal-writer-function
623     :accessor slot-definition-internal-writer-function)))
624    
625     (defclass direct-slot-definition (slot-definition)
626     ())
627    
628     (defclass effective-slot-definition (slot-definition)
629 pmai 1.23 ((reader-function ; (lambda (object) ...)
630 ram 1.6 :accessor slot-definition-reader-function)
631 pmai 1.23 (writer-function ; (lambda (new-value object) ...)
632 ram 1.6 :accessor slot-definition-writer-function)
633 pmai 1.23 (boundp-function ; (lambda (object) ...)
634 ram 1.6 :accessor slot-definition-boundp-function)
635     (accessor-flags
636 ram 1.8 :initform 0)))
637 ram 1.6
638 wlott 1.1 (defclass standard-direct-slot-definition (standard-slot-definition
639     direct-slot-definition)
640 ram 1.6 ())
641 wlott 1.1
642     (defclass standard-effective-slot-definition (standard-slot-definition
643     effective-slot-definition)
644 ram 1.8 ((location ; nil, a fixnum, a cons: (slot-name . value)
645     :initform nil
646     :accessor slot-definition-location)))
647 wlott 1.1
648 ram 1.6 (defclass structure-direct-slot-definition (structure-slot-definition
649     direct-slot-definition)
650     ())
651 wlott 1.1
652 ram 1.6 (defclass structure-effective-slot-definition (structure-slot-definition
653     effective-slot-definition)
654     ())
655 wlott 1.1
656 dtc 1.14 (defclass method (standard-object) ())
657 ram 1.7
658 ram 1.8 (defclass standard-method (definition-source-mixin plist-mixin method)
659     ((generic-function
660     :initform nil
661     :accessor method-generic-function)
662     ; (qualifiers
663     ; :initform ()
664     ; :initarg :qualifiers
665     ; :reader method-qualifiers)
666     (specializers
667     :initform ()
668     :initarg :specializers
669     :reader method-specializers)
670     (lambda-list
671     :initform ()
672     :initarg :lambda-list
673     :reader method-lambda-list)
674     (function
675     :initform nil
676     :initarg :function) ;no writer
677     (fast-function
678     :initform nil
679     :initarg :fast-function ;no writer
680     :reader method-fast-function)
681     ; (documentation
682     ; :initform nil
683     ; :initarg :documentation
684     ; :reader method-documentation)
685     ))
686 ram 1.7
687 ram 1.8 (defclass standard-accessor-method (standard-method)
688     ((slot-name :initform nil
689     :initarg :slot-name
690     :reader accessor-method-slot-name)
691     (slot-definition :initform nil
692     :initarg :slot-definition
693     :reader accessor-method-slot-definition)))
694 ram 1.7
695 ram 1.8 (defclass standard-reader-method (standard-accessor-method) ())
696 ram 1.7
697 ram 1.8 (defclass standard-writer-method (standard-accessor-method) ())
698 ram 1.7
699 ram 1.8 (defclass standard-boundp-method (standard-accessor-method) ())
700 ram 1.7
701 ram 1.8 (defclass generic-function (dependent-update-mixin
702     definition-source-mixin
703     documentation-mixin
704 dtc 1.14 funcallable-standard-object)
705 ram 1.8 ()
706     (:metaclass funcallable-standard-class))
707    
708     (defclass standard-generic-function (generic-function)
709     ((name
710     :initform nil
711     :initarg :name
712     :accessor generic-function-name)
713     (methods
714     :initform ()
715     :accessor generic-function-methods)
716     (method-class
717     :initarg :method-class
718     :accessor generic-function-method-class)
719     (method-combination
720     :initarg :method-combination
721     :accessor generic-function-method-combination)
722     (arg-info
723     :initform (make-arg-info)
724     :reader gf-arg-info)
725     (dfun-state
726     :initform ()
727     :accessor gf-dfun-state)
728     (pretty-arglist
729     :initform ()
730     :accessor gf-pretty-arglist)
731     )
732     (:metaclass funcallable-standard-class)
733     (:default-initargs :method-class *the-class-standard-method*
734     :method-combination *standard-method-combination*))
735 ram 1.7
736 dtc 1.14 (defclass method-combination (standard-object) ())
737 ram 1.7
738 ram 1.8 (defclass standard-method-combination
739     (definition-source-mixin method-combination)
740     ((type :reader method-combination-type
741     :initarg :type)
742     (documentation :reader method-combination-documentation
743     :initarg :documentation)
744     (options :reader method-combination-options
745     :initarg :options)))
746 ram 1.7
747 ram 1.6 (defparameter *early-class-predicates*
748     '((specializer specializerp)
749     (exact-class-specializer exact-class-specializer-p)
750     (class-eq-specializer class-eq-specializer-p)
751     (eql-specializer eql-specializer-p)
752     (class classp)
753 ram 1.8 (slot-class slot-class-p)
754 dtc 1.14 (std-class std-class-p)
755 ram 1.6 (standard-class standard-class-p)
756     (funcallable-standard-class funcallable-standard-class-p)
757     (structure-class structure-class-p)
758 ram 1.8 (forward-referenced-class forward-referenced-class-p)
759     (method method-p)
760     (standard-method standard-method-p)
761     (standard-accessor-method standard-accessor-method-p)
762     (standard-reader-method standard-reader-method-p)
763     (standard-writer-method standard-writer-method-p)
764     (standard-boundp-method standard-boundp-method-p)
765     (generic-function generic-function-p)
766     (standard-generic-function standard-generic-function-p)
767     (method-combination method-combination-p)))
768 ram 1.7

  ViewVC Help
Powered by ViewVC 1.1.5