functions.lisp

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