control-flow.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP (HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/ (DIR) Log (DIR) Files (DIR) Refs (DIR) Tags (DIR) README (DIR) 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 functions 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 default) 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 against ~S with ~S." 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 illegal use of a default clause in ~S." 25 whole)) 26 (setf default `(progn ,@(rest clause))) 27 '(())) 28 (destructuring-bind (key-form &body forms) clause 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 and 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 NIL from CSWITCH."))) 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)) possibilities)) 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 (- length half)))) 68 `(if (< ,random-number ,(+ position half)) 69 ,(expand first-half position random-number) 70 ,(expand second-half (+ position half) random-number)))))) 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 than one 77 argument evaluates to a true value no further DATUMS are evaluated, and NIL is 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 the 80 arguments have been evaluated, and T is returned as the secondary value. If no 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 by one 96 of the forms is true. It then returns all the values returned by evaluating 97 that form. If none of the forms return a true nth value, this form returns 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 value 110 all the value returned by SECOND-FORM." 111 `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms)))