1.0.6.30: clean up FD-SOUT a little bit

[sbcl.git] / src / code / early-extensions.lisp

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 4514057..c3f2474 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -30,6 +30,10 @@
 ;;; bound because ANSI specifies it as an exclusive bound.)
 (def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
 
+;;; like INDEX, but only up to half the maximum. Used by hash-table
+;;; code that does plenty to (aref v (* 2 i)) and (aref v (1+ (* 2 i))).
+(def!type index/2 () `(integer 0 (,(floor sb!xc:array-dimension-limit 2))))
+
 ;;; like INDEX, but augmented with -1 (useful when using the index
 ;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with
 ;;; an implementation which terminates the loop by testing for the
@@ -65,6 +69,30 @@
                           (* max-offset sb!vm:n-word-bytes))
                        scale)))
 
+#!+(or x86 x86-64)
+(defun displacement-bounds (lowtag element-size data-offset)
+  (let* ((adjustment (- (* data-offset sb!vm:n-word-bytes) lowtag))
+         (bytes-per-element (ceiling element-size sb!vm:n-byte-bits))
+         (min (truncate (+ sb!vm::minimum-immediate-offset adjustment)
+                        bytes-per-element))
+         (max (truncate (+ sb!vm::maximum-immediate-offset adjustment)
+                        bytes-per-element)))
+    (values min max)))
+
+#!+(or x86 x86-64)
+(def!type constant-displacement (lowtag element-size data-offset)
+  (flet ((integerify (x)
+           (etypecase x
+             (integer x)
+             (symbol (symbol-value x)))))
+    (let ((lowtag (integerify lowtag))
+          (element-size (integerify element-size))
+          (data-offset (integerify data-offset)))
+      (multiple-value-bind (min max) (displacement-bounds lowtag
+                                                          element-size
+                                                          data-offset)
+        `(integer ,min ,max)))))
+
 ;;; 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
@@ -378,18 +406,32 @@
   `(labels ((,name ,(mapcar #'first binds) ,@body))
      (,name ,@(mapcar #'second binds))))
 
+(defun filter-dolist-declarations (decls)
+  (mapcar (lambda (decl)
+            `(declare ,@(remove-if
+                         (lambda (clause)
+                           (and (consp clause)
+                                (or (eq (car clause) 'type)
+                                    (eq (car clause) 'ignore))))
+                         (cdr decl))))
+          decls))
+
 ;;; just like DOLIST, but with one-dimensional arrays
-(defmacro dovector ((elt vector &optional result) &rest forms)
-  (let ((index (gensym))
-        (length (gensym))
-        (vec (gensym)))
-    `(let ((,vec ,vector))
-       (declare (type vector ,vec))
-       (do ((,index 0 (1+ ,index))
-            (,length (length ,vec)))
-           ((>= ,index ,length) ,result)
-         (let ((,elt (aref ,vec ,index)))
-           ,@forms)))))
+(defmacro dovector ((elt vector &optional result) &body body)
+  (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+    (with-unique-names (index length vec)
+      `(let ((,vec ,vector))
+        (declare (type vector ,vec))
+        (do ((,index 0 (1+ ,index))
+             (,length (length ,vec)))
+            ((>= ,index ,length) (let ((,elt nil))
+                                   ,@(filter-dolist-declarations decls)
+                                   ,elt
+                                   ,result))
+          (let ((,elt (aref ,vec ,index)))
+            ,@decls
+            (tagbody
+               ,@forms)))))))
 
 ;;; Iterate over the entries in a HASH-TABLE.
 (defmacro dohash ((key-var value-var table &optional result) &body body)