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

Last change on this file since 10777 was 10777, checked in by rme, 11 years ago

Out-of-line %scharcode: character codes aren't 8 bits long any more.

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