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

Contents of /src/pcl/defs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5