diff options
Diffstat (limited to 'third_party/lisp/fiveam/src/utils.lisp')
| -rw-r--r-- | third_party/lisp/fiveam/src/utils.lisp | 226 |
1 files changed, 0 insertions, 226 deletions
diff --git a/third_party/lisp/fiveam/src/utils.lisp b/third_party/lisp/fiveam/src/utils.lisp deleted file mode 100644 index 49d552fa00..0000000000 --- a/third_party/lisp/fiveam/src/utils.lisp +++ /dev/null @@ -1,226 +0,0 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- - -(in-package :it.bese.fiveam) - -(defmacro dolist* ((iterator list &optional return-value) &body body) - "Like DOLIST but destructuring-binds the elements of LIST. - -If ITERATOR is a symbol then dolist* is just like dolist EXCEPT -that it creates a fresh binding." - (if (listp iterator) - (let ((i (gensym "DOLIST*-I-"))) - `(dolist (,i ,list ,return-value) - (destructuring-bind ,iterator ,i - ,@body))) - `(dolist (,iterator ,list ,return-value) - (let ((,iterator ,iterator)) - ,@body)))) - -(defun make-collector (&optional initial-value) - "Create a collector function. - -A Collector function will collect, into a list, all the values -passed to it in the order in which they were passed. If the -callector function is called without arguments it returns the -current list of values." - (let ((value initial-value) - (cdr (last initial-value))) - (lambda (&rest items) - (if items - (progn - (if value - (if cdr - (setf (cdr cdr) items - cdr (last items)) - (setf cdr (last items))) - (setf value items - cdr (last items))) - items) - value)))) - -(defun partitionx (list &rest lambdas) - (let ((collectors (mapcar (lambda (l) - (cons (if (and (symbolp l) - (member l (list :otherwise t) - :test #'string=)) - (constantly t) - l) - (make-collector))) - lambdas))) - (dolist (item list) - (block item - (dolist* ((test-func . collector-func) collectors) - (when (funcall test-func item) - (funcall collector-func item) - (return-from item))))) - (mapcar #'funcall (mapcar #'cdr collectors)))) - -;;;; ** Anaphoric conditionals - -(defmacro if-bind (var test &body then/else) - "Anaphoric IF control structure. - -VAR (a symbol) will be bound to the primary value of TEST. If -TEST returns a true value then THEN will be executed, otherwise -ELSE will be executed." - (assert (first then/else) - (then/else) - "IF-BIND missing THEN clause.") - (destructuring-bind (then &optional else) - then/else - `(let ((,var ,test)) - (if ,var ,then ,else)))) - -(defmacro aif (test then &optional else) - "Just like IF-BIND but the var is always IT." - `(if-bind it ,test ,then ,else)) - -;;;; ** Simple list matching based on code from Paul Graham's On Lisp. - -(defmacro acond2 (&rest clauses) - (if (null clauses) - nil - (with-gensyms (val foundp) - (destructuring-bind ((test &rest progn) &rest others) - clauses - `(multiple-value-bind (,val ,foundp) - ,test - (if (or ,val ,foundp) - (let ((it ,val)) - (declare (ignorable it)) - ,@progn) - (acond2 ,@others))))))) - -(defun varsymp (x) - (and (symbolp x) - (let ((name (symbol-name x))) - (and (>= (length name) 2) - (char= (char name 0) #\?))))) - -(defun binding (x binds) - (labels ((recbind (x binds) - (aif (assoc x binds) - (or (recbind (cdr it) binds) - it)))) - (let ((b (recbind x binds))) - (values (cdr b) b)))) - -(defun list-match (x y &optional binds) - (acond2 - ((or (eql x y) (eql x '_) (eql y '_)) - (values binds t)) - ((binding x binds) (list-match it y binds)) - ((binding y binds) (list-match x it binds)) - ((varsymp x) (values (cons (cons x y) binds) t)) - ((varsymp y) (values (cons (cons y x) binds) t)) - ((and (consp x) (consp y) (list-match (car x) (car y) binds)) - (list-match (cdr x) (cdr y) it)) - (t (values nil nil)))) - -(defun vars (match-spec) - (let ((vars nil)) - (labels ((find-vars (spec) - (cond - ((null spec) nil) - ((varsymp spec) (push spec vars)) - ((consp spec) - (find-vars (car spec)) - (find-vars (cdr spec)))))) - (find-vars match-spec)) - (delete-duplicates vars))) - -(defmacro list-match-case (target &body clauses) - (if clauses - (destructuring-bind ((test &rest progn) &rest others) - clauses - (with-gensyms (tgt binds success) - `(let ((,tgt ,target)) - (multiple-value-bind (,binds ,success) - (list-match ,tgt ',test) - (declare (ignorable ,binds)) - (if ,success - (let ,(mapcar (lambda (var) - `(,var (cdr (assoc ',var ,binds)))) - (vars test)) - (declare (ignorable ,@(vars test))) - ,@progn) - (list-match-case ,tgt ,@others)))))) - nil)) - -;;;; * def-special-environment - -(defun check-required (name vars required) - (dolist (var required) - (assert (member var vars) - (var) - "Unrecognized symbol ~S in ~S." var name))) - -(defmacro def-special-environment (name (&key accessor binder binder*) - &rest vars) - "Define two macros for dealing with groups or related special variables. - -ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest -BODY)). Each element of VARS will be bound to the -current (dynamic) value of the special variable. - -BINDER is defined as a macro for introducing (and binding new) -special variables. It is basically a readable LET form with the -prorpe declarations appended to the body. The first argument to -BINDER must be a form suitable as the first argument to LET. - -ACCESSOR defaults to a new symbol in the same package as NAME -which is the concatenation of \"WITH-\" NAME. BINDER is built as -\"BIND-\" and BINDER* is BINDER \"*\"." - (unless accessor - (setf accessor (format-symbol (symbol-package name) "~A-~A" '#:with name))) - (unless binder - (setf binder (format-symbol (symbol-package name) "~A-~A" '#:bind name))) - (unless binder* - (setf binder* (format-symbol (symbol-package binder) "~A~A" binder '#:*))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (flet () - (defmacro ,binder (requested-vars &body body) - (check-required ',name ',vars (mapcar #'car requested-vars)) - `(let ,requested-vars - (declare (special ,@(mapcar #'car requested-vars))) - ,@body)) - (defmacro ,binder* (requested-vars &body body) - (check-required ',name ',vars (mapcar #'car requested-vars)) - `(let* ,requested-vars - (declare (special ,@(mapcar #'car requested-vars))) - ,@body)) - (defmacro ,accessor (requested-vars &body body) - (check-required ',name ',vars requested-vars) - `(locally (declare (special ,@requested-vars)) - ,@body)) - ',name))) - -;; Copyright (c) 2002-2006, Edward Marco Baringer -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in the -;; documentation and/or other materials provided with the distribution. -;; -;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names -;; of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE |