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

Last change on this file since 15601 was 15165, checked in by gb, 7 years ago

Except on the PPC (which has LAP versions of %EXTEND-VECTOR), define
%EXTEND-VECTOR in terms of %UVECTOR-REPLACE, which can use things like
%COPY-IVECTOR-TO-IVECTOR.

Make %UVECTOR-REPLACE work on non-CL-array uvector types, too.

When creating an fd-based stream (in MAKE-FD-STREAM and MAKE-FILE-STREAM),
if the stream is capable of character I/O it'll be buffered by an octet
vector, so call OPTIMAL-BUFFER-SIZE with the appropriate element type.
On Windows, use the arbitrary buffer size of 4K octets (rather than #$BUFSIZ).

In %IOBLOCK-UNENCODED-READ-LINE, if we haven't seen a newline in the first
few bufferfuls of data, stop expecting to do so (and grow the string in
larger increments less often.)

In the more generic READ-LINE cases, use a SIMPLE-STRING (and track
its length and current position manually) rather than a string with a
fill-pointer.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 31.9 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;;; (Actually, we allow some internal uvector types as well as CL vectors.)
402(defun %uvector-replace (target target-start source source-start n typecode)
403  (declare (fixnum target-start n source-start n typecode)
404           (optimize (speed 3) (safety 0)))
405  (if (gvectorp target)
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    (ecase typecode
421      (#.target::subtag-bit-vector
422       (if (and (eq source target)
423                (> target-start source-start))
424         (do* ((i 0 (1+ i))
425               (source-pos (1- (the fixnum (+ source-start n)))
426                           (1- source-pos))
427               (target-pos (1- (the fixnum (+ target-start n)))
428                           (1- target-pos)))
429              ((= i n))
430           (declare (fixnum i source-pos target-pos))
431           (setf (sbit target target-pos) (sbit source source-pos)))
432         (dotimes (i n)
433           (setf (sbit target target-start) (sbit source source-start))
434           (incf target-start)
435           (incf source-start))))
436      ;; All other cases can be handled with %COPY-IVECTOR-TO-IVECTOR,
437      ;; which knows how to handle overlap
438      ((#.target::subtag-s8-vector
439        #.target::subtag-u8-vector)
440       (%copy-ivector-to-ivector source
441                                 source-start
442                                 target
443                                 target-start
444                                 n))
445      ((#.target::subtag-s16-vector
446        #.target::subtag-u16-vector)
447       (%copy-ivector-to-ivector source
448                                 (the fixnum (* source-start 2))
449                                 target
450                                 (the fixnum (* target-start 2))
451                                 (the fixnum (* n 2))))
452      ((#.target::subtag-s32-vector
453        #.target::subtag-u32-vector
454        #.target::subtag-single-float-vector
455        #.target::subtag-simple-base-string
456        #.target::subtag-bignum
457        #.target::subtag-single-float
458        #.target::subtag-double-float
459        #+32-bit-target #.target::subtag-fixnum-vector)
460       (%copy-ivector-to-ivector source
461                                 (the fixnum (* source-start 4))
462                                 target
463                                 (the fixnum (* target-start 4))
464                                 (the fixnum (* n 4))))
465      ((#.target::subtag-double-float-vector
466        #+64-bit-target #.target::subtag-s64-vector
467        #+64-bit-target #.target::subtag-u64-vector
468        #+64-bit-target #.target::subtag-fixnum-vector)
469       (%copy-ivector-to-ivector source
470                                 (the fixnum
471                                   (+ (the fixnum (- target::misc-dfloat-offset
472                                                     target::misc-data-offset))
473                                      (the fixnum (* source-start 8))))
474                                 target
475                                 (the fixnum
476                                   (+ (the fixnum (- target::misc-dfloat-offset
477                                                     target::misc-data-offset))
478                                      (the fixnum (* target-start 8))))
479                                 (the fixnum (* n 8))))))
480  target)
481
482(defun vector-push-extend (elt vector &optional (extension nil extp))
483  "Attempt to set the element of VECTOR designated by its fill pointer
484to ELT, and increment the fill pointer by one. If the fill pointer is
485too large, VECTOR is extended using adjust-array.  EXTENSION is the
486minimum number of elements to add if it must be extended."
487  (when extp
488    (unless (and (typep extension 'fixnum)
489                 (> (the fixnum extension) 0))
490      (setq extension (require-type extension 'unsigned-byte))))
491  (let* ((fill (fill-pointer vector))
492         (len (%svref vector target::vectorH.physsize-cell)))
493    (declare (fixnum fill len))
494    (multiple-value-bind (data offset) (%array-header-data-and-offset vector)
495      (declare (fixnum offset))
496      (if (= fill len)
497        (let* ((flags (%svref vector target::arrayH.flags-cell)))
498          (declare (fixnum flags))
499          (unless (logbitp $arh_adjp_bit flags)
500            (%err-disp $XMALADJUST vector))
501          (let* ((new-size (max
502                            (+ len (the fixnum (or extension
503                                                  len)))
504                            4))
505                 (typecode (typecode data))
506                 (new-vector (%alloc-misc new-size typecode)))
507            (%uvector-replace new-vector 0 data offset fill typecode)
508            (setf (%svref vector target::vectorH.data-vector-cell) new-vector
509                  (%svref vector target::vectorH.displacement-cell) 0
510                  (%svref vector target::vectorH.physsize-cell) new-size
511                  (%svref vector target::vectorH.flags-cell) (bitclr $arh_exp_disp_bit flags)
512                  (uvref new-vector fill) elt)))
513        (setf (uvref data (the fixnum (+ offset fill))) elt))
514      (setf (%svref vector target::vectorH.logsize-cell) (the fixnum (1+ fill))))
515    fill))
516
517;;; Could avoid potential memoization somehow
518(defun vector (&lexpr vals)
519  "Construct a SIMPLE-VECTOR from the given objects."
520  (let* ((n (%lexpr-count vals))
521         (v (allocate-typed-vector :simple-vector n)))
522    (declare (fixnum n))
523    (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i)))))
524
525;;; CALL-ARGUMENTS-LIMIT.
526(defun list-to-vector (elts)
527  (let* ((n (length elts)))
528    (declare (fixnum n))
529    (if (< n (floor #x8000 target::node-size))
530      (apply #'vector elts)
531      (make-array n :initial-contents elts))))
532
533             
534   
535(defun %gvector (subtag &lexpr vals)
536  (let* ((n (%lexpr-count vals))
537         (v (%alloc-misc n subtag)))
538    (declare (fixnum n))
539    (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i)))))
540
541(defun %aref1 (v i)
542  (let* ((typecode (typecode v)))
543    (declare (fixnum typecode))
544    (if (> typecode target::subtag-vectorH)
545      (uvref v i)
546      (if (= typecode target::subtag-vectorH)
547        (multiple-value-bind (data offset)
548                             (%array-header-data-and-offset v)
549          (unless (typep i 'fixnum)
550            (report-bad-arg i 'fixnum))
551          (unless (and (typep i 'fixnum)
552                       (>= (the fixnum i) 0)
553                       (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell))))
554            (if (not (typep i 'fixnum))
555              (report-bad-arg i 'fixnum)
556              (%err-disp $XARROOB i v)))
557          (uvref data (+ offset i)))
558        (if (= typecode target::subtag-arrayH)
559          (%err-disp $XNDIMS v 1)
560          (report-bad-arg v 'array))))))
561
562(defun %aset1 (v i new)
563  (let* ((typecode (typecode v)))
564    (declare (fixnum typecode))
565    (if (> typecode target::subtag-vectorH)
566      (setf (uvref v i) new)
567      (if (= typecode target::subtag-vectorH)
568        (multiple-value-bind (data offset)
569                             (%array-header-data-and-offset v)
570          (unless (and (typep i 'fixnum)
571                       (>= (the fixnum i) 0)
572                       (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell))))
573            (if (not (typep i 'fixnum))
574              (report-bad-arg i 'fixnum)
575              (%err-disp $XARROOB i v)))
576          (setf (uvref data (+ offset i)) new))
577        (if (= typecode target::subtag-arrayH)
578          (%err-disp $XNDIMS v 1)
579          (report-bad-arg v 'array))))))
580
581;;; Validate the N indices in the lexpr L against the
582;;; array-dimensions of L.  If anything's out-of-bounds,
583;;; error out (unless NO-ERROR is true, in which case
584;;; return NIL.)
585;;; If everything's OK, return the "row-major-index" of the array.
586;;; We know that A's an array-header of rank N.
587
588(defun %array-index (a l n &optional no-error)
589  (declare (fixnum n))
590  (let* ((count (%lexpr-count l)))
591    (declare (fixnum count))
592    (do* ((axis (1- n) (1- axis))
593          (chunk-size 1)
594          (result 0))
595         ((< axis 0) result)
596      (declare (fixnum result axis chunk-size))
597      (let* ((index (%lexpr-ref l count axis))
598             (dim (%svref a (the fixnum (+ target::arrayH.dim0-cell axis)))))
599        (declare (fixnum dim))
600        (unless (and (typep index 'fixnum)
601                     (>= (the fixnum index) 0)
602                     (< (the fixnum index) dim))
603          (if no-error
604            (return-from %array-index nil)
605            (error "Index value ~d is out of bounds for axis ~d of ~s."
606                   index axis a)))
607        (incf result (the fixnum (* chunk-size (the fixnum index))))
608        (setq chunk-size (* chunk-size dim))))))
609
610(defun aref (a &lexpr subs)
611  "Return the element of the ARRAY specified by the SUBSCRIPTS."
612  (let* ((n (%lexpr-count subs)))
613    (declare (fixnum n))
614    (if (= n 1)
615      (%aref1 a (%lexpr-ref subs n 0))
616      (if (= n 2)
617        (%aref2 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1))
618        (if (= n 3)
619          (%aref3 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1) (%lexpr-ref subs n 2))
620          (let* ((typecode (typecode a)))
621            (declare (fixnum typecode))
622            (if (>= typecode target::min-vector-subtag)
623              (%err-disp $XNDIMS a n)
624              (if (< typecode target::min-array-subtag)
625                (report-bad-arg a 'array)
626                ;;  This typecode is Just Right ...
627                (progn
628                  (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) n)
629                    (%err-disp $XNDIMS a n))
630                  (let* ((rmi (%array-index a subs n)))
631                    (declare (fixnum rmi))
632                    (multiple-value-bind (data offset) (%array-header-data-and-offset a)
633                      (declare (fixnum offset))
634                      (uvref data (the fixnum (+ offset rmi))))))))))))))
635
636
637
638
639
640(defun aset (a &lexpr subs&val)
641  (let* ((count (%lexpr-count subs&val))
642         (nsubs (1- count)))
643    (declare (fixnum nsubs count))
644    (if (eql count 0)
645      (%err-disp $xneinps)
646      (let* ((val (%lexpr-ref subs&val count nsubs)))
647        (if (= nsubs 1)
648          (%aset1 a (%lexpr-ref subs&val count 0) val)
649          (if (= nsubs 2)
650            (%aset2 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) val)
651            (if (= nsubs 3)
652              (%aset3 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) (%lexpr-ref subs&val count 2) val)
653              (let* ((typecode (typecode a)))
654                (declare (fixnum typecode))
655                (if (>= typecode target::min-vector-subtag)
656                  (%err-disp $XNDIMS a nsubs)
657                  (if (< typecode target::min-array-subtag)
658                    (report-bad-arg a 'array)
659                                        ;  This typecode is Just Right ...
660                    (progn
661                      (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) nsubs)
662                        (%err-disp $XNDIMS a nsubs))
663                      (let* ((rmi (%array-index a subs&val nsubs)))
664                        (declare (fixnum rmi))
665                        (multiple-value-bind (data offset) (%array-header-data-and-offset a)
666                          (setf (uvref data (the fixnum (+ offset rmi))) val))))))))))))))
667
668
669
670(defun schar (s i)
671  "SCHAR returns the character object at an indexed position in a string
672   just as CHAR does, except the string must be a simple-string."
673  (let* ((typecode (typecode s)))
674    (declare (fixnum typecode))
675    (if (= typecode target::subtag-simple-base-string)
676      (aref (the simple-string s) i)
677      (report-bad-arg s 'simple-string))))
678
679
680(defun %scharcode (s i)
681  (let* ((typecode (typecode s)))
682    (declare (fixnum typecode))
683    (if (= typecode target::subtag-simple-base-string)
684      (locally
685        (declare (optimize (speed 3) (safety 0)))
686        (aref (the (simple-array (unsigned-byte 32) (*)) s) i))
687        (report-bad-arg s 'simple-string))))
688
689
690(defun set-schar (s i v)
691  (let* ((typecode (typecode s)))
692    (declare (fixnum typecode))
693    (if (= typecode target::subtag-simple-base-string)
694      (setf (aref (the simple-string s) i) v)
695        (report-bad-arg s 'simple-string))))
696
697 
698(defun %set-scharcode (s i v)
699  (let* ((typecode (typecode s)))
700    (declare (fixnum typecode))
701    (if (= typecode target::subtag-simple-base-string)
702      (locally
703        (declare (optimize (speed 3) (safety 0)))
704        (setf (aref (the simple-string s) i) v))
705        (report-bad-arg s 'simple-string))))
706 
707
708; Strings are simple-strings, start & end values are sane.
709(defun %simple-string= (str1 str2 start1 start2 end1 end2)
710  (declare (fixnum start1 start2 end1 end2))
711  (when (= (the fixnum (- end1 start1))
712           (the fixnum (- end2 start2)))
713    (locally (declare (type simple-base-string str1 str2))
714            (do* ((i1 start1 (1+ i1))
715                  (i2 start2 (1+ i2)))
716                 ((= i1 end1) t)
717              (declare (fixnum i1 i2))
718              (unless (eq (schar str1 i1) (schar str2 i2))
719                (return))))))
720
721(defun copy-uvector (src)
722  (%extend-vector 0 src (uvsize src)))
723
724#+(or ppc32-target arm-target)
725(defun subtag-bytes (subtag element-count)
726  (declare (fixnum subtag element-count))
727  (unless (= #.target::fulltag-immheader (logand subtag #.target::fulltagmask))
728    (error "Not an ivector subtag: ~s" subtag))
729  (let* ((element-bit-shift
730          (if (<= subtag target::max-32-bit-ivector-subtag)
731            5
732            (if (<= subtag target::max-8-bit-ivector-subtag)
733              3
734              (if (<= subtag target::max-16-bit-ivector-subtag)
735                4
736                (if (= subtag target::subtag-double-float-vector)
737                  6
738                  0)))))
739         (total-bits (ash element-count element-bit-shift)))
740    (ash (+ 7 total-bits) -3)))
741
742#+ppc64-target
743(defun subtag-bytes (subtag element-count)
744  (declare (fixnum subtag element-count))
745  (unless (= ppc64::lowtag-immheader (logand subtag ppc64::lowtagmask))
746    (error "Not an ivector subtag: ~s" subtag))
747  (let* ((ivector-class (logand subtag ppc64::fulltagmask))
748         (element-bit-shift
749          (if (= ivector-class ppc64::ivector-class-32-bit)
750            5
751            (if (= ivector-class ppc64::ivector-class-8-bit)
752              3
753              (if (= ivector-class ppc64::ivector-class-64-bit)
754                6
755                (if (= subtag ppc64::subtag-bit-vector)
756                  0
757                  4)))))
758         (total-bits (ash element-count element-bit-shift)))
759    (declare (fixnum ivector-class element-bit-shift total-bits))
760    (ash (the fixnum (+ 7 total-bits)) -3)))
761
762#+x8632-target
763(defun subtag-bytes (subtag element-count)
764  (declare (fixnum subtag element-count))
765  (unless (= #.x8632::fulltag-immheader (logand subtag #.x8632::fulltagmask))
766    (error "Not an ivector subtag: ~s" subtag))
767  (let* ((element-bit-shift
768          (if (<= subtag x8632::max-32-bit-ivector-subtag)
769            5
770            (if (<= subtag x8632::max-8-bit-ivector-subtag)
771              3
772              (if (<= subtag x8632::max-16-bit-ivector-subtag)
773                4
774                (if (= subtag x8632::subtag-double-float-vector)
775                  6
776                  0)))))
777         (total-bits (ash element-count element-bit-shift)))
778    (ash (+ 7 total-bits) -3)))
779
780#+x8664-target
781(defun subtag-bytes (subtag element-count)
782  (declare (fixnum subtag element-count))
783  (unless (logbitp (the (mod 16) (logand subtag x8664::fulltagmask))
784                   (logior (ash 1 x8664::fulltag-immheader-0)
785                           (ash 1 x8664::fulltag-immheader-1)
786                           (ash 1 x8664::fulltag-immheader-2)))
787    (error "Not an ivector subtag: ~s" subtag))
788  (let* ((ivector-class (logand subtag x8664::fulltagmask))
789         (element-bit-shift
790          (if (= ivector-class x8664::ivector-class-32-bit)
791            5
792            (if (= ivector-class x8664::ivector-class-64-bit)
793                6
794                (if (= subtag x8664::subtag-bit-vector)
795                  0
796                  (if (>= subtag x8664::min-8-bit-ivector-subtag)
797                    3
798                    4)))))
799         (total-bits (ash element-count element-bit-shift)))
800    (declare (fixnum ivector-class element-bit-shift total-bits))
801    (ash (the fixnum (+ 7 total-bits)) -3)))
802
803(defun element-type-subtype (type)
804  "Convert element type specifier to internal array subtype code"
805  (ctype-subtype (specifier-type type)))
806
807(defun ctype-subtype (ctype)
808  (typecase ctype
809    (class-ctype
810     (if (or (eq (class-ctype-class ctype) *character-class*)
811             (eq (class-ctype-class ctype) *base-char-class*)
812             (eq (class-ctype-class ctype) *standard-char-class*))
813       target::subtag-simple-base-string
814       target::subtag-simple-vector))
815    (numeric-ctype
816     (if (eq (numeric-ctype-complexp ctype) :complex)
817       target::subtag-simple-vector
818       (case (numeric-ctype-class ctype)
819         (integer
820          (let* ((low (numeric-ctype-low ctype))
821                 (high (numeric-ctype-high ctype)))
822            (cond ((or (null low) (null high)) target::subtag-simple-vector)
823                  ((and (>= low 0) (<= high 1)) target::subtag-bit-vector)
824                  ((and (>= low 0) (<= high 255))
825                   target::subtag-u8-vector)
826                  ((and (>= low 0) (<= high 65535))
827                   target::subtag-u16-vector)
828                  ((and (>= low 0) (<= high #xffffffff))
829                   target::subtag-u32-vector)
830                  #+64-bit-target
831                  ((and (>= low 0) (<= high (1- (ash 1 64))))
832                   target::subtag-u64-vector)
833                  ((and (>= low -128) (<= high 127)) target::subtag-s8-vector)
834                  ((and (>= low -32768) (<= high 32767)) target::subtag-s16-vector)
835                  #+32-bit-target
836                  ((and (>= low target::target-most-negative-fixnum)
837                        (<= high target::target-most-positive-fixnum))
838                   target::subtag-fixnum-vector)
839                  ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
840                   target::subtag-s32-vector)
841                  #+64-bit-target
842                  ((and (>= low target::target-most-negative-fixnum)
843                        (<= high target::target-most-positive-fixnum))
844                   target::subtag-fixnum-vector)                 
845                  #+64-bit-target
846                  ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
847                   target::subtag-s64-vector)
848                  (t target::subtag-simple-vector))))
849         (float
850          (case (numeric-ctype-format ctype)
851            ((double-float long-float) target::subtag-double-float-vector)
852            ((single-float short-float) target::subtag-single-float-vector)
853            (t target::subtag-simple-vector)))
854         (t target::subtag-simple-vector))))
855    (named-ctype ; *, T, etc.
856     target::subtag-simple-vector)
857    (t
858     (harder-ctype-subtype ctype))))
859
860(defun %set-simple-array-p (array)
861  (setf (%svref array  target::arrayh.flags-cell)
862        (bitset  $arh_simple_bit (%svref array target::arrayh.flags-cell))))
863
864(defun  %array-header-simple-p (array)
865  (logbitp $arh_simple_bit (%svref array target::arrayh.flags-cell)))
866
867(defun %misc-ref (v i)
868  (%misc-ref v i))
869
870(defun %misc-set (v i new)
871  (%misc-set v i new))
872
873#-ppc-target
874(defun %extend-vector (start oldv newsize)
875  (declare (fixnum start))
876  (let* ((typecode (typecode oldv))
877         (new (%alloc-misc newsize typecode))
878         (oldsize (uvsize oldv)))
879    (declare (fixnum oldsize) (type (unsigned-byte 8) typecode))
880    (%uvector-replace  new start oldv 0 oldsize typecode)))
881
882
883
884; end of l0-array.lisp
Note: See TracBrowser for help on using the repository browser.