control-flow.lisp - clic - Clic is an command line interactive client for gophe… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
control-flow.lisp (5185B) | |
--- | |
1 (in-package :alexandria) | |
2 | |
3 (defun extract-function-name (spec) | |
4 "Useful for macros that want to mimic the functional interface for fun… | |
5 like #'eq and 'eq." | |
6 (if (and (consp spec) | |
7 (member (first spec) '(quote function))) | |
8 (second spec) | |
9 spec)) | |
10 | |
11 (defun generate-switch-body (whole object clauses test key &optional def… | |
12 (with-gensyms (value) | |
13 (setf test (extract-function-name test)) | |
14 (setf key (extract-function-name key)) | |
15 (when (and (consp default) | |
16 (member (first default) '(error cerror))) | |
17 (setf default `(,@default "No keys match in SWITCH. Testing agains… | |
18 ,value ',test))) | |
19 `(let ((,value (,key ,object))) | |
20 (cond ,@(mapcar (lambda (clause) | |
21 (if (member (first clause) '(t otherwise)) | |
22 (progn | |
23 (when default | |
24 (error "Multiple default clauses or ille… | |
25 whole)) | |
26 (setf default `(progn ,@(rest clause))) | |
27 '(())) | |
28 (destructuring-bind (key-form &body forms) c… | |
29 `((,test ,value ,key-form) | |
30 ,@forms)))) | |
31 clauses) | |
32 (t ,default))))) | |
33 | |
34 (defmacro switch (&whole whole (object &key (test 'eql) (key 'identity)) | |
35 &body clauses) | |
36 "Evaluates first matching clause, returning its values, or evaluates a… | |
37 returns the values of T or OTHERWISE if no keys match." | |
38 (generate-switch-body whole object clauses test key)) | |
39 | |
40 (defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity)) | |
41 &body clauses) | |
42 "Like SWITCH, but signals an error if no key matches." | |
43 (generate-switch-body whole object clauses test key '(error))) | |
44 | |
45 (defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity)) | |
46 &body clauses) | |
47 "Like SWITCH, but signals a continuable error if no key matches." | |
48 (generate-switch-body whole object clauses test key '(cerror "Return N… | |
49 | |
50 (defmacro whichever (&rest possibilities &environment env) | |
51 "Evaluates exactly one of POSSIBILITIES, chosen at random." | |
52 (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibili… | |
53 (let ((length (length possibilities))) | |
54 (cond | |
55 ((= 1 length) | |
56 (first possibilities)) | |
57 ((every #'constantp possibilities) | |
58 `(svref (load-time-value (vector ,@possibilities)) | |
59 (random ,length))) | |
60 (T | |
61 (labels ((expand (possibilities position random-number) | |
62 (if (null (cdr possibilities)) | |
63 (car possibilities) | |
64 (let* ((length (length possibilities)) | |
65 (half (truncate length 2)) | |
66 (second-half (nthcdr half possibilities)) | |
67 (first-half (butlast possibilities (- lengt… | |
68 `(if (< ,random-number ,(+ position half)) | |
69 ,(expand first-half position random-number) | |
70 ,(expand second-half (+ position half) rand… | |
71 (with-gensyms (random-number) | |
72 `(let ((,random-number (random ,length))) | |
73 ,(expand possibilities 0 random-number)))))))) | |
74 | |
75 (defmacro xor (&rest datums) | |
76 "Evaluates its arguments one at a time, from left to right. If more th… | |
77 argument evaluates to a true value no further DATUMS are evaluated, and … | |
78 returned as both primary and secondary value. If exactly one argument | |
79 evaluates to true, its value is returned as the primary value after all … | |
80 arguments have been evaluated, and T is returned as the secondary value.… | |
81 arguments evaluate to true NIL is retuned as primary, and T as secondary | |
82 value." | |
83 (with-gensyms (xor tmp true) | |
84 `(let (,tmp ,true) | |
85 (block ,xor | |
86 ,@(mapcar (lambda (datum) | |
87 `(if (setf ,tmp ,datum) | |
88 (if ,true | |
89 (return-from ,xor (values nil nil)) | |
90 (setf ,true ,tmp)))) | |
91 datums) | |
92 (return-from ,xor (values ,true t)))))) | |
93 | |
94 (defmacro nth-value-or (nth-value &body forms) | |
95 "Evaluates FORM arguments one at a time, until the NTH-VALUE returned … | |
96 of the forms is true. It then returns all the values returned by evaluat… | |
97 that form. If none of the forms return a true nth value, this form retur… | |
98 NIL." | |
99 (once-only (nth-value) | |
100 (with-gensyms (values) | |
101 `(let ((,values (multiple-value-list ,(first forms)))) | |
102 (if (nth ,nth-value ,values) | |
103 (values-list ,values) | |
104 ,(if (rest forms) | |
105 `(nth-value-or ,nth-value ,@(rest forms)) | |
106 nil)))))) | |
107 | |
108 (defmacro multiple-value-prog2 (first-form second-form &body forms) | |
109 "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its… | |
110 all the value returned by SECOND-FORM." | |
111 `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms))) |