GopherProxy

	tcontrol-flow.lisp - clic - Clic is an command line interactive client for goph…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tcontrol-flow.lisp (5126B)
	---
	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 (if (every (lambda (p) (constantp p)) possibilities)
	54 `(svref (load-time-value (vector ,@possibilities)) (random ,(lengt…
	55 (labels ((expand (possibilities position random-number)
	56 (if (null (cdr possibilities))
	57 (car possibilities)
	58 (let* ((length (length possibilities))
	59 (half (truncate length 2))
	60 (second-half (nthcdr half possibilities))
	61 (first-half (butlast possibilities (- length…
	62 `(if (< ,random-number ,(+ position half))
	63 ,(expand first-half position random-number)
	64 ,(expand second-half (+ position half) rando…
	65 (with-gensyms (random-number)
	66 (let ((length (length possibilities)))
	67 `(let ((,random-number (random ,length)))
	68 ,(expand possibilities 0 random-number)))))))
	69
	70 (defmacro xor (&rest datums)
	71 "Evaluates its arguments one at a time, from left to right. If more th…
	72 argument evaluates to a true value no further DATUMS are evaluated, and …
	73 returned as both primary and secondary value. If exactly one argument
	74 evaluates to true, its value is returned as the primary value after all …
	75 arguments have been evaluated, and T is returned as the secondary value.…
	76 arguments evaluate to true NIL is retuned as primary, and T as secondary
	77 value."
	78 (with-gensyms (xor tmp true)
	79 `(let (,tmp ,true)
	80 (block ,xor
	81 ,@(mapcar (lambda (datum)
	82 `(if (setf ,tmp ,datum)
	83 (if ,true
	84 (return-from ,xor (values nil nil))
	85 (setf ,true ,tmp))))
	86 datums)
	87 (return-from ,xor (values ,true t))))))
	88
	89 (defmacro nth-value-or (nth-value &body forms)
	90 "Evaluates FORM arguments one at a time, until the NTH-VALUE returned …
	91 of the forms is true. It then returns all the values returned by evaluat…
	92 that form. If none of the forms return a true nth value, this form retur…
	93 NIL."
	94 (once-only (nth-value)
	95 (with-gensyms (values)
	96 `(let ((,values (multiple-value-list ,(first forms))))
	97 (if (nth ,nth-value ,values)
	98 (values-list ,values)
	99 ,(if (rest forms)
	100 `(nth-value-or ,nth-value ,@(rest forms))
	101 nil))))))
	102
	103 (defmacro multiple-value-prog2 (first-form second-form &body forms)
	104 "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its…
	105 all the value returned by SECOND-FORM."
	106 `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms)))