source: branches/new-random/level-0/l0-array.lisp

Last change on this file was 13067, checked in by rme, 10 years ago

Update copyright notices.

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