+;;; Return a function like FUN, but expecting its (two) arguments in
+;;; the opposite order that FUN does.
+(declaim (inline swapped-args-fun))
+(defun swapped-args-fun (fun)
+ (declare (type function fun))
+ (lambda (x y)
+ (funcall fun y x)))
+
+;;; Return the numeric value of a type bound, i.e. an interval bound
+;;; more or less in the format of bounds in ANSI's type specifiers,
+;;; where a bare numeric value is a closed bound and a list of a
+;;; single numeric value is an open bound.
+;;;
+;;; The "more or less" bit is that the no-bound-at-all case is
+;;; represented by NIL (not by * as in ANSI type specifiers); and in
+;;; this case we return NIL.
+(defun type-bound-number (x)
+ (if (consp x)
+ (destructuring-bind (result) x result)
+ x))
+
+;;; some commonly-occuring CONSTANTLY forms
+(macrolet ((def-constantly-fun (name constant-expr)
+ `(setf (symbol-function ',name)
+ (constantly ,constant-expr))))
+ (def-constantly-fun constantly-t t)
+ (def-constantly-fun constantly-nil nil)
+ (def-constantly-fun constantly-0 0))
+
+;;; If X is a symbol, see whether it is present in *FEATURES*. Also
+;;; handle arbitrary combinations of atoms using NOT, AND, OR.
+(defun featurep (x)
+ (etypecase x
+ (cons
+ (case (car x)
+ ((:not not)
+ (cond
+ ((cddr x)
+ (error "too many subexpressions in feature expression: ~S" x))
+ ((null (cdr x))
+ (error "too few subexpressions in feature expression: ~S" x))
+ (t (not (featurep (cadr x))))))
+ ((:and and) (every #'featurep (cdr x)))
+ ((:or or) (some #'featurep (cdr x)))
+ (t
+ (error "unknown operator in feature expression: ~S." x))))
+ (symbol (not (null (memq x *features*))))))
+\f
+;;;; utilities for two-VALUES predicates
+
+(defmacro not/type (x)
+ (let ((val (gensym "VAL"))
+ (win (gensym "WIN")))
+ `(multiple-value-bind (,val ,win)
+ ,x
+ (if ,win
+ (values (not ,val) t)
+ (values nil nil)))))
+
+(defmacro and/type (x y)
+ `(multiple-value-bind (val1 win1) ,x
+ (if (and (not val1) win1)
+ (values nil t)
+ (multiple-value-bind (val2 win2) ,y
+ (if (and val1 val2)
+ (values t t)
+ (values nil (and win2 (not val2))))))))
+
+;;; sort of like ANY and EVERY, except:
+;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
+;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
+;;; as SUBTYPEP does.)
+;;; * THING is just an atom, and we apply OP (an arity-2 function)
+;;; successively to THING and each element of LIST.
+(defun any/type (op thing list)
+ (declare (type function op))
+ (let ((certain? t))
+ (dolist (i list (values nil certain?))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (when sub-value (return (values t t)))
+ (setf certain? nil))))))
+(defun every/type (op thing list)
+ (declare (type function op))
+ (let ((certain? t))
+ (dolist (i list (if certain? (values t t) (values nil nil)))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (unless sub-value (return (values nil t)))
+ (setf certain? nil))))))
+\f
+;;;; DEFPRINTER
+
+;;; These functions are called by the expansion of the DEFPRINTER
+;;; macro to do the actual printing.
+(declaim (ftype (function (symbol t stream) (values))
+ defprinter-prin1 defprinter-princ))
+(defun defprinter-prin1 (name value stream)
+ (defprinter-prinx #'prin1 name value stream))
+(defun defprinter-princ (name value stream)
+ (defprinter-prinx #'princ name value stream))
+(defun defprinter-prinx (prinx name value stream)
+ (declare (type function prinx))
+ (when *print-pretty*
+ (pprint-newline :linear stream))
+ (format stream ":~A " name)
+ (funcall prinx value stream)
+ (values))
+(defun defprinter-print-space (stream)
+ (write-char #\space stream))
+
+;;; Define some kind of reasonable PRINT-OBJECT method for a
+;;; STRUCTURE-OBJECT class.
+;;;
+;;; NAME is the name of the structure class, and CONC-NAME is the same
+;;; as in DEFSTRUCT.
+;;;
+;;; The SLOT-DESCS describe how each slot should be printed. Each
+;;; SLOT-DESC can be a slot name, indicating that the slot should
+;;; simply be printed. A SLOT-DESC may also be a list of a slot name
+;;; and other stuff. The other stuff is composed of keywords followed
+;;; by expressions. The expressions are evaluated with the variable
+;;; which is the slot name bound to the value of the slot. These
+;;; keywords are defined:
+;;;
+;;; :PRIN1 Print the value of the expression instead of the slot value.
+;;; :PRINC Like :PRIN1, only PRINC the value
+;;; :TEST Only print something if the test is true.
+;;;
+;;; If no printing thing is specified then the slot value is printed
+;;; as if by PRIN1.
+;;;
+;;; The structure being printed is bound to STRUCTURE and the stream
+;;; is bound to STREAM.
+(defmacro defprinter ((name
+ &key
+ (conc-name (concatenate 'simple-string
+ (symbol-name name)
+ "-"))
+ identity)
+ &rest slot-descs)
+ (let ((first? t)
+ maybe-print-space
+ (reversed-prints nil)
+ (stream (gensym "STREAM")))
+ (flet ((sref (slot-name)
+ `(,(symbolicate conc-name slot-name) structure)))
+ (dolist (slot-desc slot-descs)
+ (if first?
+ (setf maybe-print-space nil
+ first? nil)
+ (setf maybe-print-space `(defprinter-print-space ,stream)))
+ (cond ((atom slot-desc)
+ (push maybe-print-space reversed-prints)
+ (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
+ reversed-prints))
+ (t
+ (let ((sname (first slot-desc))
+ (test t))
+ (collect ((stuff))
+ (do ((option (rest slot-desc) (cddr option)))
+ ((null option)
+ (push `(let ((,sname ,(sref sname)))
+ (when ,test
+ ,maybe-print-space
+ ,@(or (stuff)
+ `((defprinter-prin1
+ ',sname ,sname ,stream)))))
+ reversed-prints))
+ (case (first option)
+ (:prin1
+ (stuff `(defprinter-prin1
+ ',sname ,(second option) ,stream)))
+ (:princ
+ (stuff `(defprinter-princ
+ ',sname ,(second option) ,stream)))
+ (:test (setq test (second option)))
+ (t
+ (error "bad option: ~S" (first option)))))))))))
+ `(def!method print-object ((structure ,name) ,stream)
+ (pprint-logical-block (,stream nil)
+ (print-unreadable-object (structure
+ ,stream
+ :type t
+ :identity ,identity)
+ ,@(nreverse reversed-prints))))))
+\f
+;;;; etc.
+
+;;; Given a pathname, return a corresponding physical pathname.
+(defun physicalize-pathname (possibly-logical-pathname)
+ (if (typep possibly-logical-pathname 'logical-pathname)
+ (translate-logical-pathname possibly-logical-pathname)
+ possibly-logical-pathname))
+
+(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)))
+
+;;; 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))))