diff --git a/code/list.lisp b/code/list.lisp index 1be15d45932ad7a682a91b5eff0cb83ae6480298..eaa3533dafbafce00244c3c57c8edea5127c8c6b 100644 --- a/code/list.lisp +++ b/code/list.lisp @@ -34,8 +34,8 @@ nset-difference set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc assoc-if assoc-if-not - rassoc rassoc-if rassoc-if-not)) - + rassoc rassoc-if rassoc-if-not + complement constantly)) (proclaim '(maybe-inline tree-equal list-length nth %setnth nthcdr last make-list append @@ -776,6 +776,39 @@ 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 (optimize (speed 3) (safety 0))) + (values-list list)))) + (val2-p + #'(lambda () + (declare (optimize (speed 3) (safety 0))) + (values value val1 val2))) + (val1-p + #'(lambda () + (declare (optimize (speed 3) (safety 0))) + (values value val1))) + (t + #'(lambda () + (declare (optimize (speed 3) (safety 0))) + value)))) + ;;; Functions that operate on association lists