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