+
+(defun deprecation-warning (bad-name &optional good-name)
+ (warn "using deprecated ~S~@[, should use ~S instead~]"
+ bad-name
+ good-name))
+
+;;; Anaphoric macros
+(defmacro awhen (test &body body)
+ `(let ((it ,test))
+ (when it ,@body)))
+
+(defmacro acond (&rest clauses)
+ (if (null clauses)
+ `()
+ (destructuring-bind ((test &body body) &rest rest) clauses
+ (once-only ((test test))
+ `(if ,test
+ (let ((it ,test)) (declare (ignorable it)),@body)
+ (acond ,@rest))))))
+
+;;; (binding* ({(names initial-value [flag])}*) body)
+;;; FLAG may be NIL or :EXIT-IF-NULL
+;;;
+;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN.
+(defmacro binding* ((&rest bindings) &body body)
+ (let ((bindings (reverse bindings)))
+ (loop with form = `(progn ,@body)
+ for binding in bindings
+ do (destructuring-bind (names initial-value &optional flag)
+ binding
+ (multiple-value-bind (names declarations)
+ (etypecase names
+ (null
+ (let ((name (gensym)))
+ (values (list name) `((declare (ignorable ,name))))))
+ (symbol
+ (values (list names) nil))
+ (list
+ (collect ((new-names) (ignorable))
+ (dolist (name names)
+ (when (eq name nil)
+ (setq name (gensym))
+ (ignorable name))
+ (new-names name))
+ (values (new-names)
+ (when (ignorable)
+ `((declare (ignorable ,@(ignorable)))))))))
+ (setq form `(multiple-value-bind ,names
+ ,initial-value
+ ,@declarations
+ ,(ecase flag
+ ((nil) form)
+ ((:exit-if-null)
+ `(when ,(first names) ,form)))))))
+ finally (return form))))
+\f
+;;; Delayed evaluation
+(defmacro delay (form)
+ `(cons nil (lambda () ,form)))
+
+(defun force (promise)
+ (cond ((not (consp promise)) promise)
+ ((car promise) (cdr promise))
+ (t (setf (car promise) t
+ (cdr promise) (funcall (cdr promise))))))
+
+(defun promise-ready-p (promise)
+ (or (not (consp promise))
+ (car promise)))
+\f
+;;; toplevel helper
+(defmacro with-rebound-io-syntax (&body body)
+ `(%with-rebound-io-syntax (lambda () ,@body)))
+
+(defun %with-rebound-io-syntax (function)
+ (declare (type function function))
+ (let ((*package* *package*)
+ (*print-array* *print-array*)
+ (*print-base* *print-base*)
+ (*print-case* *print-case*)
+ (*print-circle* *print-circle*)
+ (*print-escape* *print-escape*)
+ (*print-gensym* *print-gensym*)
+ (*print-length* *print-length*)
+ (*print-level* *print-level*)
+ (*print-lines* *print-lines*)
+ (*print-miser-width* *print-miser-width*)
+ (*print-pretty* *print-pretty*)
+ (*print-radix* *print-radix*)
+ (*print-readably* *print-readably*)
+ (*print-right-margin* *print-right-margin*)
+ (*read-base* *read-base*)
+ (*read-default-float-format* *read-default-float-format*)
+ (*read-eval* *read-eval*)
+ (*read-suppress* *read-suppress*)
+ (*readtable* *readtable*))
+ (funcall function)))