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

Last change on this file since 16085 was 16085, checked in by gb, 5 years ago

First attempt to merge acode-rewrite branch into trunk.

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