X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=d52a0dc0a1fd8e0f173fcd52db91532575438c78;hb=6d3b9d5de8a28cd92e280f3451b60ce412260c19;hp=bfe8451270e3ff520c109dbdf867753fcaff117e;hpb=7137cb0872e17772f26c432384da5eefa3e645d7;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index bfe8451..d52a0dc 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -434,17 +434,24 @@
             (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)))))
 
 ;;;; hash cache utility
 
@@ -1257,3 +1264,28 @@ to :INTERPRET, an interpreter will be used.")
                                           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))))