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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Wed Oct 23 16:53:45 1991 UTC (22 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.4: +1 -3 lines
Un-commented-out an unused function, to be like the distribution.
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 )
38
39
40 ;;;
41 ;;; Convert a function name to its standard setf function name. We have to
42 ;;; do this hack because not all Common Lisps have yet converted to having
43 ;;; setf function specs.
44 ;;;
45 ;;; In a port that does have setf function specs you can use those just by
46 ;;; making the obvious simple changes to these functions. The rest of PCL
47 ;;; believes that there are function names like (SETF <foo>), this is the
48 ;;; only place that knows about this hack.
49 ;;;
50 (eval-when (compile load eval)
51
52 #-cmu
53 (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
54
55 #-cmu
56 (defun get-setf-function-name (name)
57 (or (gethash name *setf-function-names*)
58 (setf (gethash name *setf-function-names*)
59 (intern (format nil
60 "SETF ~A ~A"
61 (package-name (symbol-package name))
62 (symbol-name name))
63 *the-pcl-package*))))
64
65 ;;;
66 ;;; Call this to define a setf macro for a function with the same behavior as
67 ;;; specified by the SETF function cleanup proposal. Specifically, this will
68 ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
69 ;;;
70 ;;; do-standard-defsetf A macro interface for use at top level
71 ;;; in files. Unfortunately, users may
72 ;;; have to use this for a while.
73 ;;;
74 ;;; do-standard-defsetfs-for-defclass A special version called by defclass.
75 ;;;
76 ;;; do-standard-defsetf-1 A functional interface called by the
77 ;;; above, defmethod and defgeneric.
78 ;;; Since this is all a crock anyways,
79 ;;; users are free to call this as well.
80 ;;;
81 (defmacro do-standard-defsetf (&rest function-names)
82 `(eval-when (compile load eval)
83 (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
84
85 (defun do-standard-defsetfs-for-defclass (accessors)
86 (dolist (name accessors) (do-standard-defsetf-1 name)))
87
88 (defun do-standard-defsetf-1 (function-name)
89 #+cmu
90 (declare (ignore function-name))
91 #-cmu
92 (unless (setfboundp function-name)
93 (let* ((setf-function-name (get-setf-function-name function-name)))
94
95 #+Genera
96 (let ((fn #'(lambda (form)
97 (lt::help-defsetf
98 '(&rest accessor-args) '(new-value) function-name 'nil
99 `(`(,',setf-function-name ,new-value .,accessor-args))
100 form))))
101 (setf (get function-name 'lt::setf-method) fn
102 (get function-name 'lt::setf-method-internal) fn))
103
104 #+Lucid
105 (lucid::set-simple-setf-method
106 function-name
107 #'(lambda (form new-value)
108 (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
109 (cdr form)))
110 (vars (mapcar #'car bindings)))
111 ;; This may wrap spurious LET bindings around some form,
112 ;; but the PQC compiler will unwrap then.
113 `(LET (,.bindings)
114 (,setf-function-name ,new-value . ,vars)))))
115
116 #+kcl
117 (let ((helper (gensym)))
118 (setf (macro-function helper)
119 #'(lambda (form env)
120 (declare (ignore env))
121 (let* ((loc-args (butlast (cdr form)))
122 (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
123 (vars (mapcar #'car bindings)))
124 `(let ,bindings
125 (,setf-function-name ,(car (last form)) ,@vars)))))
126 (eval `(defsetf ,function-name ,helper)))
127 #+Xerox
128 (flet ((setf-expander (body env)
129 (declare (ignore env))
130 (let ((temps
131 (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
132 (cdr body)))
133 (forms (cdr body))
134 (vars (list (gensym))))
135 (values temps
136 forms
137 vars
138 `(,setf-function-name ,@vars ,@temps)
139 `(,function-name ,@temps)))))
140 (let ((setf-method-expander (intern (concatenate 'string
141 (symbol-name function-name)
142 "-setf-expander")
143 (symbol-package function-name))))
144 (setf (get function-name :setf-method-expander) setf-method-expander
145 (symbol-function setf-method-expander) #'setf-expander)))
146
147 #-(or Genera Lucid kcl Xerox)
148 (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
149 `(,',setf-function-name ,new-value ,@accessor-args)))
150
151 )))
152
153 #-cmu
154 (defun setfboundp (symbol)
155 #+Genera (not (null (get-properties (symbol-plist symbol)
156 'lt::(derived-setf-function trivial-setf-method
157 setf-equivalence setf-method))))
158 #+Lucid (locally
159 (declare (special lucid::*setf-inverse-table*
160 lucid::*simple-setf-method-table*
161 lucid::*setf-method-expander-table*))
162 (or (gethash symbol lucid::*setf-inverse-table*)
163 (gethash symbol lucid::*simple-setf-method-table*)
164 (gethash symbol lucid::*setf-method-expander-table*)))
165 #+kcl (or (get symbol 'si::setf-method)
166 (get symbol 'si::setf-update-fn)
167 (get symbol 'si::setf-lambda))
168 #+Xerox (or (get symbol :setf-inverse)
169 (get symbol 'il:setf-inverse)
170 (get symbol 'il:setfn)
171 (get symbol :shared-setf-inverse)
172 (get symbol :setf-method-expander)
173 (get symbol 'il:setf-method-expander))
174
175 #+:coral (or (get symbol 'ccl::setf-inverse)
176 (get symbol 'ccl::setf-method-expander))
177
178 #-(or Genera Lucid KCL Xerox :coral) nil)
179
180 );eval-when
181
182
183 ;;;
184 ;;; PCL, like user code, must endure the fact that we don't have a properly
185 ;;; working setf. Many things work because they get mentioned by a defclass
186 ;;; or defmethod before they are used, but others have to be done by hand.
187 ;;;
188 (do-standard-defsetf
189 class-wrapper ;***
190 generic-function-name
191 method-function-plist
192 method-function-get
193 gdefinition
194 slot-value-using-class
195 )
196
197 (defsetf slot-value set-slot-value)
198
199
200 ;;;
201 ;;; This is like fdefinition on the Lispm. If Common Lisp had something like
202 ;;; function specs I wouldn't need this. On the other hand, I don't like the
203 ;;; way this really works so maybe function specs aren't really right either?
204 ;;;
205 ;;; I also don't understand the real implications of a Lisp-1 on this sort of
206 ;;; thing. Certainly some of the lossage in all of this is because these
207 ;;; SPECs name global definitions.
208 ;;;
209 ;;; Note that this implementation is set up so that an implementation which
210 ;;; has a 'real' function spec mechanism can use that instead and in that way
211 ;;; get rid of setf generic function names.
212 ;;;
213 #-cmu
214 (defmacro parse-gspec (spec
215 (non-setf-var . non-setf-case)
216 (setf-var . setf-case))
217 (declare (indentation 1 1))
218 (once-only (spec)
219 `(cond ((symbolp ,spec)
220 (let ((,non-setf-var ,spec)) ,@non-setf-case))
221 ((and (listp ,spec)
222 (eq (car ,spec) 'setf)
223 (symbolp (cadr ,spec)))
224 (let ((,setf-var (cadr ,spec))) ,@setf-case))
225 (t
226 (error
227 "Can't understand ~S as a generic function specifier.~%~
228 It must be either a symbol which can name a function or~%~
229 a list like ~S, where the car is the symbol ~S and the cadr~%~
230 is a symbol which can name a generic function."
231 ,spec '(setf <foo>) 'setf)))))
232
233 ;;;
234 ;;; If symbol names a function which is traced or advised, return the
235 ;;; unadvised, traced etc. definition. This lets me get at the generic
236 ;;; function object even when it is traced.
237 ;;;
238 (defun unencapsulated-fdefinition (symbol)
239 #+cmu (fdefinition symbol)
240 #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
241 #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
242 #+excl (or (excl::encapsulated-basic-definition symbol)
243 (symbol-function symbol))
244 #+xerox (il:virginfn symbol)
245
246 #-(or cmu Lispm Lucid excl Xerox) (symbol-function symbol))
247
248 ;;;
249 ;;; If symbol names a function which is traced or advised, redefine
250 ;;; the `real' definition without affecting the advise.
251 ;;;
252 (defun fdefine-carefully (symbol new-definition)
253 #+cmu (setf (fdefinition symbol) new-definition)
254 #+Lispm (si:fdefine symbol new-definition t t)
255 #+Lucid (let ((lucid::*redefinition-action* nil))
256 (setf (symbol-function symbol) new-definition))
257 #+excl (setf (symbol-function symbol) new-definition)
258 #+xerox (let ((advisedp (member symbol il:advisedfns :test #'eq))
259 (brokenp (member symbol il:brokenfns :test #'eq)))
260 ;; In XeroxLisp (late of envos) tracing is implemented
261 ;; as a special case of "breaking". Advising, however,
262 ;; is treated specially.
263 (xcl:unadvise-function symbol :no-error t)
264 (xcl:unbreak-function symbol :no-error t)
265 (setf (symbol-function symbol) new-definition)
266 (when brokenp (xcl:rebreak-function symbol))
267 (when advisedp (xcl:readvise-function symbol)))
268
269 #-(or cmu Lispm Lucid excl Xerox)
270 (setf (symbol-function symbol) new-definition)
271
272 new-definition)
273
274 (defun gboundp (spec)
275 #+cmu
276 (fboundp spec)
277 #-cmu
278 (parse-gspec spec
279 (name (fboundp name))
280 (name (fboundp (get-setf-function-name name)))))
281
282 (defun gmakunbound (spec)
283 #+cmu
284 (fmakunbound spec)
285 #-cmu
286 (parse-gspec spec
287 (name (fmakunbound name))
288 (name (fmakunbound (get-setf-function-name name)))))
289
290 (defun gdefinition (spec)
291 #+cmu
292 (fdefinition spec)
293 #-cmu
294 (parse-gspec spec
295 (name (or (macro-function name) ;??
296 (unencapsulated-fdefinition name)))
297 (name (unencapsulated-fdefinition (get-setf-function-name name)))))
298
299 #+cmu
300 (defun (setf gdefinition) (new-value spec)
301 (setf (fdefinition spec) new-value))
302
303 #-cmu
304 (defun SETF\ PCL\ GDEFINITION (new-value spec)
305 (parse-gspec spec
306 (name (fdefine-carefully name new-value))
307 (name (fdefine-carefully (get-setf-function-name name) new-value))))
308
309
310 (defun type-class (type)
311 (if (consp type)
312 (case (car type)
313 (class-eq (cadr type))
314 (eql (class-of (cadr type)))
315 (t (and (null (cdr type)) (find-class (car type) nil))))
316 (if (symbolp type)
317 (find-class type nil)
318 (and (class-specializer-p type)
319 (specializer-class type)))))
320
321 (defun class-type-p (type)
322 (if (consp type)
323 (and (null (cdr type)) (find-class (car type) nil))
324 (if (symbolp type)
325 (find-class type nil)
326 (and (classp type) type))))
327 ;;;;;;
328 (defun exact-class-type-p (type)
329 (if (consp type)
330 (or (eq (car type) 'class-eq) (eq (car type) 'eql))
331 (exact-class-specializer-p type)))
332
333 (defun make-class-eq-predicate (class)
334 (when (symbolp class) (setq class (find-class class)))
335 #'(lambda (object) (eq class (class-of object))))
336
337 (deftype class-eq (class)
338 `(satisfies ,(make-class-eq-predicate class)))
339
340 (defun class-eq-type-p (type)
341 (if (consp type)
342 (eq (car type) 'class-eq)
343 (class-eq-specializer-p type)))
344 ;;;;;;
345 (defun make-eql-predicate (eql-object)
346 #'(lambda (object) (eql eql-object object)))
347
348 (deftype eql (type-object)
349 `(satisfies ,(make-eql-predicate type-object)))
350
351 (defun eql-type-p (type)
352 (if (consp type)
353 (eq (car type) 'eql)
354 (eql-specializer-p type)))
355
356 (defun type-object (type)
357 (if (consp type)
358 (cadr type)
359 (specializer-object type)))
360
361 ;;;;;;
362 (defun not-type-p (type)
363 (and (consp type) (eq (car type) 'not)))
364
365 (defun not-type (type)
366 (cadr type))
367
368 ;;;
369 ;;; These functions are a pale imitiation of their namesake. They accept
370 ;;; class objects or types where they should.
371 ;;;
372 (defun *typep (object type)
373 (let ((specializer (or (class-type-p type)
374 (and (specializerp type) type))))
375 (cond (specializer
376 (specializer-type-p object specializer))
377 ((not-type-p type)
378 (not (*typep object (not-type type))))
379 (t
380 (typep object type)))))
381
382 (defun *subtypep (type1 type2)
383 (let ((c1 (class-type-p type1))
384 (c2 (class-type-p type2)))
385 (cond ((and c1 c2)
386 (values (memq c2 (class-precedence-list c1)) t))
387 ((setq c1 (or c1 (specializerp type1)))
388 (specializer-applicable-using-type-p c1 type2))
389 ((or (null c2) (classp c2))
390 (subtypep type1 (if c2 (class-name c2) type2))))))
391
392 (defun do-satisfies-deftype (name predicate)
393 (let* ((specifier `(satisfies ,predicate))
394 (expand-fn #'(lambda (&rest ignore)
395 (declare (ignore ignore))
396 specifier)))
397 ;; Specific ports can insert their own way of doing this. Many
398 ;; ports may find the expand-fn defined above useful.
399 ;;
400 (or #+:Genera
401 (setf (get name 'deftype) expand-fn)
402 #+(and :Lucid (not :Prime))
403 (system::define-macro `(deftype ,name) expand-fn nil)
404 #+ExCL
405 (setf (get name 'excl::deftype-expander) expand-fn)
406 #+:coral
407 (setf (get name 'ccl::deftype-expander) expand-fn)
408 ;; This is the default for ports for which we don't know any
409 ;; better. Note that for most ports, providing this definition
410 ;; should just speed up class definition. It shouldn't have an
411 ;; effect on performance of most user code.
412 (eval `(deftype ,name () '(satisfies ,predicate))))))
413
414
415 (defun make-type-predicate-name (name)
416 (intern (format nil
417 "TYPE-PREDICATE ~A ~A"
418 (package-name (symbol-package name))
419 (symbol-name name))
420 *the-pcl-package*))
421
422
423
424 (proclaim '(special *the-class-t*
425 *the-class-vector* *the-class-symbol*
426 *the-class-string* *the-class-sequence*
427 *the-class-rational* *the-class-ratio*
428 *the-class-number* *the-class-null* *the-class-list*
429 *the-class-integer* *the-class-float* *the-class-cons*
430 *the-class-complex* *the-class-character*
431 *the-class-bit-vector* *the-class-array*
432
433 *the-class-standard-object*
434 *the-class-class*
435 *the-class-method*
436 *the-class-generic-function*
437 *the-class-standard-class*
438 *the-class-funcallable-standard-class*
439 *the-class-standard-method*
440 *the-class-standard-generic-function*
441 *the-class-standard-effective-slot-definition*
442
443 *the-eslotd-standard-class-slots*
444 *the-eslotd-funcallable-standard-class-slots*))
445
446 (proclaim '(special *the-wrapper-of-t*
447 *the-wrapper-of-vector* *the-wrapper-of-symbol*
448 *the-wrapper-of-string* *the-wrapper-of-sequence*
449 *the-wrapper-of-rational* *the-wrapper-of-ratio*
450 *the-wrapper-of-number* *the-wrapper-of-null*
451 *the-wrapper-of-list* *the-wrapper-of-integer*
452 *the-wrapper-of-float* *the-wrapper-of-cons*
453 *the-wrapper-of-complex* *the-wrapper-of-character*
454 *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
455
456
457
458 (defvar *built-in-class-symbols* ())
459 (defvar *built-in-wrapper-symbols* ())
460
461 (defun get-built-in-class-symbol (class-name)
462 (or (cadr (assq class-name *built-in-class-symbols*))
463 (let ((symbol (intern (format nil
464 "*THE-CLASS-~A*"
465 (symbol-name class-name))
466 *the-pcl-package*)))
467 (push (list class-name symbol) *built-in-class-symbols*)
468 symbol)))
469
470 (defun get-built-in-wrapper-symbol (class-name)
471 (or (cadr (assq class-name *built-in-wrapper-symbols*))
472 (let ((symbol (intern (format nil
473 "*THE-WRAPPER-OF-~A*"
474 (symbol-name class-name))
475 *the-pcl-package*)))
476 (push (list class-name symbol) *built-in-wrapper-symbols*)
477 symbol)))
478
479
480
481
482 (pushnew 'class *variable-declarations*)
483 (pushnew 'variable-rebinding *variable-declarations*)
484
485 (defun variable-class (var env)
486 (caddr (variable-declaration 'class var env)))
487
488
489 (defvar *boot-state* ()) ;NIL
490 ;EARLY
491 ;BRAID
492 ;COMPLETE
493
494 (eval-when (load eval)
495 (when (eq *boot-state* 'complete)
496 (error "Trying to load (or compile) PCL in an environment in which it~%~
497 has already been loaded. This doesn't work, you will have to~%~
498 get a fresh lisp (reboot) and then load PCL."))
499 (when *boot-state*
500 (cerror "Try loading (or compiling) PCL anyways."
501 "Trying to load (or compile) PCL in an environment in which it~%~
502 has already been partially loaded. This may not work, you may~%~
503 need to get a fresh lisp (reboot) and then load PCL."))
504 )
505
506 ;;;
507 ;;; This is used by combined methods to communicate the next methods to
508 ;;; the methods they call. This variable is captured by a lexical variable
509 ;;; of the methods to give it the proper lexical scope.
510 ;;;
511 (defvar *next-methods* nil)
512
513 (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
514
515 (defvar *umi-gfs*)
516 (defvar *umi-complete-classes*)
517 (defvar *umi-reorder*)
518
519 (defvar *invalidate-discriminating-function-force-p* ())
520 (defvar *invalid-dfuns-on-stack* ())
521
522
523 (defvar *standard-method-combination*)
524
525 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
526
527
528 (defmacro define-gf-predicate (predicate &rest classes)
529 `(progn (defmethod ,predicate ((x t)) nil)
530 ,@(mapcar #'(lambda (c) `(defmethod ,predicate ((x ,c)) t))
531 classes)))
532
533 (defmacro plist-value (object name)
534 `(with-slots (plist) ,object (getf plist ,name)))
535
536 (defsetf plist-value (object name) (new-value)
537 (once-only (new-value)
538 `(with-slots (plist) ,object
539 (if ,new-value
540 (setf (getf plist ,name) ,new-value)
541 (progn (remf plist ,name) nil)))))
542
543
544
545 (defvar *built-in-classes*
546 ;;
547 ;; name supers subs cdr of cpl
548 ;;
549 '((number (t) (complex float rational) (t))
550 (complex (number) () (number t))
551 (float (number) () (number t))
552 (rational (number) (integer ratio) (number t))
553 (integer (rational) () (rational number t))
554 (ratio (rational) () (rational number t))
555
556 (sequence (t) (list vector) (t))
557 (list (sequence) (cons null) (sequence t))
558 (cons (list) () (list sequence t))
559
560
561 (array (t) (vector) (t))
562 (vector (array
563 sequence) (string bit-vector) (array sequence t))
564 (string (vector) () (vector array sequence t))
565 (bit-vector (vector) () (vector array sequence t))
566 (character (t) () (t))
567
568 (symbol (t) (null) (t))
569 (null (symbol) () (symbol list sequence t))))
570
571
572 ;;;
573 ;;; The classes that define the kernel of the metabraid.
574 ;;;
575 (defclass t () ()
576 (:metaclass built-in-class))
577
578 (defclass standard-object (t) ())
579
580 (defclass metaobject (standard-object) ())
581
582 (defclass specializer (metaobject) ())
583
584 (defclass class-specializer (specializer) ())
585
586 (defclass definition-source-mixin (standard-object)
587 ((source
588 :initform (load-truename)
589 :reader definition-source
590 :initarg :definition-source)))
591
592 (defclass plist-mixin (standard-object)
593 ((plist
594 :initform ())))
595
596 (defclass documentation-mixin (plist-mixin)
597 ())
598
599 (defclass dependent-update-mixin (plist-mixin)
600 ())
601
602 ;;;
603 ;;; The class CLASS is a specified basic class. It is the common superclass
604 ;;; of any kind of class. That is any class that can be a metaclass must
605 ;;; have the class CLASS in its class precedence list.
606 ;;;
607 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
608 class-specializer)
609 ((name
610 :initform nil
611 :initarg :name
612 :accessor class-name)
613 (direct-superclasses
614 :initform ()
615 :reader class-direct-superclasses)
616 (direct-subclasses
617 :initform ()
618 :reader class-direct-subclasses)
619 (direct-methods
620 :initform (cons nil nil))))
621
622 ;;;
623 ;;; The class PCL-CLASS is an implementation-specific common superclass of
624 ;;; all specified subclasses of the class CLASS.
625 ;;;
626 (defclass pcl-class (class)
627 ((class-precedence-list
628 :initform ())
629 (wrapper
630 :initform nil)))
631
632 ;;;
633 ;;; The class STD-CLASS is an implementation-specific common superclass of
634 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
635 ;;;
636 (defclass std-class (pcl-class)
637 ((direct-slots
638 :initform ()
639 :accessor class-direct-slots)
640 (slots
641 :initform ()
642 :accessor class-slots)
643 (no-of-instance-slots ;*** MOVE TO WRAPPER ***
644 :initform 0
645 :accessor class-no-of-instance-slots)
646 (prototype
647 :initform nil)))
648
649 (defclass standard-class (std-class)
650 ())
651
652 (defclass funcallable-standard-class (std-class)
653 ())
654
655 (defclass forward-referenced-class (pcl-class) ())
656
657 (defclass built-in-class (pcl-class) ())
658
659
660 ;;;
661 ;;; Slot definitions.
662 ;;;
663 ;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".
664 ;;;
665 (defclass slot-definition (metaobject) ())
666
667 (defclass direct-slot-definition (slot-definition) ())
668 (defclass effective-slot-definition (slot-definition) ())
669
670 (defclass standard-slot-definition (slot-definition)
671 ((name
672 :initform nil
673 :accessor slotd-name)
674 (initform
675 :initform *slotd-unsupplied*
676 :accessor slotd-initform)
677 (initfunction
678 :initform *slotd-unsupplied*
679 :accessor slotd-initfunction)
680 (readers
681 :initform nil
682 :accessor slotd-readers)
683 (writers
684 :initform nil
685 :accessor slotd-writers)
686 (initargs
687 :initform nil
688 :accessor slotd-initargs)
689 (allocation
690 :initform nil
691 :accessor slotd-allocation)
692 (type
693 :initform nil
694 :accessor slotd-type)
695 (documentation
696 :initform ""
697 :initarg :documentation)
698 (class
699 :initform nil
700 :accessor slotd-class)
701 (instance-index
702 :initform nil
703 :accessor slotd-instance-index)))
704
705 (defclass standard-direct-slot-definition (standard-slot-definition
706 direct-slot-definition)
707 ()) ;Adding slots here may
708 ;involve extra work to
709 ;the code in braid.lisp
710
711 (defclass standard-effective-slot-definition (standard-slot-definition
712 effective-slot-definition)
713 ()) ;Adding slots here may
714 ;involve extra work to
715 ;the code in braid.lisp
716
717
718
719 (defclass eql-specializer (specializer)
720 ((object :initarg :object :reader specializer-object)))
721
722
723
724 ;;;
725 ;;;
726 ;;;
727 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
728 `(let ((,var nil)
729 (.dolist-carefully. ,list))
730 (loop (when (null .dolist-carefully.) (return nil))
731 (if (consp .dolist-carefully.)
732 (progn
733 (setq ,var (pop .dolist-carefully.))
734 ,@body)
735 (,improper-list-handler)))))
736
737

  ViewVC Help
Powered by ViewVC 1.1.5