source: branches/qres/ccl/lib/arrays-fry.lisp

Last change on this file was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

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