source: trunk/source/level-0/l0-array.lisp @ 15158

Last change on this file since 15158 was 15158, checked in by gb, 8 years ago

Define another 3-register-argument UUO ('uuo_error_array_axis_bounds');
use it to report array bounds errors for multidimensional array access
(incorporating the axis/dimension in the UUO and therefore the error
message.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 31.3 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20
21
22
23; Return T if array or vector header, NIL if (simple-array * *), else
24; error.
25
26(defun %array-is-header (array)
27  (let* ((typecode (typecode array)))
28    (declare (fixnum typecode))
29    (if (< typecode target::min-array-subtag)
30      (report-bad-arg array 'array)
31      (or (= typecode target::subtag-arrayH)
32          (= typecode target::subtag-vectorH)))))
33
34(defun %set-fill-pointer (vectorh new)
35  (setf (%svref vectorh target::vectorh.logsize-cell) new))
36
37(defun %array-header-subtype (header)
38  (the fixnum 
39    (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref header target::arrayH.flags-cell)))))
40
41(defun array-element-subtype (array)
42  (if (%array-is-header array)
43    (%array-header-subtype array)
44    (typecode array)))
45 
46#+ppc32-target
47(defconstant ppc32::*immheader-array-types*
48  '#(short-float
49     (unsigned-byte 32)
50     (signed-byte 32)
51     fixnum
52     character
53     (unsigned-byte 8)
54     (signed-byte 8)
55     unused
56     (unsigned-byte 16)
57     (signed-byte 16)
58     double-float
59     bit))
60
61#+ppc64-target
62(defconstant ppc64::*immheader-array-types*
63  '#(unused
64     unused
65     unused
66     unused
67     (signed-byte 8)
68     (signed-byte 16)
69     (signed-byte 32)
70     (signed-byte 64)
71     (unsigned-byte 8)
72     (unsigned-byte 16)
73     (unsigned-byte 32)
74     (unsigned-byte 64)
75     unused
76     unused
77     short-float
78     fixnum
79     unused
80     unused
81     unused
82     double-float
83     unused
84     unused
85     character
86     unused
87     unused
88     unused
89     unused
90     unused
91     unused
92     bit
93     unused
94     unused))
95
96#+x8632-target
97(defconstant x8632::*immheader-array-types*
98  '#(short-float
99     (unsigned-byte 32)
100     (signed-byte 32)
101     fixnum
102     character
103     (unsigned-byte 8)
104     (signed-byte 8)
105     unused
106     (unsigned-byte 16)
107     (signed-byte 16)
108     double-float
109     bit))
110
111#+x8664-target
112(progn
113(defconstant x8664::*immheader-0-array-types*
114  ;; ivector-class-other-bit
115  #(unused
116    unused
117    unused
118    unused
119    unused
120    unused
121    unused
122    unused
123    unused
124    unused
125    (signed-byte 16)
126    (unsigned-byte 16)
127    character
128    (signed-byte 8)
129    (unsigned-byte 8)
130    bit
131    ))
132
133(defconstant x8664::*immheader-1-array-types*
134    ;; ivector-class-32-bit
135  #(
136    unused
137    unused
138    unused
139    unused
140    unused
141    unused
142    unused
143    unused
144    unused
145    unused
146    unused
147    unused
148    character
149    (signed-byte 32)
150    (unsigned-byte 32)
151    single-float))
152
153(defconstant x8664::*immheader-2-array-types*
154  ;; ivector-class-64-bit
155  #(
156    unused
157    unused
158    unused
159    unused
160    unused
161    unused
162    unused
163    unused
164    unused
165    unused
166    unused
167    unused
168    fixnum
169    (signed-byte 64)
170    (unsigned-byte 64)
171    double-float))
172   
173)
174
175#+arm-target
176(defconstant arm::*immheader-array-types*
177  '#(short-float
178     (unsigned-byte 32)
179     (signed-byte 32)
180     fixnum
181     character
182     (unsigned-byte 8)
183     (signed-byte 8)
184     unused
185     (unsigned-byte 16)
186     (signed-byte 16)
187     double-float
188     bit))
189
190
191(defun array-element-type (array)
192  "Return the type of the elements of the array"
193  (let* ((subtag (if (%array-is-header array)
194                   (%array-header-subtype array)
195                   (typecode array))))
196    (declare (fixnum subtag))
197    (if (= subtag target::subtag-simple-vector)
198      t                                 ; only node CL array type
199      #+ppc-target
200      (svref target::*immheader-array-types*
201             #+ppc32-target
202             (ash (the fixnum (- subtag ppc32::min-cl-ivector-subtag)) -3)
203             #+ppc64-target
204             (ash (the fixnum (logand subtag #x7f)) (- ppc64::nlowtagbits)))
205      #+x8632-target
206      (svref x8632::*immheader-array-types*
207             (ash (the fixnum (- subtag x8632::min-cl-ivector-subtag))
208                  (- x8632::ntagbits)))
209      #+x8664-target
210      (let* ((class (logand subtag x8664::fulltagmask))
211             (idx (ash subtag (- x8664::ntagbits))))
212        (declare (fixnum class idx))
213        (cond ((= class x8664::ivector-class-64-bit)
214               (%svref x8664::*immheader-2-array-types* idx))
215              ((= class x8664::ivector-class-32-bit)
216               (%svref x8664::*immheader-1-array-types* idx))
217              (t
218               (%svref x8664::*immheader-0-array-types* idx))))
219      #+arm-target
220      (svref arm::*immheader-array-types*
221             (ash (the fixnum (- subtag arm::min-cl-ivector-subtag)) -3))
222      )))
223
224
225
226(defun adjustable-array-p (array)
227  "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
228   to the argument, this happens for complex arrays."
229  (let* ((typecode (typecode array)))
230    (declare (fixnum typecode))
231    (if (< typecode target::min-array-subtag)
232      (report-bad-arg array 'array)
233      (if (or (= typecode target::subtag-arrayH)
234              (= typecode target::subtag-vectorH))
235        (logbitp $arh_adjp_bit (the fixnum (%svref array target::arrayH.flags-cell)))))))
236
237(defun array-displacement (array)
238  "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
239   options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
240  (let* ((typecode (typecode array)))
241    (declare (fixnum typecode))
242    (if (< typecode target::min-array-subtag)
243      (report-bad-arg array 'array)
244      (if (and (<= typecode target::subtag-vectorH)
245               (logbitp $arh_exp_disp_bit
246                        (the fixnum (%svref array target::arrayH.flags-cell))))
247          (values (%svref array target::arrayH.data-vector-cell)
248                  (%svref array target::arrayH.displacement-cell))
249          (values nil 0)))))
250
251(defun array-data-and-offset (array)
252  (let* ((typecode (typecode array)))
253    (declare (fixnum typecode))
254    (if (< typecode target::min-array-subtag)
255      (report-bad-arg array 'array)
256      (if (<= typecode target::subtag-vectorH)
257        (%array-header-data-and-offset array)
258        (values array 0)))))
259
260(defun array-data-offset-subtype (array)
261  (let* ((typecode (typecode array)))
262    (declare (fixnum typecode))
263    (if (< typecode target::min-array-subtag)
264      (report-bad-arg array 'array)
265      (if (<= typecode target::subtag-vectorH)
266        (do* ((header array data)
267              (offset (%svref header target::arrayH.displacement-cell)
268                      (+ offset 
269                         (the fixnum 
270                              (%svref header target::arrayH.displacement-cell))))
271              (data (%svref header target::arrayH.data-vector-cell)
272                    (%svref header target::arrayH.data-vector-cell)))
273             ((> (the fixnum (typecode data)) target::subtag-vectorH)
274              (values data offset (typecode data)))
275          (declare (fixnum offset)))
276        (values array 0 typecode)))))
277 
278
279(defun array-has-fill-pointer-p (array)
280  "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
281  (let* ((typecode (typecode array)))
282    (declare (fixnum typecode))
283    (if (>= typecode target::min-array-subtag)
284      (and (= typecode target::subtag-vectorH)
285             (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell))))
286      (report-bad-arg array 'array))))
287
288
289(defun fill-pointer (array)
290  "Return the FILL-POINTER of the given VECTOR."
291  (let* ((typecode (typecode array)))
292    (declare (fixnum typecode))
293    (if (and (= typecode target::subtag-vectorH)
294             (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell))))
295      (%svref array target::vectorH.logsize-cell)
296      (report-bad-arg array '(and array (satisfies array-has-fill-pointer-p))))))
297
298(defun set-fill-pointer (array value)
299  (let* ((typecode (typecode array)))
300    (declare (fixnum typecode))
301    (if (and (= typecode target::subtag-vectorH)
302             (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell))))
303      (let* ((vlen (%svref array target::vectorH.physsize-cell)))
304        (declare (fixnum vlen))
305        (if (eq value t)
306          (setq value vlen)
307          (unless (and (fixnump value)
308                     (>= (the fixnum value) 0)
309                     (<= (the fixnum value) vlen))
310            (%err-disp $XARROOB value array)))
311        (setf (%svref array target::vectorH.logsize-cell) value))
312      (%err-disp $XNOFILLPTR array))))
313
314(eval-when (:compile-toplevel)
315  (assert (eql target::vectorH.physsize-cell target::arrayH.physsize-cell)))
316
317(defun array-total-size (array)
318  "Return the total number of elements in the Array."
319  (let* ((typecode (typecode array)))
320    (declare (fixnum typecode))
321    (if (< typecode target::min-array-subtag)
322      (report-bad-arg array 'array)
323      (if (or (= typecode target::subtag-arrayH)
324              (= typecode target::subtag-vectorH))
325        (%svref array target::vectorH.physsize-cell)
326        (uvsize array)))))
327
328     
329
330(defun array-dimension (array axis-number)
331  "Return the length of dimension AXIS-NUMBER of ARRAY."
332  (unless (typep axis-number 'fixnum) (report-bad-arg axis-number 'fixnum))
333  (locally
334    (declare (fixnum axis-number))
335    (let* ((typecode (typecode array)))
336      (declare (fixnum typecode))
337      (if (< typecode target::min-array-subtag)
338        (report-bad-arg array 'array)
339        (if (= typecode target::subtag-arrayH)
340          (let* ((rank (%svref array target::arrayH.rank-cell)))
341            (declare (fixnum rank))
342            (unless (and (>= axis-number 0)
343                         (< axis-number rank))
344              (%err-disp $XNDIMS array axis-number))
345            (%svref array (the fixnum (+ target::arrayH.dim0-cell axis-number))))
346          (if (neq axis-number 0)
347            (%err-disp $XNDIMS array axis-number)
348            (if (= typecode target::subtag-vectorH)
349              (%svref array target::vectorH.physsize-cell)
350              (uvsize array))))))))
351
352(defun array-dimensions (array)
353  "Return a list whose elements are the dimensions of the array"
354  (let* ((typecode (typecode array)))
355    (declare (fixnum typecode))
356    (if (< typecode target::min-array-subtag)
357      (report-bad-arg array 'array)
358      (if (= typecode target::subtag-arrayH)
359        (let* ((rank (%svref array target::arrayH.rank-cell))
360               (dims ()))
361          (declare (fixnum rank))       
362          (do* ((i (1- rank) (1- i)))
363               ((< i 0) dims)
364            (declare (fixnum i))
365            (push (%svref array (the fixnum (+ target::arrayH.dim0-cell i))) dims)))
366        (list (if (= typecode target::subtag-vectorH)
367                (%svref array target::vectorH.physsize-cell)
368                (uvsize array)))))))
369
370
371(defun array-rank (array)
372  "Return the number of dimensions of ARRAY."
373  (let* ((typecode (typecode array)))
374    (declare (fixnum typecode))
375    (if (< typecode target::min-array-subtag)
376      (report-bad-arg array 'array)
377      (if (= typecode target::subtag-arrayH)
378        (%svref array target::arrayH.rank-cell)
379        1))))
380
381(defun vector-push (elt vector)
382  "Attempt to set the element of ARRAY designated by its fill pointer
383   to NEW-EL, and increment the fill pointer by one. If the fill pointer is
384   too large, NIL is returned, otherwise the index of the pushed element is
385   returned."
386  (let* ((fill (fill-pointer vector))
387         (len (%svref vector target::vectorH.physsize-cell)))
388    (declare (fixnum fill len))
389    (when (< fill len)
390      (multiple-value-bind (data offset) (%array-header-data-and-offset vector)
391        (declare (fixnum offset))
392        (setf (%svref vector target::vectorH.logsize-cell) (the fixnum (1+ fill))
393              (uvref data (the fixnum (+ fill offset))) elt)
394        fill))))
395
396;;; Implement some of the guts of REPLACE, where the source and target
397;;; sequence have the same type (and we might be able to BLT things
398;;; around more quickly because of that.)
399;;; Both TARGET and SOURCE are (SIMPLE-ARRAY (*) *), and all of the
400;;; indices are fixnums and in bounds.
401(defun %uvector-replace (target target-start source source-start n typecode)
402  (declare (fixnum target-start n source-start n typecode)
403           (optimize (speed 3) (safety 0)))
404  (ecase typecode
405    (#.target::subtag-simple-vector
406     (if (and (eq source target)
407              (> target-start source-start))
408       (do* ((i 0 (1+ i))
409             (source-pos (1- (the fixnum (+ source-start n)))
410                         (1- source-pos))
411             (target-pos (1- (the fixnum (+ target-start n)))
412                         (1- target-pos)))
413            ((= i n))
414         (declare (fixnum i source-pos target-pos))
415         (setf (svref target target-pos) (svref source source-pos)))
416       (dotimes (i n)
417         (setf (svref target target-start) (svref source source-start))
418         (incf target-start)
419         (incf source-start))))
420    (#.target::subtag-bit-vector
421     (if (and (eq source target)
422              (> target-start source-start))
423       (do* ((i 0 (1+ i))
424             (source-pos (1- (the fixnum (+ source-start n)))
425                         (1- source-pos))
426             (target-pos (1- (the fixnum (+ target-start n)))
427                         (1- target-pos)))
428            ((= i n))
429         (declare (fixnum i source-pos target-pos))
430         (setf (sbit target target-pos) (sbit source source-pos)))
431       (dotimes (i n)
432         (setf (sbit target target-start) (sbit source source-start))
433         (incf target-start)
434         (incf source-start))))
435    ;; All other cases can be handled with %COPY-IVECTOR-TO-IVECTOR,
436    ;; which knows how to handle overlap
437    ((#.target::subtag-s8-vector
438      #.target::subtag-u8-vector)
439     (%copy-ivector-to-ivector source
440                               source-start
441                               target
442                               target-start
443                               n))
444    ((#.target::subtag-s16-vector
445      #.target::subtag-u16-vector)
446     (%copy-ivector-to-ivector source
447                               (the fixnum (* source-start 2))
448                               target
449                               (the fixnum (* target-start 2))
450                               (the fixnum (* n 2))))
451    ((#.target::subtag-s32-vector
452      #.target::subtag-u32-vector
453      #.target::subtag-single-float-vector
454      #.target::subtag-simple-base-string
455      #+32-bit-target #.target::subtag-fixnum-vector)
456     (%copy-ivector-to-ivector source
457                               (the fixnum (* source-start 4))
458                               target
459                               (the fixnum (* target-start 4))
460                               (the fixnum (* n 4))))
461    ((#.target::subtag-double-float-vector
462      #+64-bit-target #.target::subtag-s64-vector
463      #+64-bit-target #.target::subtag-u64-vector
464      #+64-bit-target #.target::subtag-fixnum-vector)
465     (%copy-ivector-to-ivector source
466                               (the fixnum
467                                 (+ (the fixnum (- target::misc-dfloat-offset
468                                                   target::misc-data-offset))
469                                    (the fixnum (* source-start 8))))
470                               target
471                               (the fixnum
472                                 (+ (the fixnum (- target::misc-dfloat-offset
473                                                   target::misc-data-offset))
474                                    (the fixnum (* target-start 8))))
475                               (the fixnum (* n 8)))))
476  target)
477
478(defun vector-push-extend (elt vector &optional (extension nil extp))
479  "Attempt to set the element of VECTOR designated by its fill pointer
480to ELT, and increment the fill pointer by one. If the fill pointer is
481too large, VECTOR is extended using adjust-array.  EXTENSION is the
482minimum number of elements to add if it must be extended."
483  (when extp
484    (unless (and (typep extension 'fixnum)
485                 (> (the fixnum extension) 0))
486      (setq extension (require-type extension 'unsigned-byte))))
487  (let* ((fill (fill-pointer vector))
488         (len (%svref vector target::vectorH.physsize-cell)))
489    (declare (fixnum fill len))
490    (multiple-value-bind (data offset) (%array-header-data-and-offset vector)
491      (declare (fixnum offset))
492      (if (= fill len)
493        (let* ((flags (%svref vector target::arrayH.flags-cell)))
494          (declare (fixnum flags))
495          (unless (logbitp $arh_adjp_bit flags)
496            (%err-disp $XMALADJUST vector))
497          (let* ((new-size (max
498                            (+ len (the fixnum (or extension
499                                                  len)))
500                            4))
501                 (typecode (typecode data))
502                 (new-vector (%alloc-misc new-size typecode)))
503            (%uvector-replace new-vector 0 data offset fill typecode)
504            (setf (%svref vector target::vectorH.data-vector-cell) new-vector
505                  (%svref vector target::vectorH.displacement-cell) 0
506                  (%svref vector target::vectorH.physsize-cell) new-size
507                  (%svref vector target::vectorH.flags-cell) (bitclr $arh_exp_disp_bit flags)
508                  (uvref new-vector fill) elt)))
509        (setf (uvref data (the fixnum (+ offset fill))) elt))
510      (setf (%svref vector target::vectorH.logsize-cell) (the fixnum (1+ fill))))
511    fill))
512
513;;; Could avoid potential memoization somehow
514(defun vector (&lexpr vals)
515  "Construct a SIMPLE-VECTOR from the given objects."
516  (let* ((n (%lexpr-count vals))
517         (v (allocate-typed-vector :simple-vector n)))
518    (declare (fixnum n))
519    (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i)))))
520
521;;; CALL-ARGUMENTS-LIMIT.
522(defun list-to-vector (elts)
523  (let* ((n (length elts)))
524    (declare (fixnum n))
525    (if (< n (floor #x8000 target::node-size))
526      (apply #'vector elts)
527      (make-array n :initial-contents elts))))
528
529             
530   
531(defun %gvector (subtag &lexpr vals)
532  (let* ((n (%lexpr-count vals))
533         (v (%alloc-misc n subtag)))
534    (declare (fixnum n))
535    (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i)))))
536
537(defun %aref1 (v i)
538  (let* ((typecode (typecode v)))
539    (declare (fixnum typecode))
540    (if (> typecode target::subtag-vectorH)
541      (uvref v i)
542      (if (= typecode target::subtag-vectorH)
543        (multiple-value-bind (data offset)
544                             (%array-header-data-and-offset v)
545          (unless (typep i 'fixnum)
546            (report-bad-arg i 'fixnum))
547          (unless (and (typep i 'fixnum)
548                       (>= (the fixnum i) 0)
549                       (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell))))
550            (if (not (typep i 'fixnum))
551              (report-bad-arg i 'fixnum)
552              (%err-disp $XARROOB i v)))
553          (uvref data (+ offset i)))
554        (if (= typecode target::subtag-arrayH)
555          (%err-disp $XNDIMS v 1)
556          (report-bad-arg v 'array))))))
557
558(defun %aset1 (v i new)
559  (let* ((typecode (typecode v)))
560    (declare (fixnum typecode))
561    (if (> typecode target::subtag-vectorH)
562      (setf (uvref v i) new)
563      (if (= typecode target::subtag-vectorH)
564        (multiple-value-bind (data offset)
565                             (%array-header-data-and-offset v)
566          (unless (and (typep i 'fixnum)
567                       (>= (the fixnum i) 0)
568                       (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell))))
569            (if (not (typep i 'fixnum))
570              (report-bad-arg i 'fixnum)
571              (%err-disp $XARROOB i v)))
572          (setf (uvref data (+ offset i)) new))
573        (if (= typecode target::subtag-arrayH)
574          (%err-disp $XNDIMS v 1)
575          (report-bad-arg v 'array))))))
576
577;;; Validate the N indices in the lexpr L against the
578;;; array-dimensions of L.  If anything's out-of-bounds,
579;;; error out (unless NO-ERROR is true, in which case
580;;; return NIL.)
581;;; If everything's OK, return the "row-major-index" of the array.
582;;; We know that A's an array-header of rank N.
583
584(defun %array-index (a l n &optional no-error)
585  (declare (fixnum n))
586  (let* ((count (%lexpr-count l)))
587    (declare (fixnum count))
588    (do* ((axis (1- n) (1- axis))
589          (chunk-size 1)
590          (result 0))
591         ((< axis 0) result)
592      (declare (fixnum result axis chunk-size))
593      (let* ((index (%lexpr-ref l count axis))
594             (dim (%svref a (the fixnum (+ target::arrayH.dim0-cell axis)))))
595        (declare (fixnum dim))
596        (unless (and (typep index 'fixnum)
597                     (>= (the fixnum index) 0)
598                     (< (the fixnum index) dim))
599          (if no-error
600            (return-from %array-index nil)
601            (error "Index value ~d is out of bounds for axis ~d of ~s."
602                   index axis a)))
603        (incf result (the fixnum (* chunk-size (the fixnum index))))
604        (setq chunk-size (* chunk-size dim))))))
605
606(defun aref (a &lexpr subs)
607  "Return the element of the ARRAY specified by the SUBSCRIPTS."
608  (let* ((n (%lexpr-count subs)))
609    (declare (fixnum n))
610    (if (= n 1)
611      (%aref1 a (%lexpr-ref subs n 0))
612      (if (= n 2)
613        (%aref2 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1))
614        (if (= n 3)
615          (%aref3 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1) (%lexpr-ref subs n 2))
616          (let* ((typecode (typecode a)))
617            (declare (fixnum typecode))
618            (if (>= typecode target::min-vector-subtag)
619              (%err-disp $XNDIMS a n)
620              (if (< typecode target::min-array-subtag)
621                (report-bad-arg a 'array)
622                ;;  This typecode is Just Right ...
623                (progn
624                  (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) n)
625                    (%err-disp $XNDIMS a n))
626                  (let* ((rmi (%array-index a subs n)))
627                    (declare (fixnum rmi))
628                    (multiple-value-bind (data offset) (%array-header-data-and-offset a)
629                      (declare (fixnum offset))
630                      (uvref data (the fixnum (+ offset rmi))))))))))))))
631
632
633
634
635
636(defun aset (a &lexpr subs&val)
637  (let* ((count (%lexpr-count subs&val))
638         (nsubs (1- count)))
639    (declare (fixnum nsubs count))
640    (if (eql count 0)
641      (%err-disp $xneinps)
642      (let* ((val (%lexpr-ref subs&val count nsubs)))
643        (if (= nsubs 1)
644          (%aset1 a (%lexpr-ref subs&val count 0) val)
645          (if (= nsubs 2)
646            (%aset2 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) val)
647            (if (= nsubs 3)
648              (%aset3 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) (%lexpr-ref subs&val count 2) val)
649              (let* ((typecode (typecode a)))
650                (declare (fixnum typecode))
651                (if (>= typecode target::min-vector-subtag)
652                  (%err-disp $XNDIMS a nsubs)
653                  (if (< typecode target::min-array-subtag)
654                    (report-bad-arg a 'array)
655                                        ;  This typecode is Just Right ...
656                    (progn
657                      (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) nsubs)
658                        (%err-disp $XNDIMS a nsubs))
659                      (let* ((rmi (%array-index a subs&val nsubs)))
660                        (declare (fixnum rmi))
661                        (multiple-value-bind (data offset) (%array-header-data-and-offset a)
662                          (setf (uvref data (the fixnum (+ offset rmi))) val))))))))))))))
663
664
665
666(defun schar (s i)
667  "SCHAR returns the character object at an indexed position in a string
668   just as CHAR does, except the string must be a simple-string."
669  (let* ((typecode (typecode s)))
670    (declare (fixnum typecode))
671    (if (= typecode target::subtag-simple-base-string)
672      (aref (the simple-string s) i)
673      (report-bad-arg s 'simple-string))))
674
675
676(defun %scharcode (s i)
677  (let* ((typecode (typecode s)))
678    (declare (fixnum typecode))
679    (if (= typecode target::subtag-simple-base-string)
680      (locally
681        (declare (optimize (speed 3) (safety 0)))
682        (aref (the (simple-array (unsigned-byte 32) (*)) s) i))
683        (report-bad-arg s 'simple-string))))
684
685
686(defun set-schar (s i v)
687  (let* ((typecode (typecode s)))
688    (declare (fixnum typecode))
689    (if (= typecode target::subtag-simple-base-string)
690      (setf (aref (the simple-string s) i) v)
691        (report-bad-arg s 'simple-string))))
692
693 
694(defun %set-scharcode (s i v)
695  (let* ((typecode (typecode s)))
696    (declare (fixnum typecode))
697    (if (= typecode target::subtag-simple-base-string)
698      (locally
699        (declare (optimize (speed 3) (safety 0)))
700        (setf (aref (the simple-string s) i) v))
701        (report-bad-arg s 'simple-string))))
702 
703
704; Strings are simple-strings, start & end values are sane.
705(defun %simple-string= (str1 str2 start1 start2 end1 end2)
706  (declare (fixnum start1 start2 end1 end2))
707  (when (= (the fixnum (- end1 start1))
708           (the fixnum (- end2 start2)))
709    (locally (declare (type simple-base-string str1 str2))
710            (do* ((i1 start1 (1+ i1))
711                  (i2 start2 (1+ i2)))
712                 ((= i1 end1) t)
713              (declare (fixnum i1 i2))
714              (unless (eq (schar str1 i1) (schar str2 i2))
715                (return))))))
716
717(defun copy-uvector (src)
718  (%extend-vector 0 src (uvsize src)))
719
720#+(or ppc32-target arm-target)
721(defun subtag-bytes (subtag element-count)
722  (declare (fixnum subtag element-count))
723  (unless (= #.target::fulltag-immheader (logand subtag #.target::fulltagmask))
724    (error "Not an ivector subtag: ~s" subtag))
725  (let* ((element-bit-shift
726          (if (<= subtag target::max-32-bit-ivector-subtag)
727            5
728            (if (<= subtag target::max-8-bit-ivector-subtag)
729              3
730              (if (<= subtag target::max-16-bit-ivector-subtag)
731                4
732                (if (= subtag target::subtag-double-float-vector)
733                  6
734                  0)))))
735         (total-bits (ash element-count element-bit-shift)))
736    (ash (+ 7 total-bits) -3)))
737
738#+ppc64-target
739(defun subtag-bytes (subtag element-count)
740  (declare (fixnum subtag element-count))
741  (unless (= ppc64::lowtag-immheader (logand subtag ppc64::lowtagmask))
742    (error "Not an ivector subtag: ~s" subtag))
743  (let* ((ivector-class (logand subtag ppc64::fulltagmask))
744         (element-bit-shift
745          (if (= ivector-class ppc64::ivector-class-32-bit)
746            5
747            (if (= ivector-class ppc64::ivector-class-8-bit)
748              3
749              (if (= ivector-class ppc64::ivector-class-64-bit)
750                6
751                (if (= subtag ppc64::subtag-bit-vector)
752                  0
753                  4)))))
754         (total-bits (ash element-count element-bit-shift)))
755    (declare (fixnum ivector-class element-bit-shift total-bits))
756    (ash (the fixnum (+ 7 total-bits)) -3)))
757
758#+x8632-target
759(defun subtag-bytes (subtag element-count)
760  (declare (fixnum subtag element-count))
761  (unless (= #.x8632::fulltag-immheader (logand subtag #.x8632::fulltagmask))
762    (error "Not an ivector subtag: ~s" subtag))
763  (let* ((element-bit-shift
764          (if (<= subtag x8632::max-32-bit-ivector-subtag)
765            5
766            (if (<= subtag x8632::max-8-bit-ivector-subtag)
767              3
768              (if (<= subtag x8632::max-16-bit-ivector-subtag)
769                4
770                (if (= subtag x8632::subtag-double-float-vector)
771                  6
772                  0)))))
773         (total-bits (ash element-count element-bit-shift)))
774    (ash (+ 7 total-bits) -3)))
775
776#+x8664-target
777(defun subtag-bytes (subtag element-count)
778  (declare (fixnum subtag element-count))
779  (unless (logbitp (the (mod 16) (logand subtag x8664::fulltagmask))
780                   (logior (ash 1 x8664::fulltag-immheader-0)
781                           (ash 1 x8664::fulltag-immheader-1)
782                           (ash 1 x8664::fulltag-immheader-2)))
783    (error "Not an ivector subtag: ~s" subtag))
784  (let* ((ivector-class (logand subtag x8664::fulltagmask))
785         (element-bit-shift
786          (if (= ivector-class x8664::ivector-class-32-bit)
787            5
788            (if (= ivector-class x8664::ivector-class-64-bit)
789                6
790                (if (= subtag x8664::subtag-bit-vector)
791                  0
792                  (if (>= subtag x8664::min-8-bit-ivector-subtag)
793                    3
794                    4)))))
795         (total-bits (ash element-count element-bit-shift)))
796    (declare (fixnum ivector-class element-bit-shift total-bits))
797    (ash (the fixnum (+ 7 total-bits)) -3)))
798
799(defun element-type-subtype (type)
800  "Convert element type specifier to internal array subtype code"
801  (ctype-subtype (specifier-type type)))
802
803(defun ctype-subtype (ctype)
804  (typecase ctype
805    (class-ctype
806     (if (or (eq (class-ctype-class ctype) *character-class*)
807             (eq (class-ctype-class ctype) *base-char-class*)
808             (eq (class-ctype-class ctype) *standard-char-class*))
809       target::subtag-simple-base-string
810       target::subtag-simple-vector))
811    (numeric-ctype
812     (if (eq (numeric-ctype-complexp ctype) :complex)
813       target::subtag-simple-vector
814       (case (numeric-ctype-class ctype)
815         (integer
816          (let* ((low (numeric-ctype-low ctype))
817                 (high (numeric-ctype-high ctype)))
818            (cond ((or (null low) (null high)) target::subtag-simple-vector)
819                  ((and (>= low 0) (<= high 1)) target::subtag-bit-vector)
820                  ((and (>= low 0) (<= high 255))
821                   target::subtag-u8-vector)
822                  ((and (>= low 0) (<= high 65535))
823                   target::subtag-u16-vector)
824                  ((and (>= low 0) (<= high #xffffffff))
825                   target::subtag-u32-vector)
826                  #+64-bit-target
827                  ((and (>= low 0) (<= high (1- (ash 1 64))))
828                   target::subtag-u64-vector)
829                  ((and (>= low -128) (<= high 127)) target::subtag-s8-vector)
830                  ((and (>= low -32768) (<= high 32767)) target::subtag-s16-vector)
831                  #+32-bit-target
832                  ((and (>= low target::target-most-negative-fixnum)
833                        (<= high target::target-most-positive-fixnum))
834                   target::subtag-fixnum-vector)
835                  ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
836                   target::subtag-s32-vector)
837                  #+64-bit-target
838                  ((and (>= low target::target-most-negative-fixnum)
839                        (<= high target::target-most-positive-fixnum))
840                   target::subtag-fixnum-vector)                 
841                  #+64-bit-target
842                  ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
843                   target::subtag-s64-vector)
844                  (t target::subtag-simple-vector))))
845         (float
846          (case (numeric-ctype-format ctype)
847            ((double-float long-float) target::subtag-double-float-vector)
848            ((single-float short-float) target::subtag-single-float-vector)
849            (t target::subtag-simple-vector)))
850         (t target::subtag-simple-vector))))
851    (named-ctype ; *, T, etc.
852     target::subtag-simple-vector)
853    (t
854     (harder-ctype-subtype ctype))))
855
856(defun %set-simple-array-p (array)
857  (setf (%svref array  target::arrayh.flags-cell)
858        (bitset  $arh_simple_bit (%svref array target::arrayh.flags-cell))))
859
860(defun  %array-header-simple-p (array)
861  (logbitp $arh_simple_bit (%svref array target::arrayh.flags-cell)))
862
863(defun %misc-ref (v i)
864  (%misc-ref v i))
865
866(defun %misc-set (v i new)
867  (%misc-set v i new))
868
869
870
871; end of l0-array.lisp
Note: See TracBrowser for help on using the repository browser.