functions.lisp - clic - Clic is an command line interactive client for gopher w… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
functions.lisp (6645B) | |
--- | |
1 (in-package :alexandria) | |
2 | |
3 ;;; To propagate return type and allow the compiler to eliminate the IF … | |
4 ;;; it is known if the argument is function or not. | |
5 (declaim (inline ensure-function)) | |
6 | |
7 (declaim (ftype (function (t) (values function &optional)) | |
8 ensure-function)) | |
9 (defun ensure-function (function-designator) | |
10 "Returns the function designated by FUNCTION-DESIGNATOR: | |
11 if FUNCTION-DESIGNATOR is a function, it is returned, otherwise | |
12 it must be a function name and its FDEFINITION is returned." | |
13 (if (functionp function-designator) | |
14 function-designator | |
15 (fdefinition function-designator))) | |
16 | |
17 (define-modify-macro ensure-functionf/1 () ensure-function) | |
18 | |
19 (defmacro ensure-functionf (&rest places) | |
20 "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of | |
21 PLACES contains a function." | |
22 `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places))) | |
23 | |
24 (defun disjoin (predicate &rest more-predicates) | |
25 "Returns a function that applies each of PREDICATE and MORE-PREDICATE | |
26 functions in turn to its arguments, returning the primary value of the f… | |
27 predicate that returns true, without calling the remaining predicates. | |
28 If none of the predicates returns true, NIL is returned." | |
29 (declare (optimize (speed 3) (safety 1) (debug 1))) | |
30 (let ((predicate (ensure-function predicate)) | |
31 (more-predicates (mapcar #'ensure-function more-predicates))) | |
32 (lambda (&rest arguments) | |
33 (or (apply predicate arguments) | |
34 (some (lambda (p) | |
35 (declare (type function p)) | |
36 (apply p arguments)) | |
37 more-predicates))))) | |
38 | |
39 (defun conjoin (predicate &rest more-predicates) | |
40 "Returns a function that applies each of PREDICATE and MORE-PREDICATE | |
41 functions in turn to its arguments, returning NIL if any of the predicat… | |
42 returns false, without calling the remaining predicates. If none of the | |
43 predicates returns false, returns the primary value of the last predicat… | |
44 (if (null more-predicates) | |
45 predicate | |
46 (lambda (&rest arguments) | |
47 (and (apply predicate arguments) | |
48 ;; Cannot simply use CL:EVERY because we want to return the | |
49 ;; non-NIL value of the last predicate if all succeed. | |
50 (do ((tail (cdr more-predicates) (cdr tail)) | |
51 (head (car more-predicates) (car tail))) | |
52 ((not tail) | |
53 (apply head arguments)) | |
54 (unless (apply head arguments) | |
55 (return nil))))))) | |
56 | |
57 | |
58 (defun compose (function &rest more-functions) | |
59 "Returns a function composed of FUNCTION and MORE-FUNCTIONS that appli… | |
60 arguments to to each in turn, starting from the rightmost of MORE-FUNCTI… | |
61 and then calling the next one with the primary value of the last." | |
62 (declare (optimize (speed 3) (safety 1) (debug 1))) | |
63 (reduce (lambda (f g) | |
64 (let ((f (ensure-function f)) | |
65 (g (ensure-function g))) | |
66 (lambda (&rest arguments) | |
67 (declare (dynamic-extent arguments)) | |
68 (funcall f (apply g arguments))))) | |
69 more-functions | |
70 :initial-value function)) | |
71 | |
72 (define-compiler-macro compose (function &rest more-functions) | |
73 (labels ((compose-1 (funs) | |
74 (if (cdr funs) | |
75 `(funcall ,(car funs) ,(compose-1 (cdr funs))) | |
76 `(apply ,(car funs) arguments)))) | |
77 (let* ((args (cons function more-functions)) | |
78 (funs (make-gensym-list (length args) "COMPOSE"))) | |
79 `(let ,(loop for f in funs for arg in args | |
80 collect `(,f (ensure-function ,arg))) | |
81 (declare (optimize (speed 3) (safety 1) (debug 1))) | |
82 (lambda (&rest arguments) | |
83 (declare (dynamic-extent arguments)) | |
84 ,(compose-1 funs)))))) | |
85 | |
86 (defun multiple-value-compose (function &rest more-functions) | |
87 "Returns a function composed of FUNCTION and MORE-FUNCTIONS that app… | |
88 its arguments to each in turn, starting from the rightmost of | |
89 MORE-FUNCTIONS, and then calling the next one with all the return values… | |
90 the last." | |
91 (declare (optimize (speed 3) (safety 1) (debug 1))) | |
92 (reduce (lambda (f g) | |
93 (let ((f (ensure-function f)) | |
94 (g (ensure-function g))) | |
95 (lambda (&rest arguments) | |
96 (declare (dynamic-extent arguments)) | |
97 (multiple-value-call f (apply g arguments))))) | |
98 more-functions | |
99 :initial-value function)) | |
100 | |
101 (define-compiler-macro multiple-value-compose (function &rest more-funct… | |
102 (labels ((compose-1 (funs) | |
103 (if (cdr funs) | |
104 `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs… | |
105 `(apply ,(car funs) arguments)))) | |
106 (let* ((args (cons function more-functions)) | |
107 (funs (make-gensym-list (length args) "MV-COMPOSE"))) | |
108 `(let ,(mapcar #'list funs args) | |
109 (declare (optimize (speed 3) (safety 1) (debug 1))) | |
110 (lambda (&rest arguments) | |
111 (declare (dynamic-extent arguments)) | |
112 ,(compose-1 funs)))))) | |
113 | |
114 (declaim (inline curry rcurry)) | |
115 | |
116 (defun curry (function &rest arguments) | |
117 "Returns a function that applies ARGUMENTS and the arguments | |
118 it is called with to FUNCTION." | |
119 (declare (optimize (speed 3) (safety 1))) | |
120 (let ((fn (ensure-function function))) | |
121 (lambda (&rest more) | |
122 (declare (dynamic-extent more)) | |
123 ;; Using M-V-C we don't need to append the arguments. | |
124 (multiple-value-call fn (values-list arguments) (values-list more)… | |
125 | |
126 (define-compiler-macro curry (function &rest arguments) | |
127 (let ((curries (make-gensym-list (length arguments) "CURRY")) | |
128 (fun (gensym "FUN"))) | |
129 `(let ((,fun (ensure-function ,function)) | |
130 ,@(mapcar #'list curries arguments)) | |
131 (declare (optimize (speed 3) (safety 1))) | |
132 (lambda (&rest more) | |
133 (declare (dynamic-extent more)) | |
134 (apply ,fun ,@curries more))))) | |
135 | |
136 (defun rcurry (function &rest arguments) | |
137 "Returns a function that applies the arguments it is called | |
138 with and ARGUMENTS to FUNCTION." | |
139 (declare (optimize (speed 3) (safety 1))) | |
140 (let ((fn (ensure-function function))) | |
141 (lambda (&rest more) | |
142 (declare (dynamic-extent more)) | |
143 (multiple-value-call fn (values-list more) (values-list arguments)… | |
144 | |
145 (define-compiler-macro rcurry (function &rest arguments) | |
146 (let ((rcurries (make-gensym-list (length arguments) "RCURRY")) | |
147 (fun (gensym "FUN"))) | |
148 `(let ((,fun (ensure-function ,function)) | |
149 ,@(mapcar #'list rcurries arguments)) | |
150 (declare (optimize (speed 3) (safety 1))) | |
151 (lambda (&rest more) | |
152 (declare (dynamic-extent more)) | |
153 (multiple-value-call ,fun (values-list more) ,@rcurries))))) | |
154 | |
155 (declaim (notinline curry rcurry)) | |
156 | |
157 (defmacro named-lambda (name lambda-list &body body) | |
158 "Expands into a lambda-expression within whose BODY NAME denotes the | |
159 corresponding function." | |
160 `(labels ((,name ,lambda-list ,@body)) | |
161 #',name)) |