((or (atom result)
(not (eq (car result) 'values)))
`(values ,result &optional))
- ((intersection (cdr result) lambda-list-keywords)
+ ((intersection (cdr result) sb!xc:lambda-list-keywords)
result)
(t `(values ,@(cdr result) &optional)))))
`(function ,args ,result)))
;;; 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
+;;; order as in all the other indexed 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)
\f
;;;; miscellaneous iteration extensions
-;;; "the ultimate iteration macro"
+;;; like Scheme's named LET
;;;
-;;; note for Schemers: This seems to be identical to Scheme's "named LET".
+;;; (CMU CL called this ITERATE, and commented it as "the ultimate
+;;; iteration macro...". I (WHN) found the old name insufficiently
+;;; specific to remind me what the macro means, so I renamed it.)
(defmacro named-let (name binds &body body)
- #!+sb-doc
(dolist (x binds)
(unless (proper-list-of-length-p x 2)
(error "malformed NAMED-LET variable spec: ~S" x)))
(tagbody
,@forms)))))))
-;;; Iterate over the entries in a HASH-TABLE.
-(defmacro dohash ((key-var value-var table &optional result) &body body)
+;;; Iterate over the entries in a HASH-TABLE, first obtaining the lock
+;;; if the table is a synchronized table.
+(defmacro dohash (((key-var value-var) table &key result locked) &body body)
(multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
- (let ((gen (gensym))
- (n-more (gensym)))
- `(with-hash-table-iterator (,gen ,table)
- (loop
- (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
- ,@decls
- (unless ,n-more (return ,result))
- ,@forms))))))
+ (let* ((gen (gensym))
+ (n-more (gensym))
+ (n-table (gensym))
+ (iter-form `(with-hash-table-iterator (,gen ,n-table)
+ (loop
+ (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
+ ,@decls
+ (unless ,n-more (return ,result))
+ ,@forms)))))
+ `(let ((,n-table ,table))
+ ,(if locked
+ `(with-locked-hash-table (,n-table)
+ ,iter-form)
+ iter-form)))))
\f
;;;; hash cache utility
(char= #\* (aref name 0))
(char= #\* (aref name (1- (length name))))))))
-;;; 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)
- "Veritas aeterna. (can't change T)")
- ((eq symbol nil)
- "Nihil ex nihil. (can't change NIL)")
- ((keywordp symbol)
- "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.)
+;;; 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 to constants are given as undefined behavior,
+;;; it's nice to do so. To circumvent this you need code like this:
+;;;
+;;; (defvar foo)
+;;; (defun set-foo (x) (setq foo x))
+;;; (defconstant foo 42)
+;;; (set-foo 13)
+;;; foo => 13, (constantp 'foo) => t
+;;;
+;;; ...in which case you frankly deserve to lose.
+(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep))
+ (declare (symbol symbol))
+ (multiple-value-bind (what continue)
+ (when (eq :constant (info :variable :kind symbol))
+ (cond ((eq symbol t)
+ (values "Veritas aeterna. (can't ~@?)" nil))
+ ((eq symbol nil)
+ (values "Nihil ex nihil. (can't ~@?)" nil))
+ ((keywordp symbol)
+ (values "Can't ~@?." nil))
+ (t
+ (values "Constant modification: attempt to ~@?." t))))
+ (when what
+ (if continue
+ (cerror "Modify the constant." what action symbol)
+ (error what action symbol)))
+ (when valuep
+ ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
+ ;; check.
+ (let ((type (info :variable :type symbol)))
+ (unless (sb!kernel::%%typep new-value type)
+ (let ((spec (type-specifier type)))
+ (error 'simple-type-error
+ :format-control "Cannot ~@? to ~S (not of type ~S.)"
+ :format-arguments (list action symbol new-value spec)
+ :datum new-value
+ :expected-type spec))))))
(values))
-
;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
;;; assignment instead of doing cold static linking. That way things like
;;; (FLET ((FROB (X) ..))
(unless (proper-list-of-length-p spec 2)
(error "malformed ONCE-ONLY binding spec: ~S" spec))
(let* ((name (first spec))
- (exp-temp (gensym (symbol-name name))))
+ (exp-temp (gensym "ONCE-ONLY")))
`(let ((,exp-temp ,(second spec))
- (,name (gensym "ONCE-ONLY-")))
+ (,name (gensym ,(symbol-name name))))
`(let ((,,name ,,exp-temp))
,,(frob (rest specs) body))))))))
\f
(*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*))
;;; 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...
+ `(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)
- `(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)))
+ `(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))))
projects / sbcl.git / blobdiff