diff options
author | Vincent Ambo <mail@tazj.in> | 2021-12-15T20·10+0300 |
---|---|---|
committer | clbot <clbot@tvl.fyi> | 2021-12-15T21·02+0000 |
commit | 28ac55e94a4c71c1594d7ec51846315aed03e815 (patch) | |
tree | 3cedf2ff4a608605163b848c727690a39821ee10 /third_party/lisp/alexandria/control-flow.lisp | |
parent | 50b43cfb66a46fb5579e71d0e55174bb77fa2858 (diff) |
chore(3p/lisp): Unvendor alexandria and use nixpkgs sources r/3254
Change-Id: Idee3cb18ac42bd820d87aac0c68206436c1f4691 Reviewed-on: https://cl.tvl.fyi/c/depot/+/4338 Autosubmit: tazjin <mail@tazj.in> Tested-by: BuildkiteCI Reviewed-by: grfn <grfn@gws.fyi>
Diffstat (limited to 'third_party/lisp/alexandria/control-flow.lisp')
-rw-r--r-- | third_party/lisp/alexandria/control-flow.lisp | 106 |
1 files changed, 0 insertions, 106 deletions
diff --git a/third_party/lisp/alexandria/control-flow.lisp b/third_party/lisp/alexandria/control-flow.lisp deleted file mode 100644 index dd00df3e1620..000000000000 --- a/third_party/lisp/alexandria/control-flow.lisp +++ /dev/null @@ -1,106 +0,0 @@ -(in-package :alexandria) - -(defun extract-function-name (spec) - "Useful for macros that want to mimic the functional interface for functions -like #'eq and 'eq." - (if (and (consp spec) - (member (first spec) '(quote function))) - (second spec) - spec)) - -(defun generate-switch-body (whole object clauses test key &optional default) - (with-gensyms (value) - (setf test (extract-function-name test)) - (setf key (extract-function-name key)) - (when (and (consp default) - (member (first default) '(error cerror))) - (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S." - ,value ',test))) - `(let ((,value (,key ,object))) - (cond ,@(mapcar (lambda (clause) - (if (member (first clause) '(t otherwise)) - (progn - (when default - (error "Multiple default clauses or illegal use of a default clause in ~S." - whole)) - (setf default `(progn ,@(rest clause))) - '(())) - (destructuring-bind (key-form &body forms) clause - `((,test ,value ,key-form) - ,@forms)))) - clauses) - (t ,default))))) - -(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity)) - &body clauses) - "Evaluates first matching clause, returning its values, or evaluates and -returns the values of T or OTHERWISE if no keys match." - (generate-switch-body whole object clauses test key)) - -(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity)) - &body clauses) - "Like SWITCH, but signals an error if no key matches." - (generate-switch-body whole object clauses test key '(error))) - -(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity)) - &body clauses) - "Like SWITCH, but signals a continuable error if no key matches." - (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH."))) - -(defmacro whichever (&rest possibilities &environment env) - "Evaluates exactly one of POSSIBILITIES, chosen at random." - (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities)) - (if (every (lambda (p) (constantp p)) possibilities) - `(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities))) - (labels ((expand (possibilities position random-number) - (if (null (cdr possibilities)) - (car possibilities) - (let* ((length (length possibilities)) - (half (truncate length 2)) - (second-half (nthcdr half possibilities)) - (first-half (butlast possibilities (- length half)))) - `(if (< ,random-number ,(+ position half)) - ,(expand first-half position random-number) - ,(expand second-half (+ position half) random-number)))))) - (with-gensyms (random-number) - (let ((length (length possibilities))) - `(let ((,random-number (random ,length))) - ,(expand possibilities 0 random-number))))))) - -(defmacro xor (&rest datums) - "Evaluates its arguments one at a time, from left to right. If more than one -argument evaluates to a true value no further DATUMS are evaluated, and NIL is -returned as both primary and secondary value. If exactly one argument -evaluates to true, its value is returned as the primary value after all the -arguments have been evaluated, and T is returned as the secondary value. If no -arguments evaluate to true NIL is retuned as primary, and T as secondary -value." - (with-gensyms (xor tmp true) - `(let (,tmp ,true) - (block ,xor - ,@(mapcar (lambda (datum) - `(if (setf ,tmp ,datum) - (if ,true - (return-from ,xor (values nil nil)) - (setf ,true ,tmp)))) - datums) - (return-from ,xor (values ,true t)))))) - -(defmacro nth-value-or (nth-value &body forms) - "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one -of the forms is true. It then returns all the values returned by evaluating -that form. If none of the forms return a true nth value, this form returns -NIL." - (once-only (nth-value) - (with-gensyms (values) - `(let ((,values (multiple-value-list ,(first forms)))) - (if (nth ,nth-value ,values) - (values-list ,values) - ,(if (rest forms) - `(nth-value-or ,nth-value ,@(rest forms)) - nil)))))) - -(defmacro multiple-value-prog2 (first-form second-form &body forms) - "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value -all the value returned by SECOND-FORM." - `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms))) |