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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Nov 27 15:44:30 1990 UTC (23 years, 4 months ago) by ram
Branch: MAIN
Changes since 1.2: +25 -2 lines
Changed stuff to know that we have setf functions.
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 nil
156 #+Lucid (locally
157 (declare (special lucid::*setf-inverse-table*
158 lucid::*simple-setf-method-table*
159 lucid::*setf-method-expander-table*))
160 (or (gethash symbol lucid::*setf-inverse-table*)
161 (gethash symbol lucid::*simple-setf-method-table*)
162 (gethash symbol lucid::*setf-method-expander-table*)))
163 #+kcl (or (get symbol 'si::setf-method)
164 (get symbol 'si::setf-update-fn)
165 (get symbol 'si::setf-lambda))
166 #+Xerox (or (get symbol :setf-inverse)
167 (get symbol 'il:setf-inverse)
168 (get symbol 'il:setfn)
169 (get symbol :shared-setf-inverse)
170 (get symbol :setf-method-expander)
171 (get symbol 'il:setf-method-expander))
172
173 #+:coral (or (get symbol 'ccl::setf-inverse)
174 (get symbol 'ccl::setf-method-expander))
175
176 #-(or Genera Lucid KCL Xerox :coral) nil)
177
178 );eval-when
179
180
181 ;;;
182 ;;; PCL, like user code, must endure the fact that we don't have a properly
183 ;;; working setf. Many things work because they get mentioned by a defclass
184 ;;; or defmethod before they are used, but others have to be done by hand.
185 ;;;
186 (do-standard-defsetf
187 class-wrapper ;***
188 generic-function-name
189 method-function-plist
190 method-function-get
191 gdefinition
192 slot-value-using-class
193 )
194
195 (defsetf slot-value set-slot-value)
196
197
198 ;;;
199 ;;; This is like fdefinition on the Lispm. If Common Lisp had something like
200 ;;; function specs I wouldn't need this. On the other hand, I don't like the
201 ;;; way this really works so maybe function specs aren't really right either?
202 ;;;
203 ;;; I also don't understand the real implications of a Lisp-1 on this sort of
204 ;;; thing. Certainly some of the lossage in all of this is because these
205 ;;; SPECs name global definitions.
206 ;;;
207 ;;; Note that this implementation is set up so that an implementation which
208 ;;; has a 'real' function spec mechanism can use that instead and in that way
209 ;;; get rid of setf generic function names.
210 ;;;
211 #-cmu
212 (defmacro parse-gspec (spec
213 (non-setf-var . non-setf-case)
214 (setf-var . setf-case))
215 (declare (indentation 1 1))
216 (once-only (spec)
217 `(cond ((symbolp ,spec)
218 (let ((,non-setf-var ,spec)) ,@non-setf-case))
219 ((and (listp ,spec)
220 (eq (car ,spec) 'setf)
221 (symbolp (cadr ,spec)))
222 (let ((,setf-var (cadr ,spec))) ,@setf-case))
223 (t
224 (error
225 "Can't understand ~S as a generic function specifier.~%~
226 It must be either a symbol which can name a function or~%~
227 a list like ~S, where the car is the symbol ~S and the cadr~%~
228 is a symbol which can name a generic function."
229 ,spec '(setf <foo>) 'setf)))))
230
231 ;;;
232 ;;; If symbol names a function which is traced or advised, return the
233 ;;; unadvised, traced etc. definition. This lets me get at the generic
234 ;;; function object even when it is traced.
235 ;;;
236 (defun unencapsulated-fdefinition (symbol)
237 #+cmu (fdefinition symbol)
238 #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
239 #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
240 #+excl (or (excl::encapsulated-basic-definition symbol)
241 (symbol-function symbol))
242 #+xerox (il:virginfn symbol)
243
244 #-(or cmu Lispm Lucid excl Xerox) (symbol-function symbol))
245
246 ;;;
247 ;;; If symbol names a function which is traced or advised, redefine
248 ;;; the `real' definition without affecting the advise.
249 ;;;
250 (defun fdefine-carefully (symbol new-definition)
251 #+cmu (setf (fdefinition symbol) new-definition)
252 #+Lispm (si:fdefine symbol new-definition t t)
253 #+Lucid (let ((lucid::*redefinition-action* nil))
254 (setf (symbol-function symbol) new-definition))
255 #+excl (setf (symbol-function symbol) new-definition)
256 #+xerox (let ((advisedp (member symbol il:advisedfns :test #'eq))
257 (brokenp (member symbol il:brokenfns :test #'eq)))
258 ;; In XeroxLisp (late of envos) tracing is implemented
259 ;; as a special case of "breaking". Advising, however,
260 ;; is treated specially.
261 (xcl:unadvise-function symbol :no-error t)
262 (xcl:unbreak-function symbol :no-error t)
263 (setf (symbol-function symbol) new-definition)
264 (when brokenp (xcl:rebreak-function symbol))
265 (when advisedp (xcl:readvise-function symbol)))
266
267 #-(or cmu Lispm Lucid excl Xerox)
268 (setf (symbol-function symbol) new-definition)
269
270 new-definition)
271
272 (defun gboundp (spec)
273 #+cmu
274 (fboundp spec)
275 #-cmu
276 (parse-gspec spec
277 (name (fboundp name))
278 (name (fboundp (get-setf-function-name name)))))
279
280 (defun gmakunbound (spec)
281 #+cmu
282 (fmakunbound spec)
283 #-cmu
284 (parse-gspec spec
285 (name (fmakunbound name))
286 (name (fmakunbound (get-setf-function-name name)))))
287
288 (defun gdefinition (spec)
289 #+cmu
290 (fdefinition spec)
291 #-cmu
292 (parse-gspec spec
293 (name (or (macro-function name) ;??
294 (unencapsulated-fdefinition name)))
295 (name (unencapsulated-fdefinition (get-setf-function-name name)))))
296
297 #+cmu
298 (defun (setf gdefinition) (new-value spec)
299 (setf (fdefinition spec) new-value))
300
301 #-cmu
302 (defun SETF\ PCL\ GDEFINITION (new-value spec)
303 (parse-gspec spec
304 (name (fdefine-carefully name new-value))
305 (name (fdefine-carefully (get-setf-function-name name) new-value))))
306
307
308 ;;;
309 ;;; These functions are a pale imitiation of their namesake. They accept
310 ;;; class objects or types where they should.
311 ;;;
312 (defun *typep (object type)
313 (if (classp type)
314 (let ((class (class-of object)))
315 (if class
316 (memq type (class-precedence-list class))
317 nil))
318 (let ((class (find-class type nil)))
319 (if class
320 (*typep object class)
321 (typep object type)))))
322
323 (defun *subtypep (type1 type2)
324 (let ((c1 (if (classp type1) type1 (find-class type1 nil)))
325 (c2 (if (classp type2) type2 (find-class type2 nil))))
326 (if (and c1 c2)
327 (memq c2 (class-precedence-list c1))
328 (if (or c1 c2)
329 nil ;This isn't quite right, but...
330 (subtypep type1 type2)))))
331
332 (defun do-satisfies-deftype (name predicate)
333 #|
334 (let* ((specifier `(satisfies ,predicate))
335 (expand-fn #'(lambda (&rest ignore)
336 (declare (ignore ignore))
337 specifier)))
338 ;; Specific ports can insert their own way of doing this. Many
339 ;; ports may find the expand-fn defined above useful.
340 ;;
341 (or #+:Genera
342 (setf (get name 'deftype) expand-fn)
343 #+(and :Lucid (not :Prime))
344 (system::define-macro `(deftype ,name) expand-fn nil)
345 #+ExCL
346 (setf (get name 'excl::deftype-expander) expand-fn)
347 #+:coral
348 (setf (get name 'ccl::deftype-expander) expand-fn)
349 |#
350 ;; This is the default for ports for which we don't know any
351 ;; better. Note that for most ports, providing this definition
352 ;; should just speed up class definition. It shouldn't have an
353 ;; effect on performance of most user code.
354 (eval `(deftype ,name () '(satisfies ,predicate))))
355
356
357 (defun make-type-predicate-name (name)
358 (intern (format nil
359 "TYPE-PREDICATE ~A ~A"
360 (package-name (symbol-package name))
361 (symbol-name name))
362 *the-pcl-package*))
363
364
365
366 (proclaim '(special *the-class-t*
367 *the-class-vector* *the-class-symbol*
368 *the-class-string* *the-class-sequence*
369 *the-class-rational* *the-class-ratio*
370 *the-class-number* *the-class-null* *the-class-list*
371 *the-class-integer* *the-class-float* *the-class-cons*
372 *the-class-complex* *the-class-character*
373 *the-class-bit-vector* *the-class-array*
374
375 *the-class-standard-object*
376 *the-class-class*
377 *the-class-method*
378 *the-class-generic-function*
379 *the-class-standard-class*
380 *the-class-standard-method*
381 *the-class-standard-generic-function*))
382
383 (proclaim '(special *the-wrapper-of-t*
384 *the-wrapper-of-vector* *the-wrapper-of-symbol*
385 *the-wrapper-of-string* *the-wrapper-of-sequence*
386 *the-wrapper-of-rational* *the-wrapper-of-ratio*
387 *the-wrapper-of-number* *the-wrapper-of-null*
388 *the-wrapper-of-list* *the-wrapper-of-integer*
389 *the-wrapper-of-float* *the-wrapper-of-cons*
390 *the-wrapper-of-complex* *the-wrapper-of-character*
391 *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
392
393
394
395 (defvar *built-in-class-symbols* ())
396 (defvar *built-in-wrapper-symbols* ())
397
398 (defun get-built-in-class-symbol (class-name)
399 (or (cadr (assq class-name *built-in-class-symbols*))
400 (let ((symbol (intern (format nil
401 "*THE-CLASS-~A*"
402 (symbol-name class-name))
403 *the-pcl-package*)))
404 (push (list class-name symbol) *built-in-class-symbols*)
405 symbol)))
406
407 (defun get-built-in-wrapper-symbol (class-name)
408 (or (cadr (assq class-name *built-in-wrapper-symbols*))
409 (let ((symbol (intern (format nil
410 "*THE-WRAPPER-OF-~A*"
411 (symbol-name class-name))
412 *the-pcl-package*)))
413 (push (list class-name symbol) *built-in-wrapper-symbols*)
414 symbol)))
415
416
417
418
419 (pushnew 'class *variable-declarations*)
420 (pushnew 'variable-rebinding *variable-declarations*)
421
422 (defun variable-class (var env)
423 (caddr (variable-declaration 'class var env)))
424
425
426 (defvar *boot-state* ()) ;NIL
427 ;EARLY
428 ;BRAID
429 ;COMPLETE
430
431 (eval-when (load eval)
432 (when (eq *boot-state* 'complete)
433 (error "Trying to load (or compile) PCL in an environment in which it~%~
434 has already been loaded. This doesn't work, you will have to~%~
435 get a fresh lisp (reboot) and then load PCL."))
436 (when *boot-state*
437 (cerror "Try loading (or compiling) PCL anyways."
438 "Trying to load (or compile) PCL in an environment in which it~%~
439 has already been partially loaded. This may not work, you may~%~
440 need to get a fresh lisp (reboot) and then load PCL."))
441 )
442
443 ;;;
444 ;;; This is used by combined methods to communicate the next methods to
445 ;;; the methods they call. This variable is captured by a lexical variable
446 ;;; of the methods to give it the proper lexical scope.
447 ;;;
448 (defvar *next-methods* nil)
449
450 (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
451
452 (defvar *umi-gfs*)
453 (defvar *umi-complete-classes*)
454 (defvar *umi-reorder*)
455
456 (defvar *invalidate-discriminating-function-force-p* ())
457 (defvar *invalid-dfuns-on-stack* ())
458
459
460 (defvar *standard-method-combination*)
461
462 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
463
464
465 (defmacro define-gf-predicate (predicate &rest classes)
466 `(progn (defmethod ,predicate ((x t)) nil)
467 ,@(mapcar #'(lambda (c) `(defmethod ,predicate ((x ,c)) t))
468 classes)))
469
470 (defmacro plist-value (object name)
471 `(with-slots (plist) ,object (getf plist ,name)))
472
473 (defsetf plist-value (object name) (new-value)
474 (once-only (new-value)
475 `(with-slots (plist) ,object
476 (if ,new-value
477 (setf (getf plist ,name) ,new-value)
478 (progn (remf plist ,name) nil)))))
479
480
481
482 (defvar *built-in-classes*
483 ;;
484 ;; name supers subs cdr of cpl
485 ;;
486 '((number (t) (complex float rational) (t))
487 (complex (number) () (number t))
488 (float (number) () (number t))
489 (rational (number) (integer ratio) (number t))
490 (integer (rational) () (rational number t))
491 (ratio (rational) () (rational number t))
492
493 (sequence (t) (list vector) (t))
494 (list (sequence) (cons null) (sequence t))
495 (cons (list) () (list sequence t))
496
497
498 (array (t) (vector) (t))
499 (vector (array
500 sequence) (string bit-vector) (array sequence t))
501 (string (vector) () (vector array sequence t))
502 (bit-vector (vector) () (vector array sequence t))
503 (character (t) () (t))
504
505 (symbol (t) (null) (t))
506 (null (symbol) () (symbol list sequence t))))
507
508
509 ;;;
510 ;;; The classes that define the kernel of the metabraid.
511 ;;;
512 (defclass t () ()
513 (:metaclass built-in-class))
514
515 (defclass standard-object (t) ())
516
517 (defclass metaobject (standard-object) ())
518
519 (defclass specializer (metaobject) ())
520
521 (defclass definition-source-mixin (standard-object)
522 ((source
523 :initform (load-truename)
524 :reader definition-source
525 :initarg :definition-source)))
526
527 (defclass plist-mixin (standard-object)
528 ((plist
529 :initform ())))
530
531 (defclass documentation-mixin (plist-mixin)
532 ())
533
534 (defclass dependent-update-mixin (plist-mixin)
535 ())
536
537 ;;;
538 ;;; The class CLASS is a specified basic class. It is the common superclass
539 ;;; of any kind of class. That is any class that can be a metaclass must
540 ;;; have the class CLASS in its class precedence list.
541 ;;;
542 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
543 specializer)
544 ((name
545 :initform nil
546 :initarg :name
547 :accessor class-name)
548 (direct-superclasses
549 :initform ()
550 :reader class-direct-superclasses)
551 (direct-subclasses
552 :initform ()
553 :reader class-direct-subclasses)
554 (direct-methods
555 :initform (cons nil nil))))
556
557 ;;;
558 ;;; The class PCL-CLASS is an implementation-specific common superclass of
559 ;;; all specified subclasses of the class CLASS.
560 ;;;
561 (defclass pcl-class (class)
562 ((class-precedence-list
563 :initform ())
564 (wrapper
565 :initform nil)))
566
567 ;;;
568 ;;; The class STD-CLASS is an implementation-specific common superclass of
569 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
570 ;;;
571 (defclass std-class (pcl-class)
572 ((direct-slots
573 :initform ()
574 :accessor class-direct-slots)
575 (slots
576 :initform ()
577 :accessor class-slots)
578 (no-of-instance-slots ;*** MOVE TO WRAPPER ***
579 :initform 0
580 :accessor class-no-of-instance-slots)
581 (prototype
582 :initform nil)))
583
584 (defclass standard-class (std-class)
585 ())
586
587 (defclass funcallable-standard-class (std-class)
588 ())
589
590 (defclass forward-referenced-class (pcl-class) ())
591
592 (defclass built-in-class (pcl-class) ())
593
594
595 ;;;
596 ;;; Slot definitions.
597 ;;;
598 ;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".
599 ;;;
600 (defclass slot-definition (metaobject) ())
601
602 (defclass direct-slot-definition (slot-definition) ())
603 (defclass effective-slot-definition (slot-definition) ())
604
605 (defclass standard-slot-definition (slot-definition)
606 ((name
607 :initform nil
608 :accessor slotd-name)
609 (initform
610 :initform *slotd-unsupplied*
611 :accessor slotd-initform)
612 (initfunction
613 :initform *slotd-unsupplied*
614 :accessor slotd-initfunction)
615 (readers
616 :initform nil
617 :accessor slotd-readers)
618 (writers
619 :initform nil
620 :accessor slotd-writers)
621 (initargs
622 :initform nil
623 :accessor slotd-initargs)
624 (allocation
625 :initform nil
626 :accessor slotd-allocation)
627 (type
628 :initform nil
629 :accessor slotd-type)
630 (documentation
631 :initform ""
632 :initarg :documentation)))
633
634 (defclass standard-direct-slot-definition (standard-slot-definition
635 direct-slot-definition)
636 ()) ;Adding slots here may
637 ;involve extra work to
638 ;the code in braid.lisp
639
640 (defclass standard-effective-slot-definition (standard-slot-definition
641 effective-slot-definition)
642 ()) ;Adding slots here may
643 ;involve extra work to
644 ;the code in braid.lisp
645
646
647
648 (defclass eql-specializer (specializer)
649 ((object :initarg :object :reader eql-specializer-object)))
650
651
652
653 ;;;
654 ;;;
655 ;;;
656 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
657 `(let ((,var nil)
658 (.dolist-carefully. ,list))
659 (loop (when (null .dolist-carefully.) (return nil))
660 (if (consp .dolist-carefully.)
661 (progn
662 (setq ,var (pop .dolist-carefully.))
663 ,@body)
664 (,improper-list-handler)))))
665
666 (defun legal-std-documentation-p (x)
667 (if (or (null x) (stringp x))
668 t
669 "a string or NULL"))
670
671 (defun legal-std-lambda-list-p (x)
672 (declare (ignore x))
673 t)
674
675 (defun legal-std-method-function-p (x)
676 (if (functionp x)
677 t
678 "a function"))
679
680 (defun legal-std-qualifiers-p (x)
681 (flet ((improper-list ()
682 (return-from legal-std-qualifiers-p "Is not a proper list.")))
683 (dolist-carefully (q x improper-list)
684 (let ((ok (legal-std-qualifier-p q)))
685 (unless (eq ok t)
686 (return-from legal-std-qualifiers-p
687 (format nil "Contains ~S which ~A" q ok)))))
688 t))
689
690 (defun legal-std-qualifier-p (x)
691 (if (and x (atom x))
692 t
693 "is not a non-null atom"))
694
695 (defun legal-std-slot-name-p (x)
696 (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
697 ((keywordp x) "is a keyword and so cannot be bound")
698 ((memq x '(t nil)) "cannot be bound")
699 (t t)))
700
701 (defun legal-std-specializers-p (x)
702 (flet ((improper-list ()
703 (return-from legal-std-specializers-p "Is not a proper list.")))
704 (dolist-carefully (s x improper-list)
705 (let ((ok (legal-std-specializer-p s)))
706 (unless (eq ok t)
707 (return-from legal-std-specializers-p
708 (format nil "Contains ~S which ~A" s ok)))))
709 t))
710
711 (defun legal-std-specializer-p (x)
712 (if (or (classp x)
713 (eql-specializer-p x))
714 t
715 "is neither a class object nor an eql specializer"))

  ViewVC Help
Powered by ViewVC 1.1.5