+
+;;; 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))))
+
+;;; 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.
+;;;
+;;; This expands to something like
+;;;
+;;; (flet ((foo (...) <body-of-foo>))
+;;; (declare (optimize stack-allocate-dynamic-extent))
+;;; (flet ((foo (...)
+;;; (foo ...))
+;;; (declare (dynamic-extent #'foo))
+;;; <body-of-dx-flet>)))
+;;;
+;;; The outer FLETs are inlined into the inner ones, and the inner ones
+;;; are DX-allocated. The double-fletting is done to keep the bodies of
+;;; the functions in an environment with correct policy: we don't want
+;;; to force DX allocation in their bodies, which would be bad eg.
+;;; in safe code.
+(defmacro dx-flet (functions &body forms)
+ (let ((names (mapcar #'car functions)))
+ `(flet ,functions
+ #-sb-xc-host
+ (declare (optimize sb!c::stack-allocate-dynamic-extent))
+ (flet ,(mapcar
+ (lambda (f)
+ (let ((args (cadr f))
+ (name (car f)))
+ (when (intersection args lambda-list-keywords)
+ ;; No fundamental reason not to support them, but we
+ ;; don't currently need them here.
+ (error "Non-required arguments not implemented for DX-FLET."))
+ `(,name ,args
+ (,name ,@args))))
+ functions)
+ (declare (dynamic-extent ,@(mapcar (lambda (x) `(function ,x)) names)))
+ ,@forms))))
+
+;;; Another similar one -- but actually touches the policy of the body,
+;;; so take care with this one...
+(defmacro dx-let (bindings &body forms)
+ `(locally
+ #-sb-xc-host
+ (declare (optimize sb!c::stack-allocate-dynamic-extent))
+ (let ,bindings
+ (declare (dynamic-extent ,@(mapcar (lambda (bind)
+ (if (consp bind)
+ (car bind)
+ bind))
+ bindings)))
+ ,@forms)))
+