X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftypedefs.lisp;h=5695daf35daeb15da10c27c776aae8949a1f4199;hb=0979026ea99240e9a5cdda0b5580bbdc8f7b00d7;hp=b1602716bb721c6cca361eb8ec1405e2e82ca2b3;hpb=77360ee4a1f94c41b807be7ad0e8687199fceef1;p=sbcl.git

diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp
index b160271..5695daf 100644
--- a/src/code/typedefs.lisp
+++ b/src/code/typedefs.lisp
@@ -91,43 +91,38 @@
 
 ;;;; utilities
 
-;;; Like ANY and EVERY, except that we handle two-arg uncertain predicates.
-;;; If the result is uncertain, then we return Default from the block PUNT.
-;;; If LIST-FIRST is true, then the list element is the first arg, otherwise
-;;; the second.
-(defmacro any-type-op (op thing list &key (default '(values nil nil))
-			  list-first)
-  (let ((n-this (gensym))
-	(n-thing (gensym))
-	(n-val (gensym))
-	(n-win (gensym))
-	(n-uncertain (gensym)))
-    `(let ((,n-thing ,thing)
-	   (,n-uncertain nil))
-       (dolist (,n-this ,list
-			(if ,n-uncertain
-			    (return-from PUNT ,default)
-			    nil))
-	 (multiple-value-bind (,n-val ,n-win)
-	     ,(if list-first
-		  `(,op ,n-this ,n-thing)
-		`(,op ,n-thing ,n-this))
-	   (unless ,n-win (setq ,n-uncertain t))
-	   (when ,n-val (return t)))))))
-(defmacro every-type-op (op thing list &key (default '(values nil nil))
-			    list-first)
-  (let ((n-this (gensym))
-	(n-thing (gensym))
-	(n-val (gensym))
-	(n-win (gensym)))
-    `(let ((,n-thing ,thing))
-       (dolist (,n-this ,list t)
-	 (multiple-value-bind (,n-val ,n-win)
-	     ,(if list-first
-		  `(,op ,n-this ,n-thing)
-		`(,op ,n-thing ,n-this))
-	   (unless ,n-win (return-from PUNT ,default))
-	   (unless ,n-val (return nil)))))))
+;;; sort of like ANY and EVERY, except:
+;;;   * We handle two-VALUES predicate functions like SUBTYPEP. (And
+;;;     if the result is uncertain, then we return (VALUES NIL NIL).)
+;;;   * THING is just an atom, and we apply OP (an arity-2 function)
+;;;     successively to THING and each element of LIST.
+(defun any/type (op thing list)
+  (declare (type function op))
+  (let ((certain? t))
+    (dolist (i list (values nil certain?))
+      (multiple-value-bind (sub-value sub-certain?)
+	  (funcall op thing i)
+	(unless sub-certain? (setf certain? nil))
+	(when sub-value (return (values t t)))))))
+(defun every/type (op thing list)
+  (declare (type function op))
+  (dolist (i list (values t t))
+    (multiple-value-bind (sub-value sub-certain?)
+	(funcall op thing i)
+      (unless sub-certain? (return (values nil nil)))
+      (unless sub-value (return (values nil t))))))
+
+;;; Return a function like FUN, but expecting its (two) arguments in
+;;; the opposite order that FUN does.
+;;;
+;;; (This looks like a sort of general utility, but currently it's
+;;; used only in the implementation of the type system, so it's
+;;; internal to SB-KERNEL. -- WHN 2001-02-13)
+(declaim (inline swapped-args-fun))
+(defun swapped-args-fun (fun)
+  (declare (type function fun))
+  (lambda (x y)
+    (funcall fun y x)))
 
 ;;; Compute the intersection for types that intersect only when one is a
 ;;; hierarchical subtype of the other.