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

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index bfe8451..341c69b 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -102,7 +102,7 @@
                       ((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)))
@@ -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
 
@@ -748,38 +755,47 @@
               (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) ..))
@@ -827,9 +843,9 @@
           (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))))))))
 
@@ -1198,6 +1214,16 @@
           (*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*))
@@ -1209,51 +1235,42 @@ to :INTERPRET, an interpreter will be used.")
 
 ;;; 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))))