source: branches/ia32/level-0/l0-array.lisp @ 7430

Last change on this file since 7430 was 7338, checked in by rme, 14 years ago

Conditionalize for X8632

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