(in-package "SB!IMPL")
-;;; Lots of code wants to get to the KEYWORD package or the
-;;; COMMON-LISP package without a lot of fuss, so we cache them in
-;;; variables. TO DO: How much does this actually buy us? It sounds
-;;; sensible, but I don't know for sure that it saves space or time..
-;;; -- WHN 19990521
-;;;
-;;; (The initialization forms here only matter on the cross-compilation
-;;; host; In the target SBCL, these variables are set in cold init.)
-(declaim (type package *cl-package* *keyword-package*))
-(defvar *cl-package* (find-package "COMMON-LISP"))
-(defvar *keyword-package* (find-package "KEYWORD"))
-
;;; something not EQ to anything we might legitimately READ
(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
;;; index leaving the loop range)
(def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
+;;; A couple of VM-related types that are currently used only on the
+;;; alpha platform. -- CSR, 2002-06-24
+(def!type unsigned-byte-with-a-bite-out (s bite)
+ (cond ((eq s '*) 'integer)
+ ((and (integerp s) (> s 0))
+ (let ((bound (ash 1 s)))
+ `(integer 0 ,(- bound bite 1))))
+ (t
+ (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s))))
+
+;;; Motivated by the mips port. -- CSR, 2002-08-22
+(def!type signed-byte-with-a-bite-out (s bite)
+ (cond ((eq s '*) 'integer)
+ ((and (integerp s) (> s 1))
+ (let ((bound (ash 1 (1- s))))
+ `(integer ,(- bound) ,(- bound bite 1))))
+ (t
+ (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+
+(def!type load/store-index (scale lowtag min-offset
+ &optional (max-offset min-offset))
+ `(integer ,(- (truncate (+ (ash 1 16)
+ (* min-offset sb!vm:n-word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+ (* max-offset sb!vm:n-word-bytes))
+ scale)))
+
+;;; Similar to FUNCTION, but the result type is "exactly" specified:
+;;; if it is an object type, then the function returns exactly one
+;;; value, if it is a short form of VALUES, then this short form
+;;; specifies the exact number of values.
+(def!type sfunction (args &optional result)
+ (let ((result (cond ((eq result '*) '*)
+ ((or (atom result)
+ (not (eq (car result) 'values)))
+ `(values ,result &optional))
+ ((intersection (cdr result) lambda-list-keywords)
+ result)
+ (t `(values ,@(cdr result) &optional)))))
+ `(function ,args ,result)))
+
+;;; a type specifier
+;;;
+;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS.
+;;; However, the CL:CLASS type is only defined once PCL is loaded,
+;;; which is before this is evaluated. Once PCL is moved into cold
+;;; init, this might be fixable.
+(def!type type-specifier () '(or list symbol sb!kernel:instance))
+
;;; the default value used for initializing character data. The ANSI
-;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
-;;; because it's not in the ANSI table of portable characters.
-(defconstant default-init-char #\space)
+;;; spec says this is arbitrary, so we use the value that falls
+;;; through when we just let the low-level consing code initialize
+;;; all newly-allocated memory to zero.
+;;;
+;;; KLUDGE: It might be nice to use something which is a
+;;; STANDARD-CHAR, both to reduce user surprise a little and, probably
+;;; more significantly, to help SBCL's cross-compiler (which knows how
+;;; to dump STANDARD-CHARs). Unfortunately, the old CMU CL code is
+;;; shot through with implicit assumptions that it's #\NULL, and code
+;;; in several places (notably both DEFUN MAKE-ARRAY and DEFTRANSFORM
+;;; MAKE-ARRAY) would have to be rewritten. -- WHN 2001-10-04
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; an expression we can use to construct a DEFAULT-INIT-CHAR value
+ ;; at load time (so that we don't need to teach the cross-compiler
+ ;; how to represent and dump non-STANDARD-CHARs like #\NULL)
+ (defparameter *default-init-char-form* '(code-char 0)))
;;; CHAR-CODE values for ASCII characters which we care about but
;;; which aren't defined in section "2.1.3 Standard Characters" of the
;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
;;; (or just find a nicer way of expressing characters portably?) --
;;; WHN 19990713
-(defconstant bell-char-code 7)
-(defconstant tab-char-code 9)
-(defconstant form-feed-char-code 12)
-(defconstant return-char-code 13)
-(defconstant escape-char-code 27)
-(defconstant rubout-char-code 127)
+(def!constant bell-char-code 7)
+(def!constant backspace-char-code 8)
+(def!constant tab-char-code 9)
+(def!constant line-feed-char-code 10)
+(def!constant form-feed-char-code 12)
+(def!constant return-char-code 13)
+(def!constant escape-char-code 27)
+(def!constant rubout-char-code 127)
\f
;;;; type-ish predicates
-;;; a helper function for various macros which expect clauses of a
-;;; given length, etc.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; Return true if X is a proper list whose length is between MIN and
- ;; MAX (inclusive).
- (defun proper-list-of-length-p (x min &optional (max min))
- ;; FIXME: This implementation will hang on circular list
- ;; structure. Since this is an error-checking utility, i.e. its
- ;; job is to deal with screwed-up input, it'd be good style to fix
- ;; it so that it can deal with circular list structure.
- (cond ((minusp max)
- nil)
- ((null x)
- (zerop min))
- ((consp x)
- (and (plusp max)
- (proper-list-of-length-p (cdr x)
- (if (plusp (1- min))
- (1- min)
- 0)
- (1- max))))
- (t nil))))
-
-;;; Is X a circular list?
-(defun circular-list-p (x)
+;;; Is X a list containing a cycle?
+(defun cyclic-list-p (x)
(and (listp x)
(labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
(do ((y x (safe-cddr y))
(and (consp x)
(list-of-length-at-least-p (cdr x) (1- n)))))
+(declaim (inline singleton-p))
+(defun singleton-p (list)
+ (and (consp list)
+ (null (rest list))))
+
;;; Is X is a positive prime integer?
(defun positive-primep (x)
;; This happens to be called only from one place in sbcl-0.7.0, and
((or (= r 0) (> d q)) (/= r 0))
(declare (fixnum inc))
(multiple-value-setq (q r) (truncate x d))))))
+
+;;; Could this object contain other objects? (This is important to
+;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
+(defun compound-object-p (x)
+ (or (consp x)
+ (typep x 'instance)
+ (typep x '(array t *))))
\f
;;;; the COLLECT macro
;;;;
;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
;;; is the pointer to the current tail of the list, or NIL if the list
;;; is empty.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun collect-normal-expander (n-value fun forms)
`(progn
,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
;;; the function is made the new value for the collection. As a
;;; totally magical special-case, FUNCTION may be COLLECT, which tells
;;; us to build a list in forward order; this is the default. If an
-;;; INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd
+;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd
;;; onto the end. Note that FUNCTION may be anything that can appear
;;; in the functional position, including macros and lambdas.
(defmacro collect (collections &body body)
(binds ()))
(dolist (spec collections)
(unless (proper-list-of-length-p spec 1 3)
- (error "malformed collection specifier: ~S." spec))
+ (error "malformed collection specifier: ~S" spec))
(let* ((name (first spec))
(default (second spec))
(kind (or (third spec) 'collect))
;;; like (MEMBER ITEM LIST :TEST #'EQ)
(defun memq (item list)
#!+sb-doc
- "Returns tail of LIST beginning with first element EQ to ITEM."
+ "Return tail of LIST beginning with first element EQ to ITEM."
;; KLUDGE: These could be and probably should be defined as
;; (MEMBER ITEM LIST :TEST #'EQ)),
;; but when I try to cross-compile that, I get an error from
;; just define ASSQ explicitly in terms of more primitive
;; operations:
(dolist (pair alist)
- (when (eq (car pair) item)
+ ;; though it may look more natural to write this as
+ ;; (AND PAIR (EQ (CAR PAIR) ITEM))
+ ;; the temptation to do so should be resisted, as pointed out by PFD
+ ;; sbcl-devel 2003-08-16, as NIL elements are rare in association
+ ;; lists. -- CSR, 2003-08-16
+ (when (and (eq (car pair) item) (not (null pair)))
(return pair))))
;;; like (DELETE .. :TEST #'EQ):
(declaim (inline neq))
(defun neq (x y)
(not (eq x y)))
+
+;;; not really an old-fashioned function, but what the calling
+;;; convention should've been: like NTH, but with the same argument
+;;; order as in all the other dereferencing functions, with the
+;;; collection first and the index second
+(declaim (inline nth-but-with-sane-arg-order))
+(declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
+(defun nth-but-with-sane-arg-order (list index)
+ (nth index list))
+
+(defun adjust-list (list length initial-element)
+ (let ((old-length (length list)))
+ (cond ((< old-length length)
+ (append list (make-list (- length old-length)
+ :initial-element initial-element)))
+ ((> old-length length)
+ (subseq list 0 length))
+ (t list))))
\f
;;;; miscellaneous iteration extensions
-;;; "the ultimate iteration macro"
+;;; "the ultimate iteration macro"
;;;
;;; note for Schemers: This seems to be identical to Scheme's "named LET".
(defmacro named-let (name binds &body body)
;;; Iterate over the entries in a HASH-TABLE.
(defmacro dohash ((key-var value-var table &optional result) &body body)
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(let ((gen (gensym))
(n-more (gensym)))
`(with-hash-table-iterator (,gen ,table)
;;; The code for initializing the cache is wrapped in a form with
;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
;;; in type system definitions so that caches will be created
-;;; before top-level forms run.)
+;;; before top level forms run.)
(defmacro define-hash-cache (name args &key hash-function hash-bits default
(init-wrapper 'progn)
(values 1))
(n-cache (gensym)))
(unless (= (length default-values) values)
- (error "The number of default values ~S differs from :VALUES ~D."
+ (error "The number of default values ~S differs from :VALUES ~W."
default values))
(collect ((inlines)
(,n-cache ,var-name))
(declare (type fixnum ,n-index))
,@(sets)
- ,@(mapcar #'(lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
+ ,@(mapcar (lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
(values-indices)
(values-names))
(values)))))
(dotimes (i nargs)
(arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
(arg-sets))
- ,@(mapcar #'(lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
+ ,@(mapcar (lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
(values-indices)
default-values))
(values)))
,@(values-names))
(values ,@(values-names)))
(values ,@(values-names))))))))))))
+
+(defmacro define-cached-synonym
+ (name &optional (original (symbolicate "%" name)))
+ (let ((cached-name (symbolicate "%%" name "-cached")))
+ `(progn
+ (defun-cached (,cached-name :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((args equal))
+ (apply #',original args))
+ (defun ,name (&rest args)
+ (,cached-name args)))))
+
+;;; FIXME: maybe not the best place
+;;;
+;;; FIXME: think of a better name -- not only does this not have the
+;;; CAR recursion of EQUAL, it also doesn't have the special treatment
+;;; of pathnames, bit-vectors and strings.
+;;;
+;;; KLUDGE: This means that we will no longer cache specifiers of the
+;;; form '(INTEGER (0) 4). This is probably not a disaster.
+;;;
+;;; A helper function for the type system, which is the main user of
+;;; these caches: we must be more conservative than EQUAL for some of
+;;; our equality tests, because MEMBER and friends refer to EQLity.
+;;; So:
+(defun equal-but-no-car-recursion (x y)
+ (cond
+ ((eql x y) t)
+ ((consp x)
+ (and (consp y)
+ (eql (car x) (car y))
+ (equal-but-no-car-recursion (cdr x) (cdr y))))
+ (t nil)))
\f
;;;; package idioms
;;;; various operations on names
;;; Is NAME a legal function name?
-(defun legal-function-name-p (name)
- (or (symbolp name)
- (and (consp name)
- (eq (car name) 'setf)
- (consp (cdr name))
- (symbolp (cadr name))
- (null (cddr name)))))
-
-;;; Given a function name, return the name for the BLOCK which
-;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
-(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
-(defun function-name-block-name (function-name)
- (cond ((symbolp function-name)
- function-name)
- ((and (consp function-name)
- (= (length function-name) 2)
- (eq (first function-name) 'setf))
- (second function-name))
+(defun legal-fun-name-p (name)
+ (values (valid-function-name-p name)))
+
+;;; Signal an error unless NAME is a legal function name.
+(defun legal-fun-name-or-type-error (name)
+ (unless (legal-fun-name-p name)
+ (error 'simple-type-error
+ :datum name
+ :expected-type '(or symbol list)
+ :format-control "invalid function name: ~S"
+ :format-arguments (list name))))
+
+;;; Given a function name, return the symbol embedded in it.
+;;;
+;;; The ordinary use for this operator (and the motivation for the
+;;; name of this operator) is to convert from a function name to the
+;;; name of the BLOCK which encloses its body.
+;;;
+;;; Occasionally the operator is useful elsewhere, where the operator
+;;; name is less mnemonic. (Maybe it should be changed?)
+(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name))
+(defun fun-name-block-name (fun-name)
+ (cond ((symbolp fun-name)
+ fun-name)
+ ((consp fun-name)
+ (multiple-value-bind (legalp block-name)
+ (valid-function-name-p fun-name)
+ (if legalp
+ block-name
+ (error "not legal as a function name: ~S" fun-name))))
(t
- (error "not legal as a function name: ~S" function-name))))
+ (error "not legal as a function name: ~S" fun-name))))
(defun looks-like-name-of-special-var-p (x)
(and (symbolp x)
(char= #\* (aref name 0))
(char= #\* (aref name (1- (length name))))))))
-;;; ANSI guarantees that some symbols are self-evaluating. This
-;;; function is to be called just before a change which would affect
-;;; that. (We don't absolutely have to call this function before such
-;;; changes, since such changes are given as undefined behavior. In
-;;; particular, we don't if the runtime cost would be annoying. But
-;;; otherwise it's nice to do so.)
-(defun about-to-modify (symbol)
+;;; Some symbols are defined by ANSI to be self-evaluating. Return
+;;; non-NIL for such symbols (and make the non-NIL value a traditional
+;;; message, for use in contexts where the user asks us to change such
+;;; a symbol).
+(defun symbol-self-evaluating-p (symbol)
(declare (type symbol symbol))
(cond ((eq symbol t)
- (error "Veritas aeterna. (can't change T)"))
+ "Veritas aeterna. (can't change T)")
((eq symbol nil)
- (error "Nihil ex nihil. (can't change NIL)"))
+ "Nihil ex nihil. (can't change NIL)")
((keywordp symbol)
- (error "Keyword values can't be changed."))
- ;; (Just because a value is CONSTANTP is not a good enough
- ;; reason to complain here, because we want DEFCONSTANT to
- ;; be able to use this function, and it's legal to DEFCONSTANT
- ;; a constant as long as the new value is EQL to the old
- ;; value.)
- ))
+ "Keyword values can't be changed.")
+ (t
+ nil)))
+
+;;; This function is to be called just before a change which would
+;;; affect the symbol value. (We don't absolutely have to call this
+;;; function before such changes, since such changes are given as
+;;; undefined behavior. In particular, we don't if the runtime cost
+;;; would be annoying. But otherwise it's nice to do so.)
+(defun about-to-modify-symbol-value (symbol)
+ (declare (type symbol symbol))
+ (let ((reason (symbol-self-evaluating-p symbol)))
+ (when reason
+ (error reason)))
+ ;; (Note: Just because a value is CONSTANTP is not a good enough
+ ;; reason to complain here, because we want DEFCONSTANT to be able
+ ;; to use this function, and it's legal to DEFCONSTANT a constant as
+ ;; long as the new value is EQL to the old value.)
+ (values))
+
;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
-;;; assignment. That way things like
+;;; assignment instead of doing cold static linking. That way things like
;;; (FLET ((FROB (X) ..))
;;; (DEFUN FOO (X Y) (FROB X) ..)
;;; (DEFUN BAR (Z) (AND (FROB X) ..)))
"~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
(SETF FDEFINITION)~:@>"
name)
- `(setf (fdefinition ',name) ,lambda))
+ ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA
+ ;; expression so that the compiler can use NAME in debug names etc.
+ (destructuring-bind (lambda-symbol &rest lambda-rest) lambda
+ (assert (eql lambda-symbol 'lambda)) ; else dunno how to do conversion
+ `(setf (fdefinition ',name)
+ (named-lambda ,name ,@lambda-rest))))
\f
;;;; ONCE-ONLY
;;;;
;;; error indicating that a required &KEY argument was not supplied.
;;; This function is also useful for DEFSTRUCT slot defaults
;;; corresponding to required arguments.
-(declaim (ftype (function () nil) required-argument))
-(defun required-argument ()
+(declaim (ftype (function () nil) missing-arg))
+(defun missing-arg ()
#!+sb-doc
- (/show0 "entering REQUIRED-ARGUMENT")
- (error "A required &KEY argument was not supplied."))
+ (/show0 "entering MISSING-ARG")
+ (error "A required &KEY or &OPTIONAL argument was not supplied."))
;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
;;;
;;; guts of complex systems anyway, I replaced it too.)
(defmacro aver (expr)
`(unless ,expr
- (%failed-aver ,(let ((*package* (find-package :keyword)))
- (format nil "~S" expr)))))
+ (%failed-aver ,(format nil "~A" expr))))
+
(defun %failed-aver (expr-as-string)
- (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
+ (bug "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
+
+;;; We need a definition of BUG here for the host compiler to be able
+;;; to deal with BUGs in sbcl. This should never affect an end-user,
+;;; who will pick up the definition that signals a CONDITION of
+;;; condition-class BUG; however, this is not defined on the host
+;;; lisp, but for the target. SBCL developers sometimes trigger BUGs
+;;; in their efforts, and it is useful to get the details of the BUG
+;;; rather than an undefined function error. - CSR, 2002-04-12
+#+sb-xc-host
+(defun bug (format-control &rest format-arguments)
+ (error 'simple-error
+ :format-control "~@< ~? ~:@_~?~:>"
+ :format-arguments `(,format-control
+ ,format-arguments
+ "~@<If you see this and are an SBCL ~
+developer, then it is probable that you have made a change to the ~
+system that has broken the ability for SBCL to compile, usually by ~
+removing an assumed invariant of the system, but sometimes by making ~
+an averrance that is violated (check your code!). If you are a user, ~
+please submit a bug report to the developers' mailing list, details of ~
+which can be found at <http://sbcl.sourceforge.net/>.~:@>"
+ ())))
+
(defmacro enforce-type (value type)
(once-only ((value value))
`(unless (typep ,value ',type)
(%failed-enforce-type ,value ',type))))
+
(defun %failed-enforce-type (value type)
- (error 'simple-type-error
+ (error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG?
:value value
:expected-type type
- :format-string "~@<~S ~_is not a ~_~S~:>"
+ :format-control "~@<~S ~_is not a ~_~S~:>"
:format-arguments (list value type)))
\f
-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
- (loop repeat n collect (gensym)))
-
;;; Return a function like FUN, but expecting its (two) arguments in
;;; the opposite order that FUN does.
(declaim (inline swapped-args-fun))
\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),
(t
(error "bad option: ~S" (first option)))))))))))
`(def!method print-object ((structure ,name) ,stream)
- ;; FIXME: should probably be byte-compiled
(pprint-logical-block (,stream nil)
(print-unreadable-object (structure
,stream
(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* ({(name 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
+ (values names nil)))
+ (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)))
projects / sbcl.git / blobdiff