src/code/funutils.lisp

   1 ;;;; miscellaneous operations on functions, returning functions, or
   2 ;;;; primarily useful for functional programming
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!IMPL")
  14
  15 (defun identity (thing)
  16   #!+sb-doc
  17   "This function simply returns what was passed to it."
  18   thing)
  19
  20 (defun complement (function)
  21   #!+sb-doc
  22   "Return a new function that returns T whenever FUNCTION returns NIL and
  23    NIL whenever FUNCTION returns non-NIL."
  24   ;; KLUDGE: constraint propagation is unable to detect that NTH gets
  25   ;; called only on indices known to be less than the predetermined N.
  26   (macrolet ((arg (n) `(fast-&rest-nth ,n arguments)))
  27     (lambda (&rest arguments)
  28       (not (let ((n (length arguments)))
  29              (if (> n 3)
  30                  (apply function arguments)
  31                  (case n
  32                   (1 (funcall function (arg 0)))
  33                   (2 (funcall function (arg 0) (arg 1)))
  34                   (3 (funcall function (arg 0) (arg 1) (arg 2)))
  35                   (t (funcall function)))))))))
  36
  37 (defun constantly (value)
  38   #!+sb-doc
  39   "Return a function that always returns VALUE."
  40   (lambda (&rest arguments)
  41     (declare (ignore arguments))
  42     (declare (optimize (speed 3) (safety 0) (debug 0)))
  43     value))