+\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)))
+
+;;; Bind a few "potentially dangerous" printer control variables to
+;;; safe values, respecting current values if possible.
+(defmacro with-sane-io-syntax (&body forms)
+ `(call-with-sane-io-syntax (lambda () ,@forms)))
+
+(defun call-with-sane-io-syntax (function)
+ (declare (type function function))
+ (macrolet ((true (sym)
+ `(and (boundp ',sym) ,sym)))
+ (let ((*print-readably* nil)
+ (*print-level* (or (true *print-level*) 6))
+ (*print-length* (or (true *print-length*) 12)))
+ (funcall function))))
+
+;;; Returns a list of members of LIST. Useful for dealing with circular lists.
+;;; For a dotted list returns a secondary value of T -- in which case the
+;;; primary return value does not include the dotted tail.
+(defun list-members (list)
+ (when list
+ (do ((tail (cdr list) (cdr tail))
+ (members (list (car list)) (cons (car tail) members)))
+ ((or (not (consp tail)) (eq tail list))
+ (values members (not (listp tail)))))))
+
+;;; Default evaluator mode (interpeter / compiler)
+
+(declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*))
+(defparameter *evaluator-mode* :compile
+ #!+sb-doc
+ "Toggle between different evaluator implementations. If set to :COMPILE,
+an implementation of EVAL that calls the compiler will be used. If set
+to :INTERPRET, an interpreter will be used.")
+
+;;; Helper for making the DX closure allocation in macros expanding
+;;; to CALL-WITH-FOO less ugly.
+(defmacro dx-flet (functions &body forms)
+ `(flet ,functions
+ (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
+ ,@(mapcar (lambda (func) `(function ,(car func))) functions)))
+ ,@forms))
+
+;;; Another similar one.
+(defmacro dx-let (bindings &body forms)
+ `(let ,bindings
+ (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
+ ,@(mapcar (lambda (bind) (if (consp bind) (car bind) bind))
+ bindings)))
+ ,@forms))
+
+(in-package "SB!KERNEL")
+
+(defun fp-zero-p (x)
+ (typecase x
+ (single-float (zerop x))
+ (double-float (zerop x))
+ #!+long-float
+ (long-float (zerop x))
+ (t nil)))
+
+(defun neg-fp-zero (x)
+ (etypecase x
+ (single-float
+ (if (eql x 0.0f0)
+ (make-unportable-float :single-float-negative-zero)
+ 0.0f0))
+ (double-float
+ (if (eql x 0.0d0)
+ (make-unportable-float :double-float-negative-zero)
+ 0.0d0))
+ #!+long-float
+ (long-float
+ (if (eql x 0.0l0)
+ (make-unportable-float :long-float-negative-zero)
+ 0.0l0))))