source: trunk/source/lib/arrays-fry.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 20.3 KB
Line 
1; -*- Mode:Lisp; Package:CCL; -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17(in-package "CCL")
18
19(defun bit (bit-array &rest subscripts)
20  "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
21  (declare (dynamic-extent subscripts))
22  (unless (eq (array-element-type bit-array) 'bit)
23    (report-bad-arg bit-array '(array bit)))
24  (apply #'aref bit-array subscripts))
25
26(defun %bitset (bit-array &rest stuff)
27  (declare (dynamic-extent stuff))
28  (unless (eq (array-element-type bit-array) 'bit)
29    (report-bad-arg bit-array '(array bit)))
30  (apply #'aset bit-array stuff))
31
32(defun sbit (v &optional (sub0 nil sub0-p) &rest others)
33  "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
34  (declare (dynamic-extent others))
35  (if sub0-p
36    (if others
37      (apply #'bit v sub0 others)
38      ( sbit (require-type v 'simple-bit-vector) sub0))
39    (bit v)))
40
41(defun %sbitset (v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)
42  (declare (dynamic-extent newval-was-really-sub1))
43  (if newval-p
44    (if newval-was-really-sub1
45      (apply #'%bitset v sub0 newval newval-was-really-sub1)
46      (progn
47        (unless (typep v 'simple-bit-vector)
48          (report-bad-arg v 'simple-bit-vector))
49        (uvset v sub0 newval)))
50    (%bitset v sub0)))
51
52(defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
53  "Perform a bit-wise LOGAND on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
54  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
55  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
56  created. All the arrays must have the same rank and dimensions."
57   (bit-boole boole-and bit-array1 bit-array2 result-bit-array))
58
59(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
60  "Perform a bit-wise LOGIOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
61  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
62  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
63  created. All the arrays must have the same rank and dimensions."
64  (bit-boole  boole-ior bit-array1 bit-array2 result-bit-array))
65
66(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
67  "Perform a bit-wise LOGXOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
68  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
69  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
70  created. All the arrays must have the same rank and dimensions."
71   (bit-boole  boole-xor bit-array1 bit-array2 result-bit-array))
72
73(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
74  "Perform a bit-wise LOGEQV on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
75  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
76  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
77  created. All the arrays must have the same rank and dimensions."
78  (bit-boole boole-eqv bit-array1 bit-array2 result-bit-array))
79
80(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
81  "Perform a bit-wise LOGNAND on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
82  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
83  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
84  created. All the arrays must have the same rank and dimensions."
85  (bit-boole boole-nand bit-array1 bit-array2 result-bit-array))
86
87(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
88  "Perform a bit-wise LOGNOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
89  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
90  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
91  created. All the arrays must have the same rank and dimensions."
92  (bit-boole boole-nor bit-array1 bit-array2 result-bit-array))
93
94(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
95  "Perform a bit-wise LOGANDC1 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
96  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
97  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
98  created. All the arrays must have the same rank and dimensions."
99  (bit-boole boole-andc1 bit-array1 bit-array2 result-bit-array))
100
101(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
102  "Perform a bit-wise LOGANDC2 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
103  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
104  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
105  created. All the arrays must have the same rank and dimensions."
106  (bit-boole boole-andc2 bit-array1 bit-array2 result-bit-array))
107
108(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
109  "Perform a bit-wise LOGORC1 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
110  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
111  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
112  created. All the arrays must have the same rank and dimensions."
113  (bit-boole boole-orc1 bit-array1 bit-array2 result-bit-array))
114
115(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
116  "Perform a bit-wise LOGORC2 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2,
117  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
118  BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
119  created. All the arrays must have the same rank and dimensions."
120  (bit-boole boole-orc2 bit-array1 bit-array2 result-bit-array))
121
122(defun bit-not (bit-array &optional result-bit-array)
123  "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
124  putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
125  BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
126  created. Both arrays must have the same rank and dimensions."
127  (bit-boole boole-nor bit-array bit-array result-bit-array))
128
129(defun result-bit-array (bit-array-1 bit-array-2 result)
130  ; Check that the two bit-array args are bit-arrays with
131  ; compatible dimensions.  If "result" is specified as T,
132  ; return bit-array-1.  If result is unspecified, return
133  ; a new bit-array of the same dimensions as bit-array-2.
134  ; Otherwise, make sure that result is a bit-array of the
135  ; same dimensions as the other two arguments and return
136  ; it.
137  (let* ((typecode-1 (typecode bit-array-1))
138         (typecode-2 (typecode bit-array-2)))
139    (declare (fixnum typecode-1 typecode-2))
140    (flet ((bit-array-dimensions (bit-array typecode)
141             (declare (fixnum typecode))
142             (if (= typecode target::subtag-bit-vector)
143               (uvsize bit-array)
144               (let* ((array-p (= typecode target::subtag-arrayH))
145                      (vector-p (= typecode target::subtag-vectorH)))
146                 (if (and (or array-p vector-p) 
147                          (= (the fixnum (%array-header-subtype bit-array)) target::subtag-bit-vector))
148                   (if vector-p
149                     (array-dimension bit-array 0)
150                     (array-dimensions bit-array))
151                   (report-bad-arg bit-array '(array bit))))))
152           (check-matching-dimensions (a1 d1 a2 d2)
153             (unless (equal d1 d2)
154               (error "~s and ~s have different dimensions." a1 a2))
155             a2))
156      (let* ((dims-1 (bit-array-dimensions bit-array-1 typecode-1))
157             (dims-2 (bit-array-dimensions bit-array-2 typecode-2)))
158        (check-matching-dimensions bit-array-1 dims-1 bit-array-2 dims-2)
159        (if result
160          (if (eq result t)
161            bit-array-1
162            (check-matching-dimensions bit-array-2 dims-2 result (bit-array-dimensions result (typecode result))))
163          (make-array dims-2 :element-type 'bit :initial-element 0))))))
164
165
166
167
168 
169(defun bit-boole (opcode array1 array2 result-array)
170  (unless (eql opcode (logand 15 opcode))
171    (setq opcode (require-type opcode '(mod 16))))
172  (let* ((result (result-bit-array array1 array2 result-array)))
173    (if (and (typep array1 'simple-bit-vector)
174             (typep array2 'simple-bit-vector)
175             (typep result 'simple-bit-vector))
176      (%simple-bit-boole opcode array1 array2 result)
177      (multiple-value-bind (v1 i1) (array-data-and-offset array1)
178        (declare (simple-bit-vector v1) (fixnum i1))
179        (multiple-value-bind (v2 i2) (array-data-and-offset array2)
180          (declare (simple-bit-vector v2) (fixnum i2))
181          (multiple-value-bind (v3 i3) (array-data-and-offset result)
182            (declare (simple-bit-vector v3) (fixnum i3))
183            (let* ((e3 (+ i3 (the fixnum (array-total-size result)))))
184              (declare (fixnum e3))
185              (do* ( )
186                   ((= i3 e3) result)
187                (setf (sbit v3 i3) 
188                      (logand (boole opcode (sbit v1 i1) (sbit v2 i2)) 1))
189                (incf i1)
190                (incf i2)
191                (incf i3)))))))))
192
193
194         
195         
196
197
198
199
200; shrink-vector is called only in sequences-2. None of the calls depend on
201; the side affect of setting the passed-in symbol to the [possibly new]
202; returned vector
203; Since there hasn't been such a thing as sequences-2 in about 7 years,
204; this is especially puzzling.
205(eval-when (:compile-toplevel :execute :load-toplevel)
206  (defmacro shrink-vector (vector to-size)
207    `(setq ,vector (%shrink-vector ,vector ,to-size)))
208  )
209
210
211; new and faulty def
212(defun %shrink-vector (vector to-size)
213  (cond ((eq (length vector) to-size)
214         vector)
215        ((array-has-fill-pointer-p vector)
216         (setf (fill-pointer vector) to-size)
217         vector)
218        (t (subseq vector 0 to-size))))
219
220
221; this could be put into print-db as it was in ccl-pr-4.2
222; Or it (and print-db) could just be flushed ... tough one.
223(defun multi-dimension-array-to-list (array)
224  "Produces a nested list of the elements in array."
225  (mdal-aux array (array-dimensions array) nil 
226            (array-dimensions array)))
227
228(defun mdal-aux (array all-dimensions use-dimensions 
229                       remaining-dimensions)
230  (if (= (length all-dimensions) (length use-dimensions))
231    (apply 'aref array use-dimensions)
232    (do ((index 0 (1+ index))
233         (d-length (car remaining-dimensions))
234         (result nil))
235        ((= d-length index) result)
236      (setq result 
237            (append result (list (mdal-aux array all-dimensions
238                                           (append use-dimensions 
239                                                   (list index))
240                                           (cdr remaining-dimensions))))))))
241
242(defun adjust-array (array dims
243                           &key (element-type nil element-type-p)
244                           (initial-element nil initial-element-p)
245                           (initial-contents nil initial-contents-p)
246                           (fill-pointer nil fill-pointer-p)
247                           displaced-to
248                           displaced-index-offset
249                           &aux (subtype (array-element-subtype array)))
250  "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
251  (when (and element-type-p
252             (neq (element-type-subtype element-type) subtype))
253    (error "~S is not of element type ~S" array element-type))
254  (when (integerp dims)(setq dims (list dims))) ; because %displace-array wants the list
255  (if (neq (list-length dims)(array-rank array))
256    (error "~S has wrong rank for adjusting to dimensions ~S" array dims))
257  (let ((size 1)
258        (explicitp nil))
259    (dolist (dim dims)
260      (when (< dim 0)(report-bad-arg dims '(integer 0 *)))
261      (setq size (* size dim)))
262    (when (and (neq fill-pointer t)
263               (array-has-fill-pointer-p array)
264               (< size (or fill-pointer (fill-pointer array))))
265      (error "Cannot adjust array ~S to size less than fill pointer ~S"
266             array (or fill-pointer (fill-pointer array))))
267    (when (and fill-pointer (not (array-has-fill-pointer-p array)))
268      (error "~S does not have a fill pointer" array))
269    (when (and displaced-index-offset (null displaced-to))
270      (error "Cannot specify ~S without ~S" :displaced-index-offset :displaced-to))
271    (when (and initial-element-p initial-contents-p)
272      (error "Cannot specify both ~S and ~S" :initial-element :initial-contents))
273    (cond 
274      ((not (adjustable-array-p array))
275       (let ((new-array (make-array-1  dims 
276                                       (array-element-type array) T
277                                       displaced-to
278                                       displaced-index-offset
279                                       nil
280                                       (or fill-pointer
281                                           (and (array-has-fill-pointer-p array)
282                                                (fill-pointer array)))
283                                       initial-element initial-element-p
284                                       initial-contents initial-contents-p
285                                       size)))
286                     
287         (when (and (null initial-contents-p)
288                    (null displaced-to))
289           (multiple-value-bind (array-data offs) (array-data-and-offset array)
290             (let ((new-array-data (array-data-and-offset new-array))) 
291               (cond ((null dims)
292                      (uvset new-array-data 0 (uvref array-data offs)))
293                     (T
294                      (init-array-data array-data offs (array-dimensions array) 
295                                       new-array-data 0 dims))))))
296         (setq array new-array)))
297      (T (cond 
298           (displaced-to
299            (if (and displaced-index-offset 
300                     (or (not (fixnump displaced-index-offset))
301                         (< displaced-index-offset 0)))
302              (report-bad-arg displaced-index-offset '(integer 0 #.most-positive-fixnum)))
303            (when (or initial-element-p initial-contents-p)
304              (error "Cannot specify initial values for displaced arrays"))
305            (unless (eq subtype (array-element-subtype displaced-to))
306              (error "~S is not of element type ~S"
307                     displaced-to (array-element-type array)))
308            (do* ((vec displaced-to (displaced-array-p vec)))
309                 ((null vec) ())
310              (when (eq vec array)
311                (error "Array cannot be displaced to itself.")))
312            (setq explicitp t))
313           (T
314            (setq displaced-to (%alloc-misc size subtype))
315            (cond (initial-element-p
316                   (dotimes (i (the fixnum size)) (uvset displaced-to i initial-element)))
317                  (initial-contents-p
318                   (if (null dims) (uvset displaced-to 0 initial-contents)
319                     (init-uvector-contents displaced-to 0 dims initial-contents))))
320            (cond ((null dims)
321                   (uvset displaced-to 0 (aref array)))
322                  ((not initial-contents-p)
323                   (multiple-value-bind (vec offs) (array-data-and-offset array)
324                     (init-array-data vec offs (array-dimensions array) displaced-to 0 dims))))))
325         (%displace-array array dims size displaced-to (or displaced-index-offset 0) explicitp)))
326    (when fill-pointer-p
327      (cond
328        ((eq fill-pointer t)
329         (set-fill-pointer array size))
330        (fill-pointer
331         (set-fill-pointer array fill-pointer))))
332    array))
333
334(defun array-dims-sizes (dims)
335   (if (or (atom dims) (null (%cdr dims))) dims
336     (let ((ndims (array-dims-sizes (%cdr dims))))
337       (cons (* (%car dims) (%car ndims)) ndims))))
338
339(defun init-array-data (vec off dims nvec noff ndims)
340   (init-array-data-aux vec off dims (array-dims-sizes (cdr dims))
341                        nvec noff ndims (array-dims-sizes (cdr ndims))))
342
343(defun init-array-data-aux (vec off dims siz nvec noff ndims nsiz)
344   (when (null siz)
345      (return-from init-array-data-aux
346         (init-vector-data vec off (car dims) nvec noff (car ndims))))
347   (let ((count (pop dims))
348         (size (pop siz))
349         (ncount (pop ndims))
350         (nsize (pop nsiz)))
351     (dotimes (i (if (%i< count ncount) count ncount))
352        (declare (fixnum i))
353        (init-array-data-aux vec off dims siz nvec noff ndims nsiz)
354        (setq off (%i+ off size) noff (%i+ noff nsize)))))
355
356(defun init-vector-data (vec off len nvec noff nlen)
357  (dotimes (i (if (%i< len nlen) len nlen))
358     (declare (fixnum i))
359     (uvset nvec noff (uvref vec off))
360     (setq off (%i+ off 1) noff (%i+ noff 1))))
361
362;;; only caller is adjust-array
363
364(defun %displace-array (array dims size data offset explicitp)
365  (let* ((typecode (typecode array))
366         (array-p (eql typecode target::subtag-arrayH))
367         (vector-p (eql typecode target::subtag-vectorH)))
368    (unless (or array-p vector-p)
369      (error "Array ~S cannot be displaced" array))
370    (unless (fixnump offset) (report-bad-arg offset '(integer 0 #.most-positive-fixnum)))
371    (unless (adjustable-array-p data)
372      (multiple-value-bind (ndata noffset) (displaced-array-p data)
373        (if ndata (setq data ndata offset (%i+ offset noffset)))))
374    (unless (and (fixnump size) (%i<= (%i+ offset size) (array-total-size data)))
375      (error "Offset ~S + size ~S must be less than size of array displaced-to" offset size))
376    (let* ((flags (%svref array target::vectorH.flags-cell)))
377      (declare (fixnum flags))
378      (setf (%svref array target::vectorH.flags-cell)
379            (if (> (the fixnum (typecode data)) target::subtag-vectorH)
380              (bitclr $arh_disp_bit flags)
381              (bitset $arh_disp_bit flags)))
382      (setf (%svref array target::vectorH.flags-cell)
383            (if explicitp
384              (bitset $arh_exp_disp_bit flags)
385              (bitclr $arh_exp_disp_bit flags)))
386      (setf (%svref array target::arrayH.data-vector-cell) data)
387      (if array-p
388        (progn
389          (do ((i target::arrayH.dim0-cell (1+ i)))
390              ((null dims))
391            (declare (fixnum i))
392            (setf (%svref array i) (pop dims)))
393          (setf (%svref array target::arrayH.physsize-cell) size)
394          (setf (%svref array target::arrayH.displacement-cell) offset))
395        (progn
396          (if (or (not (logbitp $arh_fill_bit flags))
397                  (> (the fixnum (%svref array target::vectorH.logsize-cell)) size))
398            (setf (%svref array target::vectorH.logsize-cell) size))
399          (setf (%svref array target::vectorH.physsize-cell) size)
400          (setf (%svref array target::vectorH.displacement-cell) offset)))
401      array)))
402
403
404
405(defun array-row-major-index (array &lexpr subscripts)
406  (let ((rank  (array-rank array))
407        (nsubs (%lexpr-count subscripts))
408        (sum 0))
409    (declare (fixnum sum rank))
410    (unless (eql rank nsubs)
411      (%err-disp $xndims array nsubs))   
412      (if (eql 0 rank)
413        0
414        (do* ((i (1- rank) (1- i))
415              (dim (array-dimension array i) (array-dimension array i))
416              (last-size 1 size)
417              (size dim (* dim size)))
418             (nil)
419          (declare (fixnum i last-size size))
420          (let ((s (%lexpr-ref subscripts nsubs i)))
421            (unless (fixnump s)
422              (setq s (require-type s 'fixnum)))
423            (when (or (< s 0) (>= s dim))
424              (%err-disp $XARROOB (%apply-lexpr 'list subscripts) array))
425            (incf sum (the fixnum (* s last-size)))
426            (when (eql i 0) (return sum)))))))
427
428(defun array-in-bounds-p (array &lexpr subscripts)
429  "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
430  (let ((rank  (array-rank array))
431        (nsubs (%lexpr-count subscripts)))
432    (declare (fixnum nsubs rank))   
433    (if (not (eql nsubs rank))
434      (%err-disp $xndims array nsubs)
435      (if (eql 0 rank)
436        0
437        (do* ((i (1- rank) (1- i))
438              (dim (array-dimension array i) (array-dimension array i)))
439             (nil)
440          (declare (fixnum i dim))
441          (let ((s  (%lexpr-ref subscripts nsubs i)))
442            (if (typep s 'fixnum)
443              (locally (declare (fixnum s))
444                (if (or (< s 0)(>= s dim)) (return nil)))
445              (if (typep s 'bignum)
446                (return nil)
447                (report-bad-arg s 'integer)))
448            (when (eql i 0) (return t))))))))
449
450(defun row-major-aref (array index)
451  "Return the element of array corressponding to the row-major index. This is
452   SETF'able."
453  (multiple-value-bind (displaced-to offset) (displaced-array-p array)
454    (aref (or displaced-to array) (+ index offset))))
455
456(defun row-major-aset (array index new)
457  (multiple-value-bind (displaced-to offset) (displaced-array-p array)
458    (setf (aref (or displaced-to array) (+ index offset)) new)))
459
460(defsetf row-major-aref row-major-aset)
461             
462
463
464; end
Note: See TracBrowser for help on using the repository browser.