/[cmucl]/src/code/array.lisp
ViewVC logotype

Contents of /src/code/array.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (show annotations)
Mon Jul 26 17:20:26 2010 UTC (3 years, 8 months ago) by rtoy
Branch: MAIN
CVS Tags: release-20b-pre1, release-20b-pre2, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, cross-sol-x86-branch
Changes since 1.54: +19 -10 lines
compiler/fndb.lisp:
o Tell compiler that the :allocation option to make-array only takes
  nil and :malloc.

code/array.lisp:
o Add declaration for :allocation to make-array so that we can catch
  invalid values for :allocation.
o Add variable *debug-static-array-p* to enable debugging messages
  when GC'ing static arrays.
1 ;;; -*- Log: code.log; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/array.lisp,v 1.55 2010/07/26 17:20:26 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Functions to implement arrays for CMU Common Lisp.
13 ;;; Written by Skef Wholey.
14 ;;; Worked over for the MIPS port by William Lott.
15 ;;;
16 (in-package "LISP")
17
18 (intl:textdomain "cmucl")
19
20 (export '(array-rank-limit array-dimension-limit array-total-size-limit
21 make-array vector aref array-element-type array-rank
22 array-dimension array-dimensions array-in-bounds-p
23 array-row-major-index array-total-size svref bit sbit
24 bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
25 bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p
26 fill-pointer vector-push vector-push-extend vector-pop adjust-array
27 adjustable-array-p row-major-aref array-displacement))
28
29 (in-package "KERNEL")
30 (export '(%with-array-data))
31 (in-package "LISP")
32
33 (declaim (inline fill-pointer array-has-fill-pointer-p adjustable-array-p
34 array-displacement))
35
36 (defconstant array-rank-limit 65529
37 "The exclusive upper bound on the rank of an array.")
38
39 (defconstant array-dimension-limit most-positive-fixnum
40 "The exclusive upper bound any given dimension of an array.")
41
42 (defconstant array-total-size-limit most-positive-fixnum
43 "The exclusive upper bound on the total number of elements in an array.")
44
45
46
47 ;;;; Random accessor functions.
48
49 ;;; These functions are needed by the interpreter, 'cause the compiler inlines
50 ;;; them.
51
52 (macrolet ((frob (name)
53 `(progn
54 (defun ,name (array)
55 (,name array))
56 (defun (setf ,name) (value array)
57 (setf (,name array) value)))))
58 (frob %array-fill-pointer)
59 (frob %array-fill-pointer-p)
60 (frob %array-available-elements)
61 (frob %array-data-vector)
62 (frob %array-displacement)
63 (frob %array-displaced-p))
64
65 (defun %array-rank (array)
66 (%array-rank array))
67
68 (defun %array-dimension (array axis)
69 (%array-dimension array axis))
70
71 (defun %set-array-dimension (array axis value)
72 (%set-array-dimension array axis value))
73
74 (defun %check-bound (array bound index)
75 (declare (type index bound)
76 (fixnum index))
77 (%check-bound array bound index))
78
79 ;;; %WITH-ARRAY-DATA -- Interface
80 ;;;
81 ;;; The guts of the WITH-ARRAY-DATA macro (in sysmacs). Note that this
82 ;;; function is only called if we have an array header or an error, so it
83 ;;; doesn't have to be too tense.
84 ;;;
85 (defun %with-array-data (array start end)
86 (declare (array array) (type index start) (type (or index null) end)
87 (values (simple-array * (*)) index index index))
88 (let* ((size (array-total-size array))
89 (end (cond (end
90 (unless (<= end size)
91 (error (intl:gettext "End ~D is greater than total size ~D.")
92 end size))
93 end)
94 (t size))))
95 (when (> start end)
96 (error (intl:gettext "Start ~D is greater than end ~D.") start end))
97 (do ((data array (%array-data-vector data))
98 (cumulative-offset 0
99 (+ cumulative-offset
100 (%array-displacement data))))
101 ((not (array-header-p data))
102 (values data
103 (+ cumulative-offset start)
104 (+ cumulative-offset end)
105 cumulative-offset))
106 (declare (type index cumulative-offset)))))
107
108
109 ;;;; MAKE-ARRAY
110
111 (eval-when (:compile-toplevel :execute)
112
113 (defmacro pick-type (type &rest specs)
114 `(cond ,@(mapcar #'(lambda (spec)
115 `(,(if (eq (car spec) t)
116 t
117 `(subtypep ,type ',(car spec)))
118 ,@(cdr spec)))
119 specs)))
120
121 ); eval-when
122
123
124 (defun %vector-type-code (type)
125 (pick-type type
126 (base-char (values #.vm:simple-string-type #.vm:char-bits))
127 (bit (values #.vm:simple-bit-vector-type 1))
128 ((unsigned-byte 2) (values #.vm:simple-array-unsigned-byte-2-type 2))
129 ((unsigned-byte 4) (values #.vm:simple-array-unsigned-byte-4-type 4))
130 ((unsigned-byte 8) (values #.vm:simple-array-unsigned-byte-8-type 8))
131 ((unsigned-byte 16) (values #.vm:simple-array-unsigned-byte-16-type 16))
132 ((unsigned-byte 32) (values #.vm:simple-array-unsigned-byte-32-type 32))
133 ((signed-byte 8) (values #.vm:simple-array-signed-byte-8-type 8))
134 ((signed-byte 16) (values #.vm:simple-array-signed-byte-16-type 16))
135 ((signed-byte 30) (values #.vm:simple-array-signed-byte-30-type 32))
136 ((signed-byte 32) (values #.vm:simple-array-signed-byte-32-type 32))
137 (single-float (values #.vm:simple-array-single-float-type 32))
138 (double-float (values #.vm:simple-array-double-float-type 64))
139 #+long-float
140 (long-float
141 (values #.vm:simple-array-long-float-type #+x86 96 #+sparc 128))
142 #+double-double
143 (double-double-float
144 (values #.vm::simple-array-double-double-float-type 128))
145 ((complex single-float)
146 (values #.vm:simple-array-complex-single-float-type 64))
147 ((complex double-float)
148 (values #.vm:simple-array-complex-double-float-type 128))
149 #+long-float
150 ((complex long-float)
151 (values #.vm:simple-array-complex-long-float-type #+x86 192 #+sparc 256))
152 #+double-double
153 ((complex double-double-float)
154 (values #.vm::simple-array-complex-double-double-float-type 256))
155 (t (values #.vm:simple-vector-type #.vm:word-bits))))
156
157 (defun %complex-vector-type-code (type)
158 (pick-type type
159 (base-char #.vm:complex-string-type)
160 (bit #.vm:complex-bit-vector-type)
161 (t #.vm:complex-vector-type)))
162
163 (defvar *static-vectors* nil
164 "List of weak-pointers to static vectors. Needed for GCing static vectors")
165
166 (defun make-static-vector (length element-type)
167 (multiple-value-bind (type bits)
168 (lisp::%vector-type-code element-type)
169 ;; What types of static arrays do we really want to allow?
170 ;; Whatever we choose, we definitely cannot allow arrays with the
171 ;; following element types: T, (signed-byte 30)
172 (unless (member type
173 '(#.vm:simple-string-type
174 #.vm:simple-array-unsigned-byte-8-type
175 #.vm:simple-array-unsigned-byte-16-type
176 #.vm:simple-array-unsigned-byte-32-type
177 #.vm:simple-array-signed-byte-8-type
178 #.vm:simple-array-signed-byte-16-type
179 #.vm:simple-array-signed-byte-32-type
180 #.vm:simple-array-single-float-type
181 #.vm:simple-array-double-float-type
182 #.vm:simple-array-complex-single-float-type
183 #.vm:simple-array-complex-double-float-type))
184 (error (intl:gettext "Cannot make a static array of element type ~S") element-type))
185 ;; Malloc space for the vector. We need enough space for the data
186 ;; itself, and then 2 words for the vector header (header word and
187 ;; length). Use calloc to make sure the area is initialized to
188 ;; zeros, like normal Lisp arrays are.
189 (let* ((data-bytes (ceiling (* length bits) 8))
190 (total-bytes (+ data-bytes (* 2 vm:word-bytes))))
191 (sys:without-gcing
192 (let ((pointer (alien:alien-funcall (alien:extern-alien "calloc"
193 (function sys::system-area-pointer
194 unix::size-t
195 unix::size-t))
196 total-bytes
197 1)))
198 ;; Malloc should return double-word (8 byte) alignment.
199 (assert (zerop (logand 7 (sys:sap-int pointer))))
200 (when (zerop (sys:sap-int pointer))
201 (error (intl:gettext "Failed to allocate space for static array of length ~S of type ~S")
202 length element-type))
203
204 ;; Fill in the vector header word and length word. Set the data
205 ;; portion of the header word (normally 0) to 1 so we know this
206 ;; is a static vector.
207 (setf (sys:sap-ref-32 pointer 0) (+ type (ash 1 vm:type-bits)))
208 (setf (sys:sap-ref-32 pointer vm:word-bytes) (ash length 2))
209 ;; Convert the sap to a lisp object and initialize the array
210 (let ((vector
211 (kernel:make-lisp-obj (+ vm:other-pointer-type (sys:sap-int pointer)))))
212 (push (make-weak-pointer vector) *static-vectors*)
213 vector))))))
214
215 (defun make-array (dimensions &key
216 (element-type t)
217 (initial-element nil initial-element-p)
218 (initial-contents nil initial-contents-p)
219 adjustable fill-pointer
220 displaced-to displaced-index-offset
221 allocation)
222 "Creates an array of the specified Dimensions and properties. See the
223 manual for details.
224
225 :Element-type
226 The type of objects that the array can hold
227 :Initial-element
228 Each element of the array is initialized to this value, if supplied.
229 If not supplied, 0 of the appropriate type is used.
230 :Initial-contents
231 The contents of the array are initialized to this.
232 :Adjustable
233 If non-Nil, make an expressly adjustable array.
234 :Fill-pointer
235 For one-dimensional array, set the fill-pointer to the given value.
236 If T, use the actual length of the array.
237 :Displaced-to
238 Create an array that is displaced to the target array specified
239 by :displaced-to.
240 :Displaced-index-offset
241 Index offset to the displaced array. That is, index 0 of this array is
242 actually index displaced-index-offset of the target displaced array.
243 :Allocation
244 How to allocate the array. If :MALLOC, a static, nonmovable array is
245 created. This array is created by calling malloc."
246 (declare (type (member nil :malloc) allocation))
247 (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
248 (array-rank (length (the list dimensions)))
249 (static-array-p (eq allocation :malloc))
250 (simple (and (null fill-pointer)
251 (not adjustable)
252 (null displaced-to))))
253 (declare (fixnum array-rank))
254 (when (and displaced-index-offset (null displaced-to))
255 (error (intl:gettext "Can't specify :displaced-index-offset without :displaced-to")))
256 (when (and adjustable static-array-p)
257 (error (intl:gettext "Cannot make an adjustable static array")))
258 (when (and displaced-to static-array-p)
259 (error (intl:gettext "Cannot make a displaced array static")))
260 (if (and simple (= array-rank 1))
261 ;; It's a (simple-array * (*))
262 (multiple-value-bind (type bits)
263 (%vector-type-code element-type)
264 (declare (type (unsigned-byte 8) type)
265 (type (integer 1 256) bits))
266 (let* ((length (car dimensions))
267 (array (if static-array-p
268 (make-static-vector length element-type)
269 (allocate-vector
270 type
271 length
272 (ceiling (* (if (= type vm:simple-string-type)
273 (1+ length)
274 length)
275 bits)
276 vm:word-bits)))))
277 (declare (type index length))
278 (when initial-element-p
279 (fill array initial-element))
280 (when initial-contents-p
281 (when initial-element-p
282 (error (intl:gettext "Cannot specify both :initial-element and ~
283 :initial-contents")))
284 (unless (= length (length initial-contents))
285 (error (intl:gettext "~D elements in the initial-contents, but the ~
286 vector length is ~D.")
287 (length initial-contents)
288 length))
289 (replace array initial-contents))
290 array))
291 ;; It's either a complex array or a multidimensional array.
292 (let* ((total-size (reduce #'* dimensions))
293 (data (or displaced-to
294 (data-vector-from-inits
295 dimensions total-size element-type
296 initial-contents initial-contents-p
297 initial-element initial-element-p
298 static-array-p)))
299 (array (make-array-header
300 (cond ((= array-rank 1)
301 (%complex-vector-type-code element-type))
302 (simple vm:simple-array-type)
303 (t vm:complex-array-type))
304 array-rank)))
305 (cond (fill-pointer
306 (unless (= array-rank 1)
307 (error (intl:gettext "Only vectors can have fill pointers.")))
308 (let ((length (car dimensions)))
309 (declare (fixnum length))
310 (setf (%array-fill-pointer array)
311 (cond ((eq fill-pointer t)
312 length)
313 (t
314 (unless (and (fixnump fill-pointer)
315 (>= fill-pointer 0)
316 (<= fill-pointer length))
317 (error (intl:gettext "Invalid fill-pointer ~D")
318 fill-pointer))
319 fill-pointer))))
320 (setf (%array-fill-pointer-p array) t))
321 (t
322 (setf (%array-fill-pointer array) total-size)
323 (setf (%array-fill-pointer-p array) nil)))
324 (setf (%array-available-elements array) total-size)
325 (setf (%array-data-vector array) data)
326 (cond (displaced-to
327 (when (or initial-element-p initial-contents-p)
328 (error (intl:gettext "Neither :initial-element nor :initial-contents ~
329 can be specified along with :displaced-to")))
330 ;; The CLHS entry for MAKE-ARRAY says that if the
331 ;; actual array element types are not type equivalent
332 ;; (subtypes of each other), the consequences are
333 ;; undefined. Let's signal an error here.
334 (unless (and (subtypep (upgraded-array-element-type element-type)
335 (array-element-type displaced-to))
336 (subtypep (array-element-type displaced-to)
337 (upgraded-array-element-type element-type)))
338 (error (intl:gettext "One can't displace an array of type ~S into ~
339 another of type ~S.")
340 element-type (array-element-type displaced-to)))
341 (let ((offset (or displaced-index-offset 0)))
342 (when (> (+ offset total-size)
343 (array-total-size displaced-to))
344 (error (intl:gettext "~S doesn't have enough elements.") displaced-to))
345 (setf (%array-displacement array) offset)
346 (setf (%array-displaced-p array) t)))
347 (t
348 (setf (%array-displaced-p array) nil)))
349 (let ((axis 0))
350 (dolist (dim dimensions)
351 (setf (%array-dimension array axis) dim)
352 (incf axis)))
353 array))))
354
355 (defvar *debug-static-array-p* nil
356 "If non-NIL, print some debugging information when GC'ing static arrays")
357
358 (defun static-array-p (array)
359 (with-array-data ((v array) (start) (end))
360 (declare (ignore start end))
361 (and (typep v '(kernel:simple-unboxed-array (*)))
362 (let ((header (sys:sap-ref-32 (sys:vector-sap v)
363 (- (* 2 vm:word-bytes)))))
364 (logbitp vm:type-bits header)))))
365
366 (defun free-static-vector (vector)
367 (sys:without-gcing
368 (let ((addr (logandc1 vm:lowtag-mask (kernel:get-lisp-obj-address vector))))
369 (when *debug-static-array-p*
370 (format t (intl:gettext "~&Freeing foreign vector at #x~X~%") addr))
371 (alien:alien-funcall
372 (alien:extern-alien "free"
373 (function c-call:void
374 sys:system-area-pointer))
375 (sys:int-sap addr)))))
376
377 (defun finalize-static-vectors ()
378 ;; Run down the list of weak-pointers to static vectors. Look at
379 ;; the static vector and see if vector is marked. If so, clear the
380 ;; mark, and do nothing. If the mark is not set, then the vector is
381 ;; free, so free it, and remove this weak-pointer from the list.
382 ;; The mark bit the MSB of the header word. Look at scavenge in
383 ;; gencgc.c.
384 (when *static-vectors*
385 (when *debug-static-array-p*
386 (let ((*print-array* nil))
387 (format t (intl:gettext "Finalizing static vectors ~S~%") *static-vectors*)))
388 (setf *static-vectors*
389 (delete-if
390 #'(lambda (wp)
391 (let ((vector (weak-pointer-value wp)))
392 (when vector
393 (let* ((sap (sys:vector-sap vector))
394 (header (sys:sap-ref-32 sap (* -2 vm:word-bytes))))
395 (when *debug-static-array-p*
396 (format t (intl:gettext "static vector ~A. header = ~X~%")
397 vector header))
398 (cond ((logbitp 31 header)
399 ;; Clear mark
400 (setf (sys:sap-ref-32 sap (* -2 vm:word-bytes))
401 (logand header #x7fffffff))
402 (when *debug-static-array-p*
403 (let ((*print-array* nil))
404 (format t (intl:gettext " static vector ~A in use~%") vector)))
405 nil)
406 (t
407 ;; Mark was clear so free the vector
408 (when *debug-static-array-p*
409 (let ((*print-array* nil))
410 (format t (intl:gettext " Free static vector ~A~%") vector)))
411 (sys:without-interrupts
412 (setf (weak-pointer-value wp) nil)
413 (free-static-vector vector))
414 t))))))
415 *static-vectors*))))
416
417 ;; Clean up any unreferenced static vectors after GC has run.
418 (pushnew 'finalize-static-vectors *after-gc-hooks*)
419
420
421 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array
422 ;;; characteristics. Dimensions is only used to pass to FILL-DATA-VECTOR
423 ;;; for error checking on the structure of initial-contents.
424 ;;;
425 (defun data-vector-from-inits (dimensions total-size element-type
426 initial-contents initial-contents-p
427 initial-element initial-element-p
428 &optional static-array-p)
429 (when (and initial-contents-p initial-element-p)
430 (error (intl:gettext "Cannot supply both :initial-contents and :initial-element to
431 either make-array or adjust-array.")))
432 (let ((data (if static-array-p
433 (make-static-vector total-size element-type)
434 (if initial-element-p
435 (make-array total-size
436 :element-type element-type
437 :initial-element initial-element)
438 (make-array total-size
439 :element-type element-type)))))
440 (cond (initial-element-p
441 (unless (and (simple-vector-p data) static-array-p)
442 (unless (typep initial-element element-type)
443 (error (intl:gettext "~S cannot be used to initialize an array of type ~S.")
444 initial-element element-type))
445 (fill (the vector data) initial-element)))
446 (initial-contents-p
447 (fill-data-vector data dimensions initial-contents)))
448 data))
449
450
451 (defun fill-data-vector (vector dimensions initial-contents)
452 (let ((index 0))
453 (labels ((frob (axis dims contents)
454 (cond ((null dims)
455 (setf (aref vector index) contents)
456 (incf index))
457 (t
458 (unless (typep contents 'sequence)
459 (error (intl:ngettext "Malformed :initial-contents. ~S is not a ~
460 sequence, but ~D more layer needed."
461 "Malformed :initial-contents. ~S is not a ~
462 sequence, but ~D more layers needed."
463 (- (length dimensions) axis))
464 contents))
465 (unless (= (length contents) (car dims))
466 (error (intl:gettext "Malformed :initial-contents. Dimension of ~
467 axis ~D is ~D, but ~S is ~D long.")
468 axis (car dims) contents (length contents)))
469 (if (listp contents)
470 (dolist (content contents)
471 (frob (1+ axis) (cdr dims) content))
472 (dotimes (i (length contents))
473 (frob (1+ axis) (cdr dims) (aref contents i))))))))
474 (frob 0 dimensions initial-contents))))
475
476
477 (defun vector (&rest objects)
478 "Constructs a simple-vector from the given objects."
479 (coerce (the list objects) 'simple-vector))
480
481
482
483 ;;;; Accessor/Setter functions.
484
485 (defun data-vector-ref (array index)
486 (with-array-data ((vector array) (index index) (end))
487 (declare (ignore end) (optimize (safety 3)))
488 (macrolet ((dispatch (&rest stuff)
489 `(etypecase vector
490 ,@(mapcar #'(lambda (type)
491 (let ((atype `(simple-array ,type (*))))
492 `(,atype
493 (data-vector-ref (the ,atype vector)
494 index))))
495 stuff))))
496 (dispatch
497 t
498 bit
499 character
500 (unsigned-byte 2)
501 (unsigned-byte 4)
502 (unsigned-byte 8)
503 (unsigned-byte 16)
504 (unsigned-byte 32)
505 (signed-byte 8)
506 (signed-byte 16)
507 (signed-byte 30)
508 (signed-byte 32)
509 single-float
510 double-float
511 #+long-float long-float
512 #+double-double double-double-float
513 (complex single-float)
514 (complex double-float)
515 #+long-float (complex long-float)
516 #+double-double (complex double-double-float)))))
517
518 (defun data-vector-set (array index new-value)
519 (with-array-data ((vector array) (index index) (end))
520 (declare (ignore end) (optimize (safety 3)))
521 (macrolet ((dispatch (&rest stuff)
522 `(etypecase vector
523 ,@(mapcar #'(lambda (type)
524 (let ((atype `(simple-array ,type (*))))
525 `(,atype
526 (data-vector-set (the ,atype vector)
527 index
528 (the ,type new-value))
529 new-value)))
530 stuff))))
531 (dispatch
532 t
533 bit
534 character
535 (unsigned-byte 2)
536 (unsigned-byte 4)
537 (unsigned-byte 8)
538 (unsigned-byte 16)
539 (unsigned-byte 32)
540 (signed-byte 8)
541 (signed-byte 16)
542 (signed-byte 30)
543 (signed-byte 32)
544 single-float
545 double-float
546 #+long-float long-float
547 #+double-double double-double-float
548 (complex single-float)
549 (complex double-float)
550 #+long-float (complex long-float)
551 #+double-double (complex double-double-float)))))
552
553
554
555 (defun %array-row-major-index (array subscripts
556 &optional (invalid-index-error-p t))
557 (declare (array array)
558 (list subscripts))
559 (let ((rank (array-rank array)))
560 (unless (= rank (length subscripts))
561 (simple-program-error (intl:gettext "Wrong number of subscripts, ~D, for array of rank ~D")
562 (length subscripts) rank))
563 (if (array-header-p array)
564 (do ((subs (nreverse subscripts) (cdr subs))
565 (axis (1- (array-rank array)) (1- axis))
566 (chunk-size 1)
567 (result 0))
568 ((null subs) result)
569 (declare (list subs) (fixnum axis chunk-size result))
570 (let ((index (car subs))
571 (dim (%array-dimension array axis)))
572 (declare (fixnum index dim))
573 (unless (< -1 index dim)
574 (if invalid-index-error-p
575 (error (intl:gettext "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S")
576 index axis array)
577 (return-from %array-row-major-index nil)))
578 (incf result (* chunk-size index))
579 (setf chunk-size (* chunk-size dim))))
580 (let ((index (first subscripts)))
581 (unless (< -1 index (length (the (simple-array * (*)) array)))
582 (if invalid-index-error-p
583 (error (intl:gettext "Invalid index ~D in ~S") index array)
584 (return-from %array-row-major-index nil)))
585 index))))
586
587 (defun array-in-bounds-p (array &rest subscripts)
588 "Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
589 (if (%array-row-major-index array subscripts nil)
590 t))
591
592 (defun array-row-major-index (array &rest subscripts)
593 (%array-row-major-index array subscripts))
594
595 (defun aref (array &rest subscripts)
596 "Returns the element of the Array specified by the Subscripts."
597 (row-major-aref array (%array-row-major-index array subscripts)))
598
599 (defun %aset (array &rest stuff)
600 (let ((subscripts (butlast stuff))
601 (new-value (car (last stuff))))
602 (setf (row-major-aref array (%array-row-major-index array subscripts))
603 new-value)))
604
605 (declaim (inline (setf aref)))
606 (defun (setf aref) (new-value array &rest subscripts)
607 (declare (type array array))
608 (setf (row-major-aref array (%array-row-major-index array subscripts))
609 new-value))
610
611 (defun row-major-aref (array index)
612 "Returns the element of array corressponding to the row-major index. This is
613 SETF'able."
614 (declare (optimize (safety 1)))
615 (row-major-aref array index))
616
617
618 (defun %set-row-major-aref (array index new-value)
619 (declare (optimize (safety 1)))
620 (setf (row-major-aref array index) new-value))
621
622 (defun svref (simple-vector index)
623 "Returns the Index'th element of the given Simple-Vector."
624 (declare (optimize (safety 1)))
625 (aref simple-vector index))
626
627 (defun %svset (simple-vector index new)
628 (declare (optimize (safety 1)))
629 (setf (aref simple-vector index) new))
630
631
632 (defun bit (bit-array &rest subscripts)
633 "Returns the bit from the Bit-Array at the specified Subscripts."
634 (declare (type (array bit) bit-array) (optimize (safety 1)))
635 (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
636
637
638 (defun %bitset (bit-array &rest stuff)
639 (declare (type (array bit) bit-array) (optimize (safety 1)))
640 (let ((subscripts (butlast stuff))
641 (new-value (car (last stuff))))
642 (setf (row-major-aref bit-array
643 (%array-row-major-index bit-array subscripts))
644 new-value)))
645
646 (declaim (inline (setf bit)))
647 (defun (setf bit) (new-value bit-array &rest subscripts)
648 (declare (type (array bit) bit-array) (optimize (safety 1)))
649 (setf (row-major-aref bit-array
650 (%array-row-major-index bit-array subscripts))
651 new-value))
652
653 (defun sbit (simple-bit-array &rest subscripts)
654 "Returns the bit from the Simple-Bit-Array at the specified Subscripts."
655 (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
656 (row-major-aref simple-bit-array
657 (%array-row-major-index simple-bit-array subscripts)))
658
659 (defun %sbitset (simple-bit-array &rest stuff)
660 (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
661 (let ((subscripts (butlast stuff))
662 (new-value (car (last stuff))))
663 (setf (row-major-aref simple-bit-array
664 (%array-row-major-index simple-bit-array subscripts))
665 new-value)))
666
667 (declaim (inline (setf sbit)))
668 (defun (setf sbit) (new-value bit-array &rest subscripts)
669 (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
670 (setf (row-major-aref bit-array
671 (%array-row-major-index bit-array subscripts))
672 new-value))
673
674
675 ;;;; Random array properties.
676
677 (defun array-element-type (array)
678 "Returns the type of the elements of the array"
679 (let ((type (get-type array)))
680 (macrolet ((pick-element-type (&rest stuff)
681 `(cond ,@(mapcar #'(lambda (stuff)
682 (cons
683 (let ((item (car stuff)))
684 (cond ((eq item t)
685 t)
686 ((listp item)
687 (cons 'or
688 (mapcar #'(lambda (x)
689 `(= type ,x))
690 item)))
691 (t
692 `(= type ,item))))
693 (cdr stuff)))
694 stuff))))
695 (pick-element-type
696 ((vm:simple-string-type vm:complex-string-type) 'base-char)
697 ((vm:simple-bit-vector-type vm:complex-bit-vector-type) 'bit)
698 (vm:simple-vector-type t)
699 (vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2))
700 (vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4))
701 (vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8))
702 (vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16))
703 (vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32))
704 (vm:simple-array-signed-byte-8-type '(signed-byte 8))
705 (vm:simple-array-signed-byte-16-type '(signed-byte 16))
706 (vm:simple-array-signed-byte-30-type '(signed-byte 30))
707 (vm:simple-array-signed-byte-32-type '(signed-byte 32))
708 (vm:simple-array-single-float-type 'single-float)
709 (vm:simple-array-double-float-type 'double-float)
710 #+long-float
711 (vm:simple-array-long-float-type 'long-float)
712 #+double-double
713 (vm::simple-array-double-double-float-type 'double-double-float)
714 (vm:simple-array-complex-single-float-type '(complex single-float))
715 (vm:simple-array-complex-double-float-type '(complex double-float))
716 #+long-float
717 (vm:simple-array-complex-long-float-type '(complex long-float))
718 #+double-double
719 (vm::simple-array-complex-double-double-float-type '(complex double-double-float))
720 ((vm:simple-array-type vm:complex-vector-type vm:complex-array-type)
721 (with-array-data ((array array) (start) (end))
722 (declare (ignore start end))
723 (array-element-type array)))
724 (t
725 (error 'type-error :datum array :expected-type 'array))))))
726
727
728 (defun array-rank (array)
729 "Returns the number of dimensions of the Array."
730 (if (array-header-p array)
731 (%array-rank array)
732 1))
733
734 (defun array-dimension (array axis-number)
735 "Returns length of dimension Axis-Number of the Array."
736 (declare (array array) (type index axis-number))
737 (cond ((not (array-header-p array))
738 (unless (= axis-number 0)
739 (simple-program-error (intl:gettext "Vector axis is not zero: ~S") axis-number))
740 (length (the (simple-array * (*)) array)))
741 ((>= axis-number (%array-rank array))
742 (simple-program-error (intl:ngettext "~D is too big; ~S only has ~D dimension"
743 "~D is too big; ~S only has ~D dimensions"
744 (%array-rank array))
745 axis-number array))
746 (t
747 (%array-dimension array axis-number))))
748
749 (defun array-dimensions (array)
750 "Returns a list whose elements are the dimensions of the array"
751 (declare (array array))
752 (if (array-header-p array)
753 (do ((results nil (cons (array-dimension array index) results))
754 (index (1- (array-rank array)) (1- index)))
755 ((minusp index) results))
756 (list (array-dimension array 0))))
757
758 (defun array-total-size (array)
759 "Returns the total number of elements in the Array."
760 (declare (array array))
761 (if (array-header-p array)
762 (%array-available-elements array)
763 (length (the vector array))))
764
765 (defun array-displacement (array)
766 "Returns values of :displaced-to and :displaced-index-offset options to
767 make-array, or the defaults nil and 0 if not a displaced array."
768 (declare (array array))
769 (if (and (array-header-p array) (%array-displaced-p array))
770 (values (%array-data-vector array)
771 (truly-the fixnum (%array-displacement array)))
772 (values nil 0)))
773
774 (defun adjustable-array-p (array)
775 "Returns T if (adjust-array array...) would return an array identical
776 to the argument, this happens for complex arrays."
777 (declare (array array))
778 (not (typep array 'simple-array)))
779
780
781 ;;;; Fill pointer frobbing stuff.
782
783 (defun array-has-fill-pointer-p (array)
784 "Returns T if the given Array has a fill pointer, or Nil otherwise."
785 (declare (array array))
786 (and (array-header-p array) (%array-fill-pointer-p array)))
787
788 (defun fill-pointer (vector)
789 "Returns the Fill-Pointer of the given Vector."
790 (declare (vector vector))
791 (if (and (array-header-p vector) (%array-fill-pointer-p vector))
792 (%array-fill-pointer vector)
793 (error 'simple-type-error
794 :datum vector
795 :expected-type '(and vector (satisfies array-has-fill-pointer-p))
796 :format-control
797 (intl:gettext "~S is not an array with a fill-pointer.")
798 :format-arguments (list vector))))
799
800 (defun %set-fill-pointer (vector new)
801 (declare (vector vector) (fixnum new))
802 (if (and (array-header-p vector) (%array-fill-pointer-p vector))
803 (if (> new (%array-available-elements vector))
804 (simple-program-error
805 (intl:gettext "New fill pointer, ~S, is larger than the length of the vector.")
806 new)
807 (setf (%array-fill-pointer vector) new))
808 (error 'simple-type-error
809 :datum vector
810 :expected-type '(and vector (satisfies array-has-fill-pointer-p))
811 :format-control (intl:gettext "~S is not an array with a fill-pointer.")
812 :format-arguments (list vector))))
813
814 (defun vector-push (new-el array)
815 "Attempts to set the element of Array designated by the fill pointer
816 to New-El and increment fill pointer by one. If the fill pointer is
817 too large, Nil is returned, otherwise the index of the pushed element is
818 returned."
819 (declare (vector array))
820 (let ((fill-pointer (fill-pointer array)))
821 (declare (fixnum fill-pointer))
822 (cond ((= fill-pointer (%array-available-elements array))
823 nil)
824 (t
825 (setf (aref array fill-pointer) new-el)
826 (setf (%array-fill-pointer array) (1+ fill-pointer))
827 fill-pointer))))
828
829 (defun vector-push-extend (new-el array &optional
830 (extension (if (zerop (length array))
831 1
832 (length array))))
833 "Like Vector-Push except that if the fill pointer gets too large, the
834 Array is extended rather than Nil being returned."
835 (declare (vector array) (fixnum extension))
836 (let ((fill-pointer (fill-pointer array)))
837 (declare (fixnum fill-pointer))
838 (when (= fill-pointer (%array-available-elements array))
839 (setf array (adjust-array array (+ fill-pointer extension))))
840 (setf (aref array fill-pointer) new-el)
841 (setf (%array-fill-pointer array) (1+ fill-pointer))
842 fill-pointer))
843
844 (defun vector-pop (array)
845 "Attempts to decrease the fill-pointer by 1 and return the element
846 pointer to by the new fill pointer. If the original value of the fill
847 pointer is 0, an error occurs."
848 (declare (vector array))
849 (let ((fill-pointer (fill-pointer array)))
850 (declare (fixnum fill-pointer))
851 (if (zerop fill-pointer)
852 (simple-program-error (intl:gettext "Nothing left to pop."))
853 (aref array
854 (setf (%array-fill-pointer array)
855 (1- fill-pointer))))))
856
857
858 ;;;; Adjust-array
859
860 (defun adjust-array (array dimensions &key
861 (element-type (array-element-type array))
862 (initial-element nil initial-element-p)
863 (initial-contents nil initial-contents-p)
864 fill-pointer
865 displaced-to displaced-index-offset)
866 "Adjusts the Array's dimensions to the given Dimensions and stuff."
867 (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
868 (cond ((/= (the fixnum (length (the list dimensions)))
869 (the fixnum (array-rank array)))
870 (simple-program-error (intl:gettext "Number of dimensions not equal to rank of array.")))
871 ((not (subtypep element-type (array-element-type array)))
872 (simple-program-error (intl:gettext "New element type, ~S, is incompatible with old.")
873 element-type))
874 ((static-array-p array)
875 (simple-program-error (intl:gettext "Static arrays are not adjustable."))))
876 (let ((array-rank (length (the list dimensions))))
877 (declare (fixnum array-rank))
878 (when (and fill-pointer (> array-rank 1))
879 (simple-program-error (intl:gettext "Multidimensional arrays can't have fill pointers.")))
880 (cond (initial-contents-p
881 ;; Array former contents replaced by initial-contents.
882 (if (or initial-element-p displaced-to)
883 (simple-program-error (intl:gettext "Initial contents may not be specified with ~
884 the :initial-element or :displaced-to option.")))
885 (let* ((array-size (apply #'* dimensions))
886 (array-data (data-vector-from-inits
887 dimensions array-size element-type
888 initial-contents initial-contents-p
889 initial-element initial-element-p)))
890 (if (adjustable-array-p array)
891 (set-array-header array array-data array-size
892 (get-new-fill-pointer array array-size
893 fill-pointer)
894 0 dimensions nil)
895 (if (array-header-p array)
896 ;; Simple multidimensional or single dimensional array.
897 (make-array dimensions
898 :element-type element-type
899 :initial-contents initial-contents)
900 array-data))))
901 (displaced-to
902 ;; No initial-contents supplied is already established.
903 (when initial-element
904 (simple-program-error (intl:gettext "The :initial-element option may not be specified ~
905 with :displaced-to.")))
906 (unless (subtypep element-type (array-element-type displaced-to))
907 (simple-program-error (intl:gettext "One can't displace an array of type ~S into another of ~
908 type ~S.")
909 element-type (array-element-type displaced-to)))
910 (let ((displacement (or displaced-index-offset 0))
911 (array-size (apply #'* dimensions)))
912 (declare (fixnum displacement array-size))
913 (if (< (the fixnum (array-total-size displaced-to))
914 (the fixnum (+ displacement array-size)))
915 (simple-program-error (intl:gettext "The :displaced-to array is too small.")))
916 (if (adjustable-array-p array)
917 ;; None of the original contents appear in adjusted array.
918 (set-array-header array displaced-to array-size
919 (get-new-fill-pointer array array-size
920 fill-pointer)
921 displacement dimensions t)
922 ;; Simple multidimensional or single dimensional array.
923 (make-array dimensions
924 :element-type element-type
925 :displaced-to displaced-to
926 :displaced-index-offset
927 displaced-index-offset))))
928 ((= array-rank 1)
929 (let ((old-length (array-total-size array))
930 (new-length (car dimensions))
931 new-data)
932 (declare (fixnum old-length new-length))
933 (with-array-data ((old-data array) (old-start)
934 (old-end old-length))
935 (cond
936 ((and (adjustable-array-p array)
937 (not (%array-displaced-p array))
938 (<= new-length old-length))
939 ;; Shrink underlying vector in-place. We don't do this
940 ;; for non-adjustable arrays, since that might confuse
941 ;; user expectations about adjust-array consing a fresh
942 ;; array in that case.
943 (setf new-data (shrink-vector old-data new-length)))
944 (t
945 (setf new-data
946 (data-vector-from-inits
947 dimensions new-length element-type
948 initial-contents initial-contents-p
949 initial-element initial-element-p))
950 (replace new-data old-data
951 :start2 old-start :end2 old-end)))
952 (if (adjustable-array-p array)
953 (set-array-header array new-data new-length
954 (get-new-fill-pointer array new-length
955 fill-pointer)
956 0 dimensions nil)
957 new-data))))
958 (t
959 (let ((old-length (%array-available-elements array))
960 (new-length (apply #'* dimensions)))
961 (declare (fixnum old-length new-length))
962 (cond ((null dimensions)
963 array)
964 (t
965 (with-array-data ((old-data array) (old-start)
966 (old-end old-length))
967 (declare (ignore old-end))
968 (let ((new-data (if (or (%array-displaced-p array)
969 (> new-length old-length))
970 (data-vector-from-inits
971 dimensions new-length
972 element-type () nil
973 initial-element initial-element-p)
974 old-data)))
975 (if (or (zerop old-length) (zerop new-length))
976 (when initial-element-p (fill new-data initial-element))
977 (zap-array-data old-data (array-dimensions array)
978 old-start
979 new-data dimensions new-length
980 element-type initial-element
981 initial-element-p))
982 (if (adjustable-array-p array)
983 (set-array-header array new-data new-length
984 new-length 0 dimensions nil)
985 (let ((new-array
986 (make-array-header vm:simple-array-type array-rank)))
987 (set-array-header new-array new-data new-length
988 new-length 0 dimensions nil)))))))))))))
989
990 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
991 (cond ((not fill-pointer)
992 (when (array-has-fill-pointer-p old-array)
993 (when (> (%array-fill-pointer old-array) new-array-size)
994 (simple-program-error
995 (intl:gettext "Cannot adjust-array an array (~S) to a size (~S) that is ~
996 smaller than it's fill pointer (~S).")
997 old-array new-array-size (fill-pointer old-array)))
998 (%array-fill-pointer old-array)))
999 ((not (array-has-fill-pointer-p old-array))
1000 (simple-program-error
1001 (intl:gettext "Cannot supply a non-NIL value (~S) for :fill-pointer ~
1002 in adjust-array unless the array (~S) was originally ~
1003 created with a fill pointer.")
1004 fill-pointer
1005 old-array))
1006 ((numberp fill-pointer)
1007 (when (> fill-pointer new-array-size)
1008 (simple-program-error
1009 (intl:gettext "Cannot supply a value for :fill-pointer (~S) that is larger ~
1010 than the new length of the vector (~S).")
1011 fill-pointer new-array-size))
1012 fill-pointer)
1013 ((eq fill-pointer t)
1014 new-array-size)
1015 (t
1016 (simple-program-error (intl:gettext "Bogus value for :fill-pointer in adjust-array: ~S")
1017 fill-pointer))))
1018
1019 (defun shrink-vector (vector new-size)
1020 "Destructively alters the Vector, changing its length to New-Size, which
1021 must be less than or equal to its current size."
1022 (declare (vector vector))
1023 (unless (array-header-p vector)
1024 (macrolet ((frob (name &rest things)
1025 `(etypecase ,name
1026 ,@(mapcar #'(lambda (thing)
1027 `(,(car thing)
1028 (fill (truly-the ,(car thing) ,name)
1029 ,(cadr thing)
1030 :start new-size)))
1031 things))))
1032 (frob vector
1033 (simple-vector 0)
1034 (simple-base-string (code-char 0))
1035 (simple-bit-vector 0)
1036 ((simple-array (unsigned-byte 2) (*)) 0)
1037 ((simple-array (unsigned-byte 4) (*)) 0)
1038 ((simple-array (unsigned-byte 8) (*)) 0)
1039 ((simple-array (unsigned-byte 16) (*)) 0)
1040 ((simple-array (unsigned-byte 32) (*)) 0)
1041 ((simple-array (signed-byte 8) (*)) 0)
1042 ((simple-array (signed-byte 16) (*)) 0)
1043 ((simple-array (signed-byte 30) (*)) 0)
1044 ((simple-array (signed-byte 32) (*)) 0)
1045 ((simple-array single-float (*)) (coerce 0 'single-float))
1046 ((simple-array double-float (*)) (coerce 0 'double-float))
1047 #+long-float
1048 ((simple-array long-float (*)) (coerce 0 'long-float))
1049 #+double-double
1050 ((simple-array double-double-float (*))
1051 (coerce 0 'double-double-float))
1052 ((simple-array (complex single-float) (*))
1053 (coerce 0 '(complex single-float)))
1054 ((simple-array (complex double-float) (*))
1055 (coerce 0 '(complex double-float)))
1056 #+long-float
1057 ((simple-array (complex long-float) (*))
1058 (coerce 0 '(complex long-float)))
1059 #+double-double
1060 ((simple-array (complex double-double-float) (*))
1061 (coerce 0 '(complex double-double-float))))))
1062 ;; Only arrays have fill-pointers, but vectors have their length parameter
1063 ;; in the same place.
1064 (setf (%array-fill-pointer vector) new-size)
1065 vector)
1066
1067 (defun set-array-header (array data length fill-pointer displacement dimensions
1068 &optional displacedp)
1069 "Fills in array header with provided information. Returns array."
1070 (setf (%array-data-vector array) data)
1071 (setf (%array-available-elements array) length)
1072 (cond (fill-pointer
1073 (setf (%array-fill-pointer array) fill-pointer)
1074 (setf (%array-fill-pointer-p array) t))
1075 (t
1076 (setf (%array-fill-pointer array) length)
1077 (setf (%array-fill-pointer-p array) nil)))
1078 (setf (%array-displacement array) displacement)
1079 (if (listp dimensions)
1080 (dotimes (axis (array-rank array))
1081 (declare (type index axis))
1082 (setf (%array-dimension array axis) (pop dimensions)))
1083 (setf (%array-dimension array 0) dimensions))
1084 (setf (%array-displaced-p array) displacedp)
1085 array)
1086
1087
1088
1089 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY.
1090
1091 ;;; Make a temporary to be used when old-data and new-data are EQ.
1092 ;;;
1093 (defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
1094
1095 (defun zap-array-data-temp (length element-type initial-element
1096 initial-element-p)
1097 (declare (fixnum length))
1098 (when (> length (the fixnum (length *zap-array-data-temp*)))
1099 (setf *zap-array-data-temp*
1100 (make-array length :initial-element t)))
1101 (when initial-element-p
1102 (unless (typep initial-element element-type)
1103 (simple-program-error (intl:gettext "~S cannot be used to initialize an array of type ~S.")
1104 initial-element element-type))
1105 (fill (the simple-vector *zap-array-data-temp*) initial-element
1106 :end length))
1107 *zap-array-data-temp*)
1108
1109
1110 ;;; ZAP-ARRAY-DATA -- Internal.
1111 ;;;
1112 ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data from the
1113 ;;; Old-Data in an arrangement specified by the Old-Dims to the New-Data in an
1114 ;;; arrangement specified by the New-Dims. Offset is a displaced offset to be
1115 ;;; added to computed indexes of Old-Data. New-Length, Element-Type,
1116 ;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data
1117 ;;; are EQ; in this case, a temporary must be used and filled appropriately.
1118 ;;; When Old-Data and New-Data are not EQ, New-Data has already been filled
1119 ;;; with any specified initial-element.
1120 ;;;
1121 (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
1122 element-type initial-element initial-element-p)
1123 (declare (list old-dims new-dims))
1124 (setq old-dims (nreverse old-dims))
1125 (setq new-dims (reverse new-dims))
1126 (if (eq old-data new-data)
1127 (let ((temp (zap-array-data-temp new-length element-type
1128 initial-element initial-element-p)))
1129 (zap-array-data-aux old-data old-dims offset temp new-dims)
1130 (dotimes (i new-length) (setf (aref new-data i) (aref temp i))))
1131 (zap-array-data-aux old-data old-dims offset new-data new-dims)))
1132
1133 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
1134 (declare (fixnum offset))
1135 (let ((limits (mapcar #'(lambda (x y)
1136 (declare (fixnum x y))
1137 (1- (the fixnum (min x y))))
1138 old-dims new-dims)))
1139 (macrolet ((bump-index-list (index limits)
1140 `(do ((subscripts ,index (cdr subscripts))
1141 (limits ,limits (cdr limits)))
1142 ((null subscripts) nil)
1143 (cond ((< (the fixnum (car subscripts))
1144 (the fixnum (car limits)))
1145 (rplaca subscripts
1146 (1+ (the fixnum (car subscripts))))
1147 (return ,index))
1148 (t (rplaca subscripts 0))))))
1149 (do ((index (make-list (length old-dims) :initial-element 0)
1150 (bump-index-list index limits)))
1151 ((null index))
1152 (setf (aref new-data (row-major-index-from-dims index new-dims))
1153 (aref old-data
1154 (+ (the fixnum (row-major-index-from-dims index old-dims))
1155 offset)))))))
1156
1157 ;;; ROW-MAJOR-INDEX-FROM-DIMS -- Internal.
1158 ;;;
1159 ;;; This figures out the row-major-order index of an array reference from a
1160 ;;; list of subscripts and a list of dimensions. This is for internal calls
1161 ;;; only, and the subscripts and dim-list variables are assumed to be reversed
1162 ;;; from what the user supplied.
1163 ;;;
1164 (defun row-major-index-from-dims (rev-subscripts rev-dim-list)
1165 (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
1166 (rev-dim-list rev-dim-list (cdr rev-dim-list))
1167 (chunk-size 1)
1168 (result 0))
1169 ((null rev-dim-list) result)
1170 (declare (fixnum chunk-size result))
1171 (setq result (+ result
1172 (the fixnum (* (the fixnum (car rev-subscripts))
1173 chunk-size))))
1174 (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
1175
1176
1177
1178 ;;;; Some bit stuff.
1179
1180 (defun bit-array-same-dimensions-p (array1 array2)
1181 (declare (type (array bit) array1 array2))
1182 (and (= (array-rank array1)
1183 (array-rank array2))
1184 (dotimes (index (array-rank array1) t)
1185 (when (/= (array-dimension array1 index)
1186 (array-dimension array2 index))
1187 (return nil)))))
1188
1189 (defun pick-result-array (result-bit-array bit-array-1)
1190 (case result-bit-array
1191 ((t) bit-array-1)
1192 ((nil) (make-array (array-dimensions bit-array-1)
1193 :element-type 'bit
1194 :initial-element 0))
1195 (t
1196 (unless (bit-array-same-dimensions-p bit-array-1
1197 result-bit-array)
1198 (simple-program-error (intl:gettext "~S and ~S do not have the same dimensions.")
1199 bit-array-1 result-bit-array))
1200 result-bit-array)))
1201
1202 (defmacro def-bit-array-op (name function)
1203 (let ((docstring (format nil
1204 "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
1205 BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
1206 If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
1207 RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
1208 All the arrays must have the same rank and dimensions."
1209 (symbol-name function))))
1210 (intl::note-translatable intl::*default-domain* docstring)
1211 `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
1212 ,docstring
1213 (declare (type (array bit) bit-array-1 bit-array-2)
1214 (type (or (array bit) (member t nil)) result-bit-array))
1215 (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
1216 (simple-program-error (intl:gettext "~S and ~S do not have the same dimensions.")
1217 bit-array-1 bit-array-2))
1218 (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
1219 (if (and (simple-bit-vector-p bit-array-1)
1220 (simple-bit-vector-p bit-array-2)
1221 (simple-bit-vector-p result-bit-array))
1222 (locally (declare (optimize (speed 3) (safety 0)))
1223 (,name bit-array-1 bit-array-2 result-bit-array))
1224 (with-array-data ((data1 bit-array-1) (start1) (end1))
1225 (declare (ignore end1))
1226 (with-array-data ((data2 bit-array-2) (start2) (end2))
1227 (declare (ignore end2))
1228 (with-array-data ((data3 result-bit-array) (start3) (end3))
1229 (do ((index-1 start1 (1+ index-1))
1230 (index-2 start2 (1+ index-2))
1231 (index-3 start3 (1+ index-3)))
1232 ((>= index-3 end3) result-bit-array)
1233 (declare (type index index-1 index-2 index-3))
1234 (setf (sbit data3 index-3)
1235 (logand (,function (sbit data1 index-1)
1236 (sbit data2 index-2))
1237 1)))))))))))
1238
1239 (def-bit-array-op bit-and logand)
1240 (def-bit-array-op bit-ior logior)
1241 (def-bit-array-op bit-xor logxor)
1242 (def-bit-array-op bit-eqv logeqv)
1243 (def-bit-array-op bit-nand lognand)
1244 (def-bit-array-op bit-nor lognor)
1245 (def-bit-array-op bit-andc1 logandc1)
1246 (def-bit-array-op bit-andc2 logandc2)
1247 (def-bit-array-op bit-orc1 logorc1)
1248 (def-bit-array-op bit-orc2 logorc2)
1249
1250 (defun bit-not (bit-array &optional result-bit-array)
1251 "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
1252 putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
1253 BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
1254 created. Both arrays must have the same rank and dimensions."
1255 (declare (type (array bit) bit-array)
1256 (type (or (array bit) (member t nil)) result-bit-array))
1257 (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
1258 (if (and (simple-bit-vector-p bit-array)
1259 (simple-bit-vector-p result-bit-array))
1260 (locally (declare (optimize (speed 3) (safety 0)))
1261 (bit-not bit-array result-bit-array))
1262 (with-array-data ((src bit-array) (src-start) (src-end))
1263 (declare (ignore src-end))
1264 (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
1265 (do ((src-index src-start (1+ src-index))
1266 (dst-index dst-start (1+ dst-index)))
1267 ((>= dst-index dst-end) result-bit-array)
1268 (declare (type index src-index dst-index))
1269 (setf (sbit dst dst-index)
1270 (logxor (sbit src src-index) 1))))))))

  ViewVC Help
Powered by ViewVC 1.1.5