X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=9337589f49831d2055564f073f2ab5f8f75d06f0;hb=b1cd84e0503ff29d72a860ea1709c87f721412ed;hp=65f98d72c0e19892034ee2dd8d12cc13d95fc2af;hpb=e87722978bc9993cc5a862964366ee7cd0b7fb4c;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 65f98d7..9337589 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -377,8 +377,8 @@
 
 ;;; 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)
@@ -395,11 +395,12 @@
 
 ;;;; 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)))
@@ -433,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
 
@@ -920,23 +928,24 @@
   (def-constantly-fun constantly-nil nil)
   (def-constantly-fun constantly-0 0))
 
-;;; If X is an atom, see whether it is present in *FEATURES*. Also
+;;; 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)
-  (if (consp x)
-      (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)))
-      (not (null (memq x *features*)))))
+  (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*))))))
 
 ;;;; utilities for two-VALUES predicates