source: trunk/ccl/lib/arrays-fry.lisp @ 1968

Last change on this file since 1968 was 1968, checked in by gb, 14 years ago

target:: package prefix.

  • 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) 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
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
223; this could be put into print-db as it was in ccl-pr-4.2
224; Or it (and print-db) could just be flushed ... tough one.
225(defun multi-dimension-array-to-list (array)
226  "Produces a nested list of the elements in array."
227  (mdal-aux array (array-dimensions array) nil 
228            (array-dimensions array)))
229
230(defun mdal-aux (array all-dimensions use-dimensions 
231                       remaining-dimensions)
232  (if (= (length all-dimensions) (length use-dimensions))
233    (apply 'aref array use-dimensions)
234    (do ((index 0 (1+ index))
235         (d-length (car remaining-dimensions))
236         (result nil))
237        ((= d-length index) result)
238      (setq result 
239            (append result (list (mdal-aux array all-dimensions
240                                           (append use-dimensions 
241                                                   (list index))
242                                           (cdr remaining-dimensions))))))))
243
244(defun adjust-array (array dims
245                           &key (element-type nil element-type-p)
246                           (initial-element nil initial-element-p)
247                           (initial-contents nil initial-contents-p)
248                           (fill-pointer nil fill-pointer-p)
249                           displaced-to
250                           displaced-index-offset
251                           &aux (subtype (array-element-subtype array)))
252  "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
253  (when (and element-type-p
254             (neq (element-type-subtype element-type) subtype))
255    (error "~S is not of element type ~S" array element-type))
256  (when (integerp dims)(setq dims (list dims))) ; because %displace-array wants the list
257  (if (neq (list-length dims)(array-rank array))
258    (error "~S has wrong rank for adjusting to dimensions ~S" array dims))
259  (let ((size 1)
260        (explicitp nil))
261    (dolist (dim dims)
262      (when (< dim 0)(report-bad-arg dims '(integer 0 *)))
263      (setq size (* size dim)))
264    (when (and (neq fill-pointer t)
265               (array-has-fill-pointer-p array)
266               (< size (or fill-pointer (fill-pointer array))))
267      (error "Cannot adjust array ~S to size less than fill pointer ~S"
268             array (or fill-pointer (fill-pointer array))))
269    (when (and fill-pointer (not (array-has-fill-pointer-p array)))
270      (error "~S does not have a fill pointer" array))
271    (when (and displaced-index-offset (null displaced-to))
272      (error "Cannot specify ~S without ~S" :displaced-index-offset :displaced-to))
273    (when (and initial-element-p initial-contents-p)
274      (error "Cannot specify both ~S and ~S" :initial-element :initial-contents))
275    (cond 
276      ((not (adjustable-array-p array))
277       (let ((new-array (make-array-1  dims 
278                                       (array-element-type array) T
279                                       displaced-to
280                                       displaced-index-offset
281                                       nil
282                                       (or fill-pointer
283                                           (and (array-has-fill-pointer-p array)
284                                                (fill-pointer array)))
285                                       initial-element initial-element-p
286                                       initial-contents initial-contents-p
287                                       size)))
288                     
289         (when (and (null initial-contents-p)
290                    (null displaced-to))
291           (multiple-value-bind (array-data offs) (array-data-and-offset array)
292             (let ((new-array-data (array-data-and-offset new-array))) 
293               (cond ((null dims)
294                      (uvset new-array-data 0 (uvref array-data offs)))
295                     (T
296                      (init-array-data array-data offs (array-dimensions array) 
297                                       new-array-data 0 dims))))))
298         (setq array new-array)))
299      (T (cond 
300           (displaced-to
301            (if (and displaced-index-offset 
302                     (or (not (fixnump displaced-index-offset))
303                         (< displaced-index-offset 0)))
304              (report-bad-arg displaced-index-offset '(integer 0 #.most-positive-fixnum)))
305            (when (or initial-element-p initial-contents-p)
306              (error "Cannot specify initial values for displaced arrays"))
307            (unless (eq subtype (array-element-subtype displaced-to))
308              (error "~S is not of element type ~S"
309                     displaced-to (array-element-type array)))
310            (do* ((vec displaced-to (displaced-array-p vec)))
311                 ((null vec) ())
312              (when (eq vec array)
313                (error "Array cannot be displaced to itself.")))
314            (setq explicitp t))
315           (T
316            (setq displaced-to (%alloc-misc size subtype))
317            (cond (initial-element-p
318                   (dotimes (i (the fixnum size)) (uvset displaced-to i initial-element)))
319                  (initial-contents-p
320                   (if (null dims) (uvset displaced-to 0 initial-contents)
321                     (init-uvector-contents displaced-to 0 dims initial-contents))))
322            (cond ((null dims)
323                   (uvset displaced-to 0 (aref array)))
324                  ((not initial-contents-p)
325                   (multiple-value-bind (vec offs) (array-data-and-offset array)
326                     (init-array-data vec offs (array-dimensions array) displaced-to 0 dims))))))
327         (%displace-array array dims size displaced-to (or displaced-index-offset 0) explicitp)))
328    (when fill-pointer-p
329      (cond
330        ((eq fill-pointer t)
331         (set-fill-pointer array size))
332        (fill-pointer
333         (set-fill-pointer array fill-pointer))))
334    array))
335
336(defun array-dims-sizes (dims)
337   (if (or (atom dims) (null (%cdr dims))) dims
338     (let ((ndims (array-dims-sizes (%cdr dims))))
339       (cons (* (%car dims) (%car ndims)) ndims))))
340
341(defun init-array-data (vec off dims nvec noff ndims)
342   (init-array-data-aux vec off dims (array-dims-sizes (cdr dims))
343                        nvec noff ndims (array-dims-sizes (cdr ndims))))
344
345(defun init-array-data-aux (vec off dims siz nvec noff ndims nsiz)
346   (when (null siz)
347      (return-from init-array-data-aux
348         (init-vector-data vec off (car dims) nvec noff (car ndims))))
349   (let ((count (pop dims))
350         (size (pop siz))
351         (ncount (pop ndims))
352         (nsize (pop nsiz)))
353     (dotimes (i (if (%i< count ncount) count ncount))
354        (declare (fixnum i))
355        (init-array-data-aux vec off dims siz nvec noff ndims nsiz)
356        (setq off (%i+ off size) noff (%i+ noff nsize)))))
357
358(defun init-vector-data (vec off len nvec noff nlen)
359  (dotimes (i (if (%i< len nlen) len nlen))
360     (declare (fixnum i))
361     (uvset nvec noff (uvref vec off))
362     (setq off (%i+ off 1) noff (%i+ noff 1))))
363
364;;; only caller is adjust-array
365
366(defun %displace-array (array dims size data offset explicitp)
367  (let* ((typecode (typecode array))
368         (array-p (eql typecode target::subtag-arrayH))
369         (vector-p (eql typecode target::subtag-vectorH)))
370    (unless (or array-p vector-p)
371      (error "Array ~S cannot be displaced" array))
372    (unless (fixnump offset) (report-bad-arg offset '(integer 0 #.most-positive-fixnum)))
373    (unless (adjustable-array-p data)
374      (multiple-value-bind (ndata noffset) (displaced-array-p data)
375        (if ndata (setq data ndata offset (%i+ offset noffset)))))
376    (unless (and (fixnump size) (%i<= (%i+ offset size) (array-total-size data)))
377      (error "Offset ~S + size ~S must be less than size of array displaced-to" offset size))
378    (let* ((flags (%svref array target::vectorH.flags-cell)))
379      (declare (fixnum flags))
380      (setf (%svref array target::vectorH.flags-cell)
381            (if (> (the fixnum (typecode data)) target::subtag-vectorH)
382              (bitclr $arh_disp_bit flags)
383              (bitset $arh_disp_bit flags)))
384      (setf (%svref array target::vectorH.flags-cell)
385            (if explicitp
386              (bitset $arh_exp_disp_bit flags)
387              (bitclr $arh_exp_disp_bit flags)))
388      (setf (%svref array target::arrayH.data-vector-cell) data)
389      (if array-p
390        (progn
391          (do ((i target::arrayH.dim0-cell (1+ i)))
392              ((null dims))
393            (declare (fixnum i))
394            (setf (%svref array i) (pop dims)))
395          (setf (%svref array target::arrayH.physsize-cell) size)
396          (setf (%svref array target::arrayH.displacement-cell) offset))
397        (progn
398          (if (or (not (logbitp $arh_fill_bit flags))
399                  (> (the fixnum (%svref array target::vectorH.logsize-cell)) size))
400            (setf (%svref array target::vectorH.logsize-cell) size))
401          (setf (%svref array target::vectorH.physsize-cell) size)
402          (setf (%svref array target::vectorH.displacement-cell) offset)))
403      array)))
404
405
406
407(defun array-row-major-index (array &lexpr subscripts)
408  (let ((rank  (array-rank array))
409        (nsubs (%lexpr-count subscripts))
410        (sum 0))
411    (declare (fixnum sum rank))
412    (unless (eql rank nsubs)
413      (%err-disp $xndims array nsubs))   
414      (if (eql 0 rank)
415        0
416        (do* ((i (1- rank) (1- i))
417              (dim (array-dimension array i) (array-dimension array i))
418              (last-size 1 size)
419              (size dim (* dim size)))
420             (nil)
421          (declare (fixnum i last-size size))
422          (let ((s (%lexpr-ref subscripts nsubs i)))
423            (unless (fixnump s)
424              (setq s (require-type s 'fixnum)))
425            (when (or (< s 0) (>= s dim))
426              (%err-disp $XARROOB (%apply-lexpr 'list subscripts) array))
427            (incf sum (the fixnum (* s last-size)))
428            (when (eql i 0) (return sum)))))))
429
430(defun array-in-bounds-p (array &lexpr subscripts)
431  "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
432  (let ((rank  (array-rank array))
433        (nsubs (%lexpr-count subscripts)))
434    (declare (fixnum nsubs rank))   
435    (if (not (eql nsubs rank))
436      (%err-disp $xndims array nsubs)
437      (if (eql 0 rank)
438        0
439        (do* ((i (1- rank) (1- i))
440              (dim (array-dimension array i) (array-dimension array i)))
441             (nil)
442          (declare (fixnum i dim))
443          (let ((s  (%lexpr-ref subscripts nsubs i)))
444            (if (typep s 'fixnum)
445              (locally (declare (fixnum s))
446                (if (or (< s 0)(>= s dim)) (return nil)))
447              (if (typep s 'bignum)
448                (return nil)
449                (report-bad-arg s 'integer)))
450            (when (eql i 0) (return t))))))))
451
452(defun row-major-aref (array index)
453  "Return the element of array corressponding to the row-major index. This is
454   SETF'able."
455  (multiple-value-bind (displaced-to offset) (displaced-array-p array)
456    (aref (or displaced-to array) (+ index offset))))
457
458(defun row-major-aset (array index new)
459  (multiple-value-bind (displaced-to offset) (displaced-array-p array)
460    (setf (aref (or displaced-to array) (+ index offset)) new)))
461
462(defsetf row-major-aref row-major-aset)
463             
464
465
466; end
Note: See TracBrowser for help on using the repository browser.