X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Farray.lisp;h=0d44b094f3b75f1cf212c0dd8c11617f5468ed2d;hb=d720bc359f03734ccb9baf66cb45dc01d623f369;hp=efd993ed0e3ccf2727b5019a7002dfe5b222b86c;hpb=5762f26aae78beaead9919074963f67d92794599;p=sbcl.git

diff --git a/src/code/array.lisp b/src/code/array.lisp
index efd993e..0d44b09 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -339,9 +339,30 @@ of specialized arrays is supported."
                        (svref ,',table-name tag)))))))
   (def !find-data-vector-setter %%data-vector-setters%%)
   (def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
-  (def !find-data-vector-reffer %%data-vector-reffers%%)
+  ;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
+  ;; meaning we can have post-build dependences on this.
+  (def %find-data-vector-reffer %%data-vector-reffers%%)
   (def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))
 
+;;; Like DOVECTOR, but more magical -- can't use this on host.
+(defmacro do-vector-data ((elt vector &optional result) &body body)
+  (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+    (with-unique-names (index vec start end ref)
+      `(with-array-data ((,vec ,vector)
+                         (,start)
+                         (,end)
+                         :check-fill-pointer t)
+         (let ((,ref (%find-data-vector-reffer ,vec)))
+           (do ((,index ,start (1+ ,index)))
+               ((>= ,index ,end)
+                (let ((,elt nil))
+                  ,@(filter-dolist-declarations decls)
+                  ,elt
+                  ,result))
+             (let ((,elt (funcall ,ref ,vec ,index)))
+               ,@decls
+               (tagbody ,@forms))))))))
+
 (macrolet ((%ref (accessor-getter extra-params)
              `(funcall (,accessor-getter array) array index ,@extra-params))
            (define (accessor-name slow-accessor-name accessor-getter
@@ -375,7 +396,7 @@ of specialized arrays is supported."
                         (declare (ignore end))
                         (,accessor-name vector index ,@extra-params)))))))
   (define hairy-data-vector-ref slow-hairy-data-vector-ref
-    !find-data-vector-reffer
+    %find-data-vector-reffer
     nil (progn))
   (define hairy-data-vector-set slow-hairy-data-vector-set
     !find-data-vector-setter
@@ -1346,20 +1367,6 @@ function to be removed without further warning."
 
 ;;;; array type dispatching
 
-;;; Store some saetp fields for DEFINE-ARRAY-DISPATCH since
-;;; sb!vm:*specialized-array-element-type-properties* is not always
-;;; available.
-(macrolet
-    ((define-saetp-info ()
-       `(eval-when (:compile-toplevel :load-toplevel :execute)
-          (defglobal %%saetp-info%%
-              ',(loop for saetp
-                      across sb!vm:*specialized-array-element-type-properties*
-                      collect `(,(sb!vm:saetp-typecode saetp)
-                                ,(sb!vm:saetp-specifier saetp)
-                                ,(sb!vm:saetp-primitive-type-name saetp)))))))
-  (define-saetp-info))
-
 ;;; Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated),
 ;;; defines the functions
 ;;;
@@ -1391,7 +1398,10 @@ function to be removed without further warning."
                   :expected-type '(simple-array * (*)))))
        (defglobal ,table-name (make-array ,(1+ sb!vm:widetag-mask)
                                           :initial-element #',error-name))
-       ,@(loop for (typecode specifier primitive-type-name) in %%saetp-info%%
+       ,@(loop for info across sb!vm:*specialized-array-element-type-properties*
+               for typecode = (sb!vm:saetp-typecode info)
+               for specifier = (sb!vm:saetp-specifier info)
+               for primitive-type-name = (sb!vm:saetp-primitive-type-name info)
                collect (let ((fun-name (symbolicate (string dispatch-name)
                                                     "/" primitive-type-name)))
                          `(progn