0.pre8.24:

[sbcl.git] / src / code / early-extensions.lisp

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 5163fe1..4522aa2 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -105,29 +105,6 @@
 \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)
@@ -573,6 +550,27 @@
        (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
 
@@ -605,11 +603,24 @@
 (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)
@@ -634,7 +645,9 @@
         fun-name)
        ((and (consp fun-name)
              (legal-fun-name-p fun-name))
-        (second 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))))