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

Last change on this file since 9060 was 9060, checked in by gb, 12 years ago

CTYPE-SUBTYPE: try harder in some cases.

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