From 6fb53d9d9e249ce9b839833833bee90ae8245f22 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Fri, 3 Apr 1998 03:45:39 +0000
Subject: [PATCH] Fix the handling of the :key keyword argument for many of the
 list functions which did not handle a :key of Nil. Noted by Paul Dietz.

---
 code/list.lisp | 290 ++++++++++++++++++++++++++-----------------------
 code/seq.lisp  |   4 +-
 2 files changed, 156 insertions(+), 138 deletions(-)

diff --git a/code/list.lisp b/code/list.lisp
index 47300632b..b91a0b234 100644
--- a/code/list.lisp
+++ b/code/list.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.20 1997/08/06 11:55:30 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.21 1998/04/03 03:45:39 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -421,6 +421,56 @@
       (rplaca list newval)
       (return newval))))
 
+
+;;;; :key arg optimization to save funcall of IDENTITY.
+
+;;; APPLY-KEY saves us a function call sometimes.
+;;;    This is not in and (eval-when (compile eval) ...
+;;;    because this is used in seq.lisp and sort.lisp.
+;;;
+(defmacro apply-key (key element)
+  `(if ,key
+       (funcall ,key ,element)
+       ,element))
+
+(defun identity (thing)
+  "Returns what was passed to it."
+  thing)
+
+
+(defun complement (function)
+  "Builds a new function that returns T whenever FUNCTION returns NIL and
+   NIL whenever FUNCTION returns T."
+  #'(lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
+		       &rest more-args)
+      (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
+		 (arg2-p (funcall function arg0 arg1 arg2))
+		 (arg1-p (funcall function arg0 arg1))
+		 (arg0-p (funcall function arg0))
+		 (t (funcall function))))))
+
+
+(defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p)
+			 &rest more-values)
+  "Builds a function that always returns VALUE, and posisbly MORE-VALUES."
+  (cond (more-values
+	 (let ((list (list* value val1 val2 more-values)))
+	   #'(lambda ()
+	       (declare (ext:optimize-interface (speed 3) (safety 0)))
+	       (values-list list))))
+	(val2-p
+	 #'(lambda ()
+	     (declare (ext:optimize-interface (speed 3) (safety 0)))
+	     (values value val1 val2)))
+	(val1-p
+	 #'(lambda ()
+	     (declare (ext:optimize-interface (speed 3) (safety 0)))
+	     (values value val1)))
+	(t
+	 #'(lambda ()
+	     (declare (ext:optimize-interface (speed 3) (safety 0)))
+	     value))))
+
 
 ;;;; Macros for (&key (key #'identity) (test #'eql testp) (test-not nil notp)).
 ;;; Use these with the following keyword args:
@@ -431,19 +481,18 @@
 	 (t ,(append funcall '(:key key :test test)))))
 
 (defmacro satisfies-the-test (item elt)
-  `(cond (testp
-	  (funcall test ,item (funcall key ,elt)))
-	 (notp
-	  (not (funcall test-not ,item (funcall key ,elt))))
-	 (t (funcall test ,item (funcall key ,elt)))))
+  (let ((key-tmp (gensym)))
+    `(let ((,key-tmp (apply-key key ,elt)))
+      (cond (testp (funcall test ,item ,key-tmp))
+	    (notp (not (funcall test-not ,item ,key-tmp)))
+	    (t (funcall test ,item ,key-tmp))))))
 
 
 ;;; Substitution of expressions
 
 
 
-(defun subst (new old tree &key (key #'identity)
-		  (test #'eql testp) (test-not nil notp))
+(defun subst (new old tree &key key (test #'eql testp) (test-not nil notp))
   "Substitutes new for subtrees matching old."
   (labels ((s (subtree)
 	      (cond ((satisfies-the-test old subtree) new)
@@ -456,10 +505,10 @@
 			     (cons car cdr)))))))
     (s tree)))
 
-(defun subst-if (new test tree &key (key #'identity))
+(defun subst-if (new test tree &key key)
   "Substitutes new for subtrees for which test is true."
   (labels ((s (subtree)
-	      (cond ((funcall test (funcall key subtree)) new)
+	      (cond ((funcall test (apply-key key subtree)) new)
 		    ((atom subtree) subtree)
 		    (t (let ((car (s (car subtree)))
 			     (cdr (s (cdr subtree))))
@@ -469,10 +518,10 @@
 			     (cons car cdr)))))))
     (s tree)))
 
-(defun subst-if-not (new test tree &key (key #'identity))
+(defun subst-if-not (new test tree &key key)
   "Substitutes new for subtrees for which test is false."
   (labels ((s (subtree)
-	      (cond ((not (funcall test (funcall key subtree))) new)
+	      (cond ((not (funcall test (apply-key key subtree))) new)
 		    ((atom subtree) subtree)
 		    (t (let ((car (s (car subtree)))
 			     (cdr (s (cdr subtree))))
@@ -482,8 +531,7 @@
 			     (cons car cdr)))))))
     (s tree)))
 
-(defun nsubst (new old tree &key (key #'identity)
-		  (test #'eql testp) (test-not nil notp))
+(defun nsubst (new old tree &key key (test #'eql testp) (test-not nil notp))
   "Substitutes new for subtrees matching old."
   (labels ((s (subtree)
 	      (cond ((satisfies-the-test old subtree) new)
@@ -499,33 +547,33 @@
 		       subtree))))
     (s tree)))
 
-(defun nsubst-if (new test tree &key (key #'identity))
+(defun nsubst-if (new test tree &key key)
   "Substitutes new for subtrees of tree for which test is true."
   (labels ((s (subtree)
-	      (cond ((funcall test (funcall key subtree)) new)
+	      (cond ((funcall test (apply-key key subtree)) new)
 		    ((atom subtree) subtree)
 		    (t (do* ((last nil subtree)
 			     (subtree subtree (Cdr subtree)))
 			    ((atom subtree)
-			     (if (funcall test (funcall key subtree))
+			     (if (funcall test (apply-key key subtree))
 				 (setf (cdr last) new)))
-			 (if (funcall test (funcall key subtree))
+			 (if (funcall test (apply-key key subtree))
 			     (return (setf (cdr last) new))
 			     (setf (car subtree) (s (car subtree)))))
 		       subtree))))
     (s tree)))
 
-(defun nsubst-if-not (new test tree &key (key #'identity))
+(defun nsubst-if-not (new test tree &key key)
   "Substitutes new for subtrees of tree for which test is false."
   (labels ((s (subtree)
-	      (cond ((not (funcall test (funcall key subtree))) new)
+	      (cond ((not (funcall test (apply-key key subtree))) new)
 		    ((atom subtree) subtree)
 		    (t (do* ((last nil subtree)
 			     (subtree subtree (Cdr subtree)))
 			    ((atom subtree)
-			     (if (not (funcall test (funcall key subtree)))
+			     (if (not (funcall test (apply-key key subtree)))
 				 (setf (cdr last) new)))
-			 (if (not (funcall test (funcall key subtree)))
+			 (if (not (funcall test (apply-key key subtree)))
 			     (return (setf (cdr last) new))
 			     (setf (car subtree) (s (car subtree)))))
 		       subtree))))
@@ -534,15 +582,14 @@
 
 
 
-(defun sublis (alist tree &key (key #'identity)
-		     (test #'eql) (test-not nil notp))
+(defun sublis (alist tree &key key (test #'eql) (test-not nil notp))
   "Substitutes from alist into tree nondestructively."
   (declare (inline assoc))
   (labels ((s (subtree)
-	     (let ((assoc
-		    (if notp
-			(assoc (funcall key subtree) alist :test-not test-not)
-			(assoc (funcall key subtree) alist :test test))))
+	     (let* ((key-val (apply-key key subtree))
+		    (assoc (if notp
+			       (assoc key-val alist :test-not test-not)
+			       (assoc key-val alist :test test))))
 	       (cond (assoc (cdr assoc))
 		     ((atom subtree) subtree)
 		     (t (let ((car (s (car subtree)))
@@ -555,12 +602,13 @@
 
 ;;; In run-time env, since can be referenced in line expansions.
 (defmacro nsublis-macro ()
-  '(if notp
-       (assoc (funcall key subtree) alist :test-not test-not)
-       (assoc (funcall key subtree) alist :test test)))
+  (let ((key-tmp (gensym)))
+    `(let ((,key-tmp (apply-key key subtree)))
+      (if notp
+	  (assoc ,key-tmp alist :test-not test-not)
+	  (assoc ,key-tmp alist :test test)))))
 
-(defun nsublis (alist tree &key (key #'identity)
-		  (test #'eql) (test-not nil notp))
+(defun nsublis (alist tree &key key (test #'eql) (test-not nil notp))
   "Substitutes new for subtrees matching old."
   (declare (inline assoc))
   (let (temp)
@@ -582,8 +630,7 @@
 
 ;;;; Functions for using lists as sets
 
-(defun member (item list &key (key #'identity) (test #'eql testp)
-		    (test-not nil notp))
+(defun member (item list &key key (test #'eql testp) (test-not nil notp))
   "Returns tail of list beginning with first element satisfying EQLity,
    :test, or :test-not with a given item."
   (do ((list list (cdr list)))
@@ -592,18 +639,18 @@
       (if (satisfies-the-test item car)
 	  (return list)))))
 
-(defun member-if (test list &key (key #'identity))
+(defun member-if (test list &key key)
   "Returns tail of list beginning with first element satisfying test(element)"
   (do ((list list (Cdr list)))
       ((endp list) nil)
-    (if (funcall test (funcall key (car list)))
+    (if (funcall test (apply-key key (car list)))
 	(return list))))
 
-(defun member-if-not (test list &key (key #'identity))
+(defun member-if-not (test list &key key)
   "Returns tail of list beginning with first element not satisfying test(el)"
   (do ((list list (cdr list)))
       ((endp list) ())
-    (if (not (funcall test (funcall key (car list))))
+    (if (not (funcall test (apply-key key (car list))))
 	(return list))))
 
 (defun tailp (sublist list)
@@ -614,12 +661,13 @@
     (if (eql sublist list)
 	(return t))))
 
-(defun adjoin (item list &key (key #'identity) (test #'eql)
-		    (test-not nil notp))
+(defun adjoin (item list &key key (test #'eql) (test-not nil notp))
   "Add item to list unless it is already a member"
   (declare (inline member))
-  (if (if notp (member (funcall key item) list :test-not test-not :key key)
-	  (member (funcall key item) list :test test :key key))
+  (if (let ((key-val (apply-key key item)))
+	(if notp
+	    (member key-val list :test-not test-not :key key)
+	    (member key-val list :test test :key key)))
       list
       (cons item list)))
 
@@ -631,14 +679,13 @@
 ;;; will apply the test to the elements from list1 and list2 in the correct
 ;;; order.
 ;;;
-(defun union (list1 list2 &key
-		    (key #'identity) (test #'eql testp) (test-not nil notp))
+(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   "Returns the union of list1 and list2."
   (declare (inline member))
   (when (and testp notp) (error "Test and test-not both supplied."))
   (let ((res list2))
     (dolist (elt list1)
-      (unless (with-set-keys (member (funcall key elt) list2))
+      (unless (with-set-keys (member (apply-key key elt) list2))
 	(push elt res)))
     res))
 
@@ -651,8 +698,7 @@
 	   (cdr temp) ,destination
 	   ,destination temp)))
 
-(defun nunion (list1 list2 &key (key #'identity)
-		     (test #'eql testp) (test-not nil notp))
+(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   "Destructively returns the union list1 and list2."
   (declare (inline member))
   (if (and testp notp)
@@ -661,26 +707,26 @@
 	(list1 list1))
     (do ()
 	((endp list1))
-      (if (not (with-set-keys (member (funcall key (car list1)) list2)))
+      (if (not (with-set-keys (member (apply-key key (car list1)) list2)))
 	  (steve-splice list1 res)
 	  (setf list1 (cdr list1))))
     res))
   
 
-(defun intersection (list1 list2  &key (key #'identity)
-			       (test #'eql testp) (test-not nil notp))
+(defun intersection (list1 list2 &key key
+			   (test #'eql testp) (test-not nil notp))
   "Returns the intersection of list1 and list2."
   (declare (inline member))
   (if (and testp notp)
       (error "Test and test-not both supplied."))
   (let ((res nil))
     (dolist (elt list1)
-      (if (with-set-keys (member (funcall key elt) list2))
+      (if (with-set-keys (member (apply-key key elt) list2))
 	  (push elt res)))
     res))
 
-(defun nintersection (list1 list2 &key (key #'identity)
-		     (test #'eql testp) (test-not nil notp))
+(defun nintersection (list1 list2 &key key
+			    (test #'eql testp) (test-not nil notp))
   "Destructively returns the intersection of list1 and list2."
   (declare (inline member))
   (if (and testp notp)
@@ -688,12 +734,12 @@
   (let ((res nil)
 	(list1 list1))
     (do () ((endp list1))
-      (if (with-set-keys (member (funcall key (car list1)) list2))
+      (if (with-set-keys (member (apply-key key (car list1)) list2))
 	  (steve-splice list1 res)
 	  (setq list1 (Cdr list1))))
     res))
 
-(defun set-difference (list1 list2 &key (key #'identity)
+(defun set-difference (list1 list2 &key key
 			     (test #'eql testp) (test-not nil notp))
   "Returns the elements of list1 which are not in list2."
   (declare (inline member))
@@ -703,12 +749,12 @@
       list1
       (let ((res nil))
 	(dolist (elt list1)
-	  (if (not (with-set-keys (member (funcall key elt) list2)))
+	  (if (not (with-set-keys (member (apply-key key elt) list2)))
 	      (push elt res)))
 	res)))
 
 
-(defun nset-difference (list1 list2 &key (key #'identity)
+(defun nset-difference (list1 list2 &key key
 			      (test #'eql testp) (test-not nil notp))
   "Destructively returns the elements of list1 which are not in list2."
   (declare (inline member))
@@ -717,22 +763,22 @@
   (let ((res nil)
 	(list1 list1))
     (do () ((endp list1))
-      (if (not (with-set-keys (member (funcall key (car list1)) list2)))
+      (if (not (with-set-keys (member (apply-key key (car list1)) list2)))
 	  (steve-splice list1 res)
 	  (setq list1 (cdr list1))))
     res))
 
 
-(defun set-exclusive-or (list1 list2 &key (key #'identity)
+(defun set-exclusive-or (list1 list2 &key key
 			       (test #'eql testp) (test-not nil notp))
   "Returns new list of elements appearing exactly once in list1 and list2."
   (declare (inline member))
   (let ((result nil))
     (dolist (elt list1)
-      (unless (with-set-keys (member (funcall key elt) list2))
+      (unless (with-set-keys (member (apply-key key elt) list2))
 	(setq result (cons elt result))))
     (dolist (elt list2)
-      (unless (with-set-keys (member (funcall key elt) list1))
+      (unless (with-set-keys (member (apply-key key elt) list1))
 	(setq result (cons elt result))))
     result))
 
@@ -745,7 +791,7 @@
 ;;; top of the list or not
 
 (defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp)
-				(key #'identity))
+				key)
   "Destructively return a list with elements which appear but once in list1
    and list2."
   (do ((list1 list1)
@@ -760,10 +806,11 @@
     (do ((y list2 (cdr y))
 	 (splicey ()))
 	((endp y) (setq splicex x))
-      (cond ((if notp
-		 (not (funcall test-not (funcall key (car x))
-			       (funcall key (Car y))))
-		 (funcall test (funcall key (car x)) (funcall key (Car y))))
+      (cond ((let ((key-val-x (apply-key key (car x)))
+		   (key-val-y (apply-key key (Car y))))
+	       (if notp
+		   (not (funcall test-not key-val-x key-val-y))
+		   (funcall test key-val-x key-val-y)))
 	     (if (null splicex)
 		 (setq list1 (cdr x))
 		 (rplacd splicex (cdr x)))
@@ -773,70 +820,15 @@
 	     (return ()))			; assume lists are really sets
 	    (t (setq splicey y))))))
 
-(defun subsetp (list1 list2 &key (key #'identity)
-		      (test #'eql testp) (test-not nil notp))
+(defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   "Returns T if every element in list1 is also in list2."
   (declare (inline member))
   (dolist (elt list1)
-    (unless (with-set-keys (member (funcall key elt) list2))
+    (unless (with-set-keys (member (apply-key key elt) list2))
       (return-from subsetp nil)))
   T)
 
 
-
-;;;; :key arg optimization to save funcall of IDENTITY.
-
-;;; We should move this earlier in this file and make other functions use it as
-;;; well.
-;;;
-
-;;; APPLY-KEY saves us a function call sometimes.
-;;;    This is not in and (eval-when (compile eval) ...
-;;;    because this is used in seq.lisp and sort.lisp.
-;;;
-(defmacro apply-key (key element)
-  `(if ,key
-       (funcall ,key ,element)
-       ,element))
-
-(defun identity (thing)
-  "Returns what was passed to it."
-  thing)
-
-
-(defun complement (function)
-  "Builds a new function that returns T whenever FUNCTION returns NIL and
-   NIL whenever FUNCTION returns T."
-  #'(lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
-		       &rest more-args)
-      (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
-		 (arg2-p (funcall function arg0 arg1 arg2))
-		 (arg1-p (funcall function arg0 arg1))
-		 (arg0-p (funcall function arg0))
-		 (t (funcall function))))))
-
-
-(defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p)
-			 &rest more-values)
-  "Builds a function that always returns VALUE, and posisbly MORE-VALUES."
-  (cond (more-values
-	 (let ((list (list* value val1 val2 more-values)))
-	   #'(lambda ()
-	       (declare (ext:optimize-interface (speed 3) (safety 0)))
-	       (values-list list))))
-	(val2-p
-	 #'(lambda ()
-	     (declare (ext:optimize-interface (speed 3) (safety 0)))
-	     (values value val1 val2)))
-	(val1-p
-	 #'(lambda ()
-	     (declare (ext:optimize-interface (speed 3) (safety 0)))
-	     (values value val1)))
-	(t
-	 #'(lambda ()
-	     (declare (ext:optimize-interface (speed 3) (safety 0)))
-	     value))))
-
 
 ;;; Functions that operate on association lists
 
@@ -863,40 +855,66 @@
 (defun assoc (item alist &key key test test-not)
   "Returns the cons in alist whose car is equal (by a given test or EQL) to
    the Item."
-  (cond (test (assoc-guts (funcall test item (apply-key key (caar alist)))))
-	(test-not (assoc-guts (not (funcall test-not item
-					    (apply-key key (caar alist))))))
-	(t (assoc-guts (eql item (apply-key key (caar alist)))))))
+  (cond (test
+	 (if key
+	     (assoc-guts (funcall test item (funcall key (caar alist))))
+	     (assoc-guts (funcall test item (caar alist)))))
+	(test-not
+	 (if key
+	     (assoc-guts (not (funcall test-not item
+				       (funcall key (caar alist)))))
+	     (assoc-guts (not (funcall test-not item (caar alist))))))
+	(t
+	 (if key
+	     (assoc-guts (eql item (funcall key (caar alist))))
+	     (assoc-guts (eql item (caar alist)))))))
 
 (defun assoc-if (predicate alist &key key)
   "Returns the first cons in alist whose car satisfies the Predicate.  If
    key is supplied, apply it to the car of each cons before testing."
-  (assoc-guts (funcall predicate (apply-key key (caar alist)))))
+  (if key
+      (assoc-guts (funcall predicate (funcall key (caar alist))))
+      (assoc-guts (funcall predicate (caar alist)))))
 
 (defun assoc-if-not (predicate alist &key key)
   "Returns the first cons in alist whose car does not satisfiy the Predicate.
   If key is supplied, apply it to the car of each cons before testing."
-  (assoc-guts (not (funcall predicate (apply-key key (caar alist))))))
+  (if key
+      (assoc-guts (not (funcall predicate (funcall key (caar alist)))))
+      (assoc-guts (not (funcall predicate (caar alist))))))
 
 
 (defun rassoc (item alist &key key test test-not)
   (declare (list alist))
   "Returns the cons in alist whose cdr is equal (by a given test or EQL) to
    the Item."
-  (cond (test (assoc-guts (funcall test item (apply-key key (cdar alist)))))
-	(test-not (assoc-guts (not (funcall test-not item
-					    (apply-key key (cdar alist))))))
-	(t (assoc-guts (eql item (apply-key key (cdar alist)))))))
+  (cond (test
+	 (if key
+	     (assoc-guts (funcall test item (funcall key (cdar alist))))
+	     (assoc-guts (funcall test item (cdar alist)))))
+	(test-not
+	 (if key
+	     (assoc-guts (not (funcall test-not item
+				       (funcall key (cdar alist)))))
+	     (assoc-guts (not (funcall test-not item (cdar alist))))))
+	(t
+	 (if key
+	     (assoc-guts (eql item (funcall key (cdar alist))))
+	     (assoc-guts (eql item (cdar alist)))))))
 
 (defun rassoc-if (predicate alist &key key)
   "Returns the first cons in alist whose cdr satisfies the Predicate.  If key
   is supplied, apply it to the cdr of each cons before testing."
-  (assoc-guts (funcall predicate (apply-key key (cdar alist)))))
+  (if key
+      (assoc-guts (funcall predicate (funcall key (cdar alist))))
+      (assoc-guts (funcall predicate (cdar alist)))))
 
 (defun rassoc-if-not (predicate alist &key key)
   "Returns the first cons in alist whose cdr does not satisfy the Predicate.
   If key is supplied, apply it to the cdr of each cons before testing."
-  (assoc-guts (not (funcall predicate (apply-key key (cdar alist))))))
+  (if key
+      (assoc-guts (not (funcall predicate (funcall key (cdar alist)))))
+      (assoc-guts (not (funcall predicate (cdar alist))))))
 
 
 
diff --git a/code/seq.lisp b/code/seq.lisp
index c0ab6f0ed..203737b19 100644
--- a/code/seq.lisp
+++ b/code/seq.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.27 1998/03/21 08:12:05 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.28 1998/04/03 03:45:39 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1341,7 +1341,7 @@
 				(nthcdr (1+ start) result)
 				:test test
 				:test-not test-not
-				:key (if key key #'identity))))
+				:key key)))
 	      (and (not from-end)
 		   (not (do ((it (apply-key key (car current)))
 			     (l (cdr current) (cdr l))
-- 
GitLab