functions.lisp

   1 (in-package :alexandria)
   2
   3 (defun disjoin (predicate &rest more-predicates)
   4   "Returns a function that applies each of PREDICATE and MORE-PREDICATE
   5 functions in turn to its arguments, returning the primary value of the first
   6 predicate that returns true, without calling the remaining predicates.
   7 If none of the predicates returns true, NIL is returned."
   8   (declare (optimize (speed 3) (safety 1) (debug 1)))
   9   (lambda (&rest arguments)
  10     (or (apply predicate arguments)
  11         (some (lambda (p)
  12                 (apply p arguments))
  13               more-predicates))))
  14
  15 (defun conjoin (predicate &rest more-predicates)
  16   "Returns a function that applies each of PREDICATE and MORE-PREDICATE
  17 functions in turn to its arguments, returning NIL if any of the predicates
  18 returns false, without calling the remaining predicated. If none of the
  19 predicates returns false, returns the primary value of the last predicate."
  20   (lambda (&rest arguments)
  21     (and (apply predicate arguments)
  22          (do ((tail (cdr more-predicates) (cdr tail))
  23               (head (car more-predicates) (car tail)))
  24              ((not tail)
  25               (apply head arguments))
  26            (unless (apply head arguments)
  27              (return nil))))))
  28
  29 (defun compose (function &rest more-functions)
  30   "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
  31 arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
  32 and then calling the next one with the primary value of the last."
  33   (declare (optimize (speed 3) (safety 1) (debug 1)))
  34   (reduce (lambda (f g)
  35             (lambda (&rest arguments)
  36               (declare (dynamic-extent arguments))
  37               (funcall f (apply g arguments))))
  38           more-functions
  39           :initial-value function))
  40
  41 (define-compiler-macro compose (function &rest more-functions)
  42   (labels ((compose-1 (funs)
  43              (if (cdr funs)
  44                  `(funcall ,(car funs) ,(compose-1 (cdr funs)))
  45                  `(apply ,(car funs) arguments))))
  46     (let* ((args (cons function more-functions))
  47            (funs (make-gensym-list (length args) "COMPOSE")))
  48       `(let ,(mapcar #'list funs args)
  49          (declare (optimize (speed 3) (safety 1) (debug 1)))
  50          (lambda (&rest arguments)
  51            (declare (dynamic-extent arguments))
  52            ,(compose-1 funs))))))
  53
  54 (defun multiple-value-compose (function &rest more-functions)
  55     "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
  56 its arguments to to each in turn, starting from the rightmost of
  57 MORE-FUNCTIONS, and then calling the next one with all the return values of
  58 the last."
  59   (declare (optimize (speed 3) (safety 1) (debug 1)))
  60   (reduce (lambda (f g)
  61             (lambda (&rest arguments)
  62               (declare (dynamic-extent arguments))
  63               (multiple-value-call f (apply g arguments))))
  64           more-functions
  65           :initial-value function))
  66
  67 (define-compiler-macro multiple-value-compose (function &rest more-functions)
  68   (labels ((compose-1 (funs)
  69              (if (cdr funs)
  70                  `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
  71                  `(apply ,(car funs) arguments))))
  72     (let* ((args (cons function more-functions))
  73            (funs (make-gensym-list (length args) "MV-COMPOSE")))
  74       `(let ,(mapcar #'list funs args)
  75          (declare (optimize (speed 3) (safety 1) (debug 1)))
  76          (lambda (&rest arguments)
  77            (declare (dynamic-extent arguments))
  78            ,(compose-1 funs))))))
  79
  80 (defun curry (function &rest arguments)
  81   "Returns a function that applies ARGUMENTS and the arguments
  82 it is called with to FUNCTION."
  83   (declare (optimize (speed 3) (safety 1) (debug 1)))
  84   (lambda (&rest more)
  85     (declare (dynamic-extent more))
  86     ;; Using M-V-C we don't need to append the arguments.
  87     (multiple-value-call function (values-list arguments) (values-list more))))
  88
  89 (define-compiler-macro curry (function &rest arguments)
  90   (let ((curries (make-gensym-list (length arguments) "CURRY")))
  91     `(let ,(mapcar #'list curries arguments)
  92        (declare (optimize (speed 3) (safety 1) (debug 1)))
  93        (lambda (&rest more)
  94          (apply ,function ,@curries more)))))
  95
  96 (defun rcurry (function &rest arguments)
  97   "Returns a function that applies the arguments it is called
  98 with and ARGUMENTS to FUNCTION."
  99   (declare (optimize (speed 3) (safety 1) (debug 1)))
 100   (lambda (&rest more)
 101     (declare (dynamic-extent more))
 102     (multiple-value-call function (values-list more) (values-list arguments))))
 103
 104 (defmacro named-lambda (name lambda-list &body body)
 105   "Expands into a lambda-expression within whose BODY NAME denotes the
 106 corresponding function."
 107   `(labels ((,name ,lambda-list ,@body))
 108      #',name))
 109
 110 (declaim (ftype (function (t) (values function &optional))
 111                 ensure-function))
 112 (defun ensure-function (function-designator)
 113   "Returns the function designated by FUNCTION-DESIGNATOR:
 114 if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
 115 it must be a function name and its FDEFINITION is returned."
 116   (if (functionp function-designator)
 117       function-designator
 118       (fdefinition function-designator)))