X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=323982d5ed5b9b9b201ca8690f6eb3f941a451fb;hb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;hp=a23f10faf60a63603b8f0610532c777e8d7a4680;hpb=7ce2c42adf3d62f03086de940adaee48e6161a40;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index a23f10f..323982d 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -573,6 +573,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)))
 
 ;;;; package idioms
 
@@ -605,10 +626,24 @@
 (defun legal-fun-name-p (name)
   (or (symbolp name)
       (and (consp name)
-           (eq (car name) 'setf)
-           (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)
@@ -619,16 +654,23 @@
 	   :format-control "invalid function name: ~S"
 	   :format-arguments (list name))))
 
-;;; Given a function name, return the name for the BLOCK which
-;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
+;;; Given a function name, return the symbol embedded in it.
+;;;
+;;; The ordinary use for this operator (and the motivation for the
+;;; name of this operator) is to convert from a function name to the
+;;; name of the BLOCK which encloses its body.
+;;;
+;;; Occasionally the operator is useful elsewhere, where the operator
+;;; name is less mnemonic. (Maybe it should be changed?)
 (declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name))
 (defun fun-name-block-name (fun-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))))