Changeset 579


Ignore:
Timestamp:
Feb 28, 2004, 9:13:48 AM (15 years ago)
Author:
gb
Message:

ADJUST-ARRAY fixes (from Bryan O'Connor).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/lib/arrays-fry.lisp

    r322 r579  
    220220
    221221(defun adjust-array (array dims
    222                      &key (element-type nil element-type-p)
    223                           (initial-element nil initial-element-p)
    224                           (initial-contents nil initial-contents-p)
    225                           (fill-pointer nil fill-pointer-p)
    226                           displaced-to
    227                           displaced-index-offset
    228                      &aux (subtype (array-element-subtype array)))
     222                           &key (element-type nil element-type-p)
     223                           (initial-element nil initial-element-p)
     224                           (initial-contents nil initial-contents-p)
     225                           (fill-pointer nil fill-pointer-p)
     226                           displaced-to
     227                           displaced-index-offset
     228                           &aux (subtype (array-element-subtype array)))
    229229  (when (and element-type-p
    230230             (neq (element-type-subtype element-type) subtype))
     
    233233  (if (neq (list-length dims)(array-rank array))
    234234    (error "~S has wrong rank for adjusting to dimensions ~S" array dims))
    235   (let ((size 1))   
     235  (let ((size 1)
     236        (explicitp nil))
    236237    (dolist (dim dims)
    237238      (when (< dim 0)(report-bad-arg dims '(integer 0 *)))
     
    243244             array (or fill-pointer (fill-pointer array))))
    244245    (when (and fill-pointer (not (array-has-fill-pointer-p array)))
    245         (error "~S does not have a fill pointer" array))
     246      (error "~S does not have a fill pointer" array))
    246247    (when (and displaced-index-offset (null displaced-to))
    247248      (error "Cannot specify ~S without ~S" :displaced-index-offset :displaced-to))
    248249    (when (and initial-element-p initial-contents-p)
    249         (error "Cannot specify both ~S and ~S" :initial-element :initial-contents))
     250      (error "Cannot specify both ~S and ~S" :initial-element :initial-contents))
    250251    (cond
    251      ((not (adjustable-array-p array))
    252       (let ((new-array (make-array-1  dims
     252      ((not (adjustable-array-p array))
     253       (let ((new-array (make-array-1  dims
    253254                                       (array-element-type array) T
    254255                                       displaced-to
    255256                                       displaced-index-offset
    256257                                       nil
    257                                        fill-pointer
     258                                       (or fill-pointer
     259                                           (and (array-has-fill-pointer-p array)
     260                                                (fill-pointer array)))
    258261                                       initial-element initial-element-p
    259262                                       initial-contents initial-contents-p
    260263                                       size)))
    261264                     
    262         (when (and (null initial-contents-p)
    263                    (null displaced-to))
    264           (multiple-value-bind (array-data offs) (array-data-and-offset array)
    265             (let ((new-array-data (array-data-and-offset new-array)))
    266               (cond ((null dims)
    267                      (uvset new-array-data 0 (uvref array-data offs)))
    268                     (T
    269                    (init-array-data array-data offs (array-dimensions array)
    270                                     new-array-data 0 dims))))))
    271         (setq array new-array)))
    272      (T (cond
    273          (displaced-to
    274           (if (and displaced-index-offset
    275                    (or (not (fixnump displaced-index-offset))
    276                        (< displaced-index-offset 0)))
    277             (report-bad-arg displaced-index-offset '(integer 0 #.most-positive-fixnum)))
    278           (when (or initial-element-p initial-contents-p)
    279             (error "Cannot specify initial values for displaced arrays"))
    280           (unless (eq subtype (array-element-subtype displaced-to))
    281             (error "~S is not of element type ~S"
    282                    displaced-to (array-element-type array)))
    283           (do* ((vec displaced-to (displaced-array-p vec)))
    284                ((null vec) ())
    285             (when (eq vec array)
    286               (error "Array cannot be displaced to itself."))))
    287          (T
    288           (setq displaced-to ( %alloc-misc size subtype))     
    289           (cond (initial-element-p
    290                  (dotimes (i (the fixnum size)) (uvset displaced-to i initial-element)))
    291                 (initial-contents-p
    292                  (if (null dims) (uvset displaced-to 0 initial-contents)
     265         (when (and (null initial-contents-p)
     266                    (null displaced-to))
     267           (multiple-value-bind (array-data offs) (array-data-and-offset array)
     268             (let ((new-array-data (array-data-and-offset new-array)))
     269               (cond ((null dims)
     270                      (uvset new-array-data 0 (uvref array-data offs)))
     271                     (T
     272                      (init-array-data array-data offs (array-dimensions array)
     273                                       new-array-data 0 dims))))))
     274         (setq array new-array)))
     275      (T (cond
     276           (displaced-to
     277            (if (and displaced-index-offset
     278                     (or (not (fixnump displaced-index-offset))
     279                         (< displaced-index-offset 0)))
     280              (report-bad-arg displaced-index-offset '(integer 0 #.most-positive-fixnum)))
     281            (when (or initial-element-p initial-contents-p)
     282              (error "Cannot specify initial values for displaced arrays"))
     283            (unless (eq subtype (array-element-subtype displaced-to))
     284              (error "~S is not of element type ~S"
     285                     displaced-to (array-element-type array)))
     286            (do* ((vec displaced-to (displaced-array-p vec)))
     287                 ((null vec) ())
     288              (when (eq vec array)
     289                (error "Array cannot be displaced to itself.")))
     290            (setq explicitp t))
     291           (T
     292            (setq displaced-to (%alloc-misc size subtype))
     293            (cond (initial-element-p
     294                   (dotimes (i (the fixnum size)) (uvset displaced-to i initial-element)))
     295                  (initial-contents-p
     296                   (if (null dims) (uvset displaced-to 0 initial-contents)
    293297                     (init-uvector-contents displaced-to 0 dims initial-contents))))
    294           (cond ((null dims)
    295                  (uvset displaced-to 0 (aref array)))
    296                 ((not initial-contents-p)
    297                  (multiple-value-bind (vec offs) (array-data-and-offset array)
    298                    (init-array-data vec offs (array-dimensions array) displaced-to 0 dims))))))
    299         (%displace-array array dims size displaced-to (or displaced-index-offset 0))))
     298            (cond ((null dims)
     299                   (uvset displaced-to 0 (aref array)))
     300                  ((not initial-contents-p)
     301                   (multiple-value-bind (vec offs) (array-data-and-offset array)
     302                     (init-array-data vec offs (array-dimensions array) displaced-to 0 dims))))))
     303         (%displace-array array dims size displaced-to (or displaced-index-offset 0) explicitp)))
    300304    (when fill-pointer-p
    301305      (cond
     
    336340; only caller is adjust-array
    337341
    338 (defun %displace-array (array dims size data offset)
     342(defun %displace-array (array dims size data offset explicitp)
    339343  (let* ((typecode (typecode array))
    340344         (array-p (eql typecode ppc32::subtag-arrayH))
     
    354358              (bitclr $arh_disp_bit flags)
    355359              (bitset $arh_disp_bit flags)))
     360      (setf (%svref array ppc32::vectorH.flags-cell)
     361            (if explicitp
     362              (bitset $arh_exp_disp_bit flags)
     363              (bitclr $arh_exp_disp_bit flags)))
    356364      (setf (%svref array ppc32::arrayH.data-vector-cell) data)
    357365      (if array-p
Note: See TracChangeset for help on using the changeset viewer.