functions.lisp 6.49 KB
Newer Older
Nikodemus Siivola's avatar
Nikodemus Siivola committed
1 2
(in-package :alexandria)

3 4 5
;;; To propagate return type and allow the compiler to eliminate the IF when
;;; it is known if the argument is function or not.
(declaim (inline ensure-function))
6

7 8 9 10 11 12 13 14 15 16
(declaim (ftype (function (t) (values function &optional))
                ensure-function))
(defun ensure-function (function-designator)
  "Returns the function designated by FUNCTION-DESIGNATOR:
if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
it must be a function name and its FDEFINITION is returned."
  (if (functionp function-designator)
      function-designator
      (fdefinition function-designator)))

Attila Lendvai's avatar
Attila Lendvai committed
17 18 19
(define-modify-macro ensure-functionf/1 () ensure-function)

(defmacro ensure-functionf (&rest places)
20 21
  "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
PLACES contains a function."
Attila Lendvai's avatar
Attila Lendvai committed
22 23
  `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
24 25 26 27 28 29
(defun disjoin (predicate &rest more-predicates)
  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning the primary value of the first
predicate that returns true, without calling the remaining predicates.
If none of the predicates returns true, NIL is returned."
  (declare (optimize (speed 3) (safety 1) (debug 1)))
30 31 32 33 34 35 36 37
  (let ((predicate (ensure-function predicate))
	(more-predicates (mapcar #'ensure-function more-predicates)))
    (lambda (&rest arguments)
      (or (apply predicate arguments)
	  (some (lambda (p)
		  (declare (type function p))
		  (apply p arguments))
		more-predicates)))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
38 39 40 41

(defun conjoin (predicate &rest more-predicates)
  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning NIL if any of the predicates
42
returns false, without calling the remaining predicates. If none of the
Nikodemus Siivola's avatar
Nikodemus Siivola committed
43
predicates returns false, returns the primary value of the last predicate."
44 45 46 47 48 49 50 51 52 53 54 55
  (if (null more-predicates)
      predicate
      (lambda (&rest arguments)
	(and (apply predicate arguments)
	     ;; Cannot simply use CL:EVERY because we want to return the
	     ;; non-NIL value of the last predicate if all succeed.
	     (do ((tail (cdr more-predicates) (cdr tail))
		  (head (car more-predicates) (car tail)))
		 ((not tail)
		  (apply head arguments))
	       (unless (apply head arguments)
		 (return nil)))))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
56

57

Nikodemus Siivola's avatar
Nikodemus Siivola committed
58 59 60 61 62 63
(defun compose (function &rest more-functions)
  "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
and then calling the next one with the primary value of the last."
  (declare (optimize (speed 3) (safety 1) (debug 1)))
  (reduce (lambda (f g)
64 65 66 67 68
	    (let ((f (ensure-function f))
		  (g (ensure-function g)))
	      (lambda (&rest arguments)
		(declare (dynamic-extent arguments))
		(funcall f (apply g arguments)))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
69 70 71 72 73 74 75 76 77 78
          more-functions
          :initial-value function))

(define-compiler-macro compose (function &rest more-functions)
  (labels ((compose-1 (funs)
             (if (cdr funs)
                 `(funcall ,(car funs) ,(compose-1 (cdr funs)))
                 `(apply ,(car funs) arguments))))
    (let* ((args (cons function more-functions))
           (funs (make-gensym-list (length args) "COMPOSE")))
79 80
      `(let ,(loop for f in funs for arg in args
		   collect `(,f (ensure-function ,arg)))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
81 82 83 84 85 86 87
         (declare (optimize (speed 3) (safety 1) (debug 1)))
         (lambda (&rest arguments)
           (declare (dynamic-extent arguments))
           ,(compose-1 funs))))))

(defun multiple-value-compose (function &rest more-functions)
    "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
88
its arguments to each in turn, starting from the rightmost of
Nikodemus Siivola's avatar
Nikodemus Siivola committed
89 90 91 92
MORE-FUNCTIONS, and then calling the next one with all the return values of
the last."
  (declare (optimize (speed 3) (safety 1) (debug 1)))
  (reduce (lambda (f g)
93 94 95 96 97
	    (let ((f (ensure-function f))
		  (g (ensure-function g)))
	      (lambda (&rest arguments)
		(declare (dynamic-extent arguments))
		(multiple-value-call f (apply g arguments)))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
          more-functions
          :initial-value function))

(define-compiler-macro multiple-value-compose (function &rest more-functions)
  (labels ((compose-1 (funs)
             (if (cdr funs)
                 `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
                 `(apply ,(car funs) arguments))))
    (let* ((args (cons function more-functions))
           (funs (make-gensym-list (length args) "MV-COMPOSE")))
      `(let ,(mapcar #'list funs args)
         (declare (optimize (speed 3) (safety 1) (debug 1)))
         (lambda (&rest arguments)
           (declare (dynamic-extent arguments))
           ,(compose-1 funs))))))

114 115
(declaim (inline curry rcurry))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
116 117 118
(defun curry (function &rest arguments)
  "Returns a function that applies ARGUMENTS and the arguments
it is called with to FUNCTION."
119
  (declare (optimize (speed 3) (safety 1)))
120 121 122 123 124
  (let ((fn (ensure-function function)))
    (lambda (&rest more)
      (declare (dynamic-extent more))
      ;; Using M-V-C we don't need to append the arguments.
      (multiple-value-call fn (values-list arguments) (values-list more)))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
125 126

(define-compiler-macro curry (function &rest arguments)
127 128 129 130
  (let ((curries (make-gensym-list (length arguments) "CURRY"))
        (fun (gensym "FUN")))
    `(let ((,fun (ensure-function ,function))
           ,@(mapcar #'list curries arguments))
131
       (declare (optimize (speed 3) (safety 1)))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
132
       (lambda (&rest more)
133
         (declare (dynamic-extent more))
134
         (apply ,fun ,@curries more)))))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
135 136 137 138

(defun rcurry (function &rest arguments)
  "Returns a function that applies the arguments it is called
with and ARGUMENTS to FUNCTION."
139
  (declare (optimize (speed 3) (safety 1)))
140 141 142 143
  (let ((fn (ensure-function function)))
    (lambda (&rest more)
      (declare (dynamic-extent more))
      (multiple-value-call fn (values-list more) (values-list arguments)))))
144

145 146 147 148 149 150 151 152 153 154
(define-compiler-macro rcurry (function &rest arguments)
  (let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
        (fun (gensym "FUN")))
    `(let ((,fun (ensure-function ,function))
           ,@(mapcar #'list rcurries arguments))
       (declare (optimize (speed 3) (safety 1)))
       (lambda (&rest more)
         (declare (dynamic-extent more))
         (multiple-value-call ,fun (values-list more) ,@rcurries)))))

155 156
(declaim (notinline curry rcurry))

157 158
(defmacro named-lambda (name lambda-list &body body)
  "Expands into a lambda-expression within whose BODY NAME denotes the
159
corresponding function."
Nikodemus Siivola's avatar
Nikodemus Siivola committed
160
  `(labels ((,name ,lambda-list ,@body))
161
     #',name))