\f
;;;; type-ish predicates
-;;; a helper function for various macros which expect clauses of a
-;;; given length, etc.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; Return true if X is a proper list whose length is between MIN and
- ;; MAX (inclusive).
- (defun proper-list-of-length-p (x min &optional (max min))
- ;; FIXME: This implementation will hang on circular list
- ;; structure. Since this is an error-checking utility, i.e. its
- ;; job is to deal with screwed-up input, it'd be good style to fix
- ;; it so that it can deal with circular list structure.
- (cond ((minusp max)
- nil)
- ((null x)
- (zerop min))
- ((consp x)
- (and (plusp max)
- (proper-list-of-length-p (cdr x)
- (if (plusp (1- min))
- (1- min)
- 0)
- (1- max))))
- (t nil))))
-
;;; Is X a list containing a cycle?
(defun cyclic-list-p (x)
(and (listp x)
(defun ,name (&rest args)
(,cached-name args)))))
+;;; FIXME: maybe not the best place
+;;;
+;;; FIXME: think of a better name -- not only does this not have the
+;;; CAR recursion of EQUAL, it also doesn't have the special treatment
+;;; of pathnames, bit-vectors and strings.
+;;;
+;;; KLUDGE: This means that we will no longer cache specifiers of the
+;;; form '(INTEGER (0) 4). This is probably not a disaster.
+;;;
+;;; A helper function for the type system, which is the main user of
+;;; these caches: we must be more conservative than EQUAL for some of
+;;; our equality tests, because MEMBER and friends refer to EQLity.
+;;; So:
+(defun equal-but-no-car-recursion (x y)
+ (cond
+ ((eql x y) t)
+ ((consp x)
+ (and (consp y)
+ (eql (car x) (car y))
+ (equal-but-no-car-recursion (cdr x) (cdr y))))
+ (t nil)))
\f
;;;; package idioms
(defun legal-fun-name-p (name)
(or (symbolp name)
(and (consp name)
- (or (eq (car name) 'setf)
- (eq (car name) 'sb!pcl::class-predicate))
- (consp (cdr name))
- (symbolp (cadr name))
- (null (cddr name)))))
+ ;; (SETF FOO)
+ ;; (CLASS-PREDICATE FOO)
+ (or (and (or (eq (car name) 'setf)
+ (eq (car name) 'sb!pcl::class-predicate))
+ (consp (cdr name))
+ (symbolp (cadr name))
+ (null (cddr name)))
+ ;; (SLOT-ACCESSOR <CLASSNAME-OR-:GLOBAL>
+ ;; <SLOT-NAME> [READER|WRITER|BOUNDP])
+ (and (eq (car name) 'sb!pcl::slot-accessor)
+ (consp (cdr name))
+ (symbolp (cadr name))
+ (consp (cddr name))
+ (symbolp (caddr name))
+ (consp (cdddr name))
+ (member
+ (cadddr name)
+ '(sb!pcl::reader sb!pcl::writer sb!pcl::boundp)))))))
;;; Signal an error unless NAME is a legal function name.
(defun legal-fun-name-or-type-error (name)
(cond ((symbolp fun-name)
fun-name)
((and (consp fun-name)
- (= (length fun-name) 2)
- (eq (first fun-name) 'setf))
- (second fun-name))
+ (legal-fun-name-p fun-name))
+ (case (car fun-name)
+ ((setf sb!pcl::class-predicate) (second fun-name))
+ ((sb!pcl::slot-accessor) (third fun-name))))
(t
(error "not legal as a function name: ~S" fun-name))))