X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=481a83dfcda537095ebdfe83b98ac981f5cc6f81;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=c342e862ddfbbbfff11fa6ee7f4089664d38f134;hpb=e38cf29945f9ff0cfbf614c0c216be60e2515175;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index c342e86..481a83d 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -105,29 +105,6 @@
 
 ;;;; 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)
@@ -184,7 +161,7 @@
 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
 ;;; is the pointer to the current tail of the list, or NIL if the list
 ;;; is empty.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun collect-normal-expander (n-value fun forms)
     `(progn
        ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
@@ -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)))
 
 ;;;; package idioms
 
@@ -603,13 +601,7 @@
 
 ;;; Is NAME a legal function name?
 (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)))))
+  (values (valid-function-name-p name)))
 
 ;;; Signal an error unless NAME is a legal function name.
 (defun legal-fun-name-or-type-error (name)
@@ -632,10 +624,12 @@
 (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))
+	((consp fun-name)
+	 (multiple-value-bind (legalp block-name)
+	     (valid-function-name-p fun-name)
+	   (if legalp
+	       block-name
+	       (error "not legal as a function name: ~S" fun-name))))
 	(t
 	 (error "not legal as a function name: ~S" fun-name))))
 
@@ -797,12 +791,6 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
 	 :format-string "~@<~S ~_is not a ~_~S~:>"
 	 :format-arguments (list value type)))
 
-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
-  (loop repeat n collect (gensym)))
-
 ;;; Return a function like FUN, but expecting its (two) arguments in
 ;;; the opposite order that FUN does.
 (declaim (inline swapped-args-fun))
@@ -904,6 +892,15 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
 
 ;;;; utilities for two-VALUES predicates
 
+(defmacro and/type (x y)
+  `(multiple-value-bind (val1 win1) ,x
+     (if (and (not val1) win1)
+         (values nil t)
+         (multiple-value-bind (val2 win2) ,y
+           (if (and val1 val2)
+               (values t t)
+               (values nil (and win2 (not val2))))))))
+
 ;;; sort of like ANY and EVERY, except:
 ;;;   * We handle two-VALUES predicate functions, as SUBTYPEP does.
 ;;;     (And if the result is uncertain, then we return (VALUES NIL NIL),