1 /*
2 * Array functions
3 * Bruno Haible 1990-2005
4 * Sam Steingold 1998-2012
5 * German comments translated into English: Stefan Kain 2002-09-23
6 */
7
8 #include "lispbibl.c"
9 #include "arilev0.c" /* for bit_op, also defines mulu24 and mulu32_unchecked */
10
11 /* ======================================================================== */
12 /* Global auxiliary functions */
13
14 /* Function: Copies a simple-vector.
15 copy_svector(vector)
16 > vector: simple-vector
17 < result: fresh simple-vector with the same contents
18 can trigger GC */
copy_svector(object vector)19 global maygc object copy_svector (object vector) {
20 var uintL length = Svector_length(vector);
21 pushSTACK(vector);
22 var object newvector = allocate_vector(length); /* vector of same length */
23 vector = popSTACK();
24 /* copy the contents of vector into newvector: */
25 if (length != 0) {
26 var gcv_object_t* ptr1 = &TheSvector(vector)->data[0];
27 var gcv_object_t* ptr2 = &TheSvector(newvector)->data[0];
28 dotimespL(length,length, {
29 *ptr2++ = *ptr1++;
30 });
31 }
32 return newvector;
33 }
34
35 /* Function: allocate a simple-bit/byte-vector and copy data there
36 > atype: array type
37 > vec_len: the length of the new array
38 > data: pointer to the memory area to be copied
39 > byte_len: the memory size to be copied, in bytes
40 < returns a fresh simple-bit/byte-vector with the same contents
41 can trigger GC */
data_to_sbvector(uintB atype,uintL vec_len,const void * data,uintL byte_len)42 modexp maygc object data_to_sbvector (uintB atype, uintL vec_len,
43 const void *data, uintL byte_len) {
44 var object newvector = allocate_bit_vector(atype,vec_len);
45 if (byte_len != 0)
46 copy_mem_b(TheSbvector(newvector)->data,data,byte_len);
47 return newvector;
48 }
49
50 /* Function: Copies a simple-bit/byte-vector.
51 copy_sbvector(vector)
52 > vector: simple-bit/byte-vector
53 < result: fresh simple-bit/byte-vector with the same contents
54 can trigger GC */
copy_sbvector(object vector)55 global maygc object copy_sbvector (object vector) {
56 var uintB atype = sbNvector_atype(vector);
57 var uintL length = Sbvector_length(vector);
58 pushSTACK(vector);
59 var object newvector = data_to_sbvector(atype,length,TheSbvector(vector)->data,ceiling(length<<atype,8)); /* vector of the same length */
60 skipSTACK(1);
61 return newvector;
62 }
63
64 LISPFUNNR(copy_simple_vector,1)
65 { /* (SYS::%COPY-SIMPLE-VECTOR vector) returns a copy
66 of the simple-vector VECTOR. */
67 var object obj = popSTACK();
68 if (!simple_vector_p(obj))
69 error_no_svector(S(copy_simple_vector),obj);
70 VALUES1(copy_svector(obj));
71 }
72
73 /* Function: Returns the active length of a vector (same as LENGTH).
74 vector_length(vector)
75 > vector: a vector
76 < result: its length */
vector_length(object vector)77 modexp uintL vector_length (object vector) {
78 if (array_simplep(vector)) {
79 if (simple_string_p(vector)) {
80 sstring_un_realloc(vector);
81 return Sstring_length(vector);
82 } else
83 return Sarray_length(vector);
84 }
85 /* Indirect Array */
86 var Iarray addr = TheIarray(vector);
87 var uintL offset = offsetofa(iarray_,dims);
88 if (iarray_flags(addr) & bit(arrayflags_dispoffset_bit))
89 offset += sizeof(uintL);
90 /* The dimensions start at addr+offset. */
91 if (iarray_flags(addr) & bit(arrayflags_fillp_bit)) /* fill-pointer ? */
92 offset += sizeof(uintL);
93 return *(uintL*)pointerplus(addr,offset);
94 }
95
96 /* Function: Canonicalizes an array element-type and returns its
97 element type code.
98 ** When this function is changed, also update UPGRADED-ARRAY-ELEMENT-TYPE
99 ** and SUBTYPE-SEQUENCE in type.lisp!
100 eltype_code(element_type)
101 > element_type: type specifier
102 < result: element type code Atype_xxx
103 The canonicalized types are the possible results of ARRAY-ELEMENT-TYPE
104 (symbols T, BIT, CHARACTER and lists (UNSIGNED-BYTE n)).
105 The result type is a supertype of element_type.
106 can trigger GC */
eltype_code(object obj)107 global maygc uintB eltype_code (object obj)
108 { /* (cond ((eq obj 'BIT) Atype_Bit)
109 ((eq obj 'CHARACTER) Atype_Char)
110 ((eq obj 'T) Atype_T)
111 ((eq obj 'NIL) Atype_NIL)
112 (t (if (subtypep obj 'NIL)
113 Atype_NIL
114 (multiple-value-bind (low high) (sys::subtype-integer obj)
115 ;; Now (or (null low) (subtypep obj `(INTEGER ,low ,high)))
116 (if (and (integerp low) (not (minusp low)) (integerp high))
117 (let ((l (integer-length high)))
118 ;; Now (subtypep obj `(UNSIGNED-BYTE ,l))
119 (cond ((<= l 1) Atype_Bit)
120 ((<= l 2) Atype_2Bit)
121 ((<= l 4) Atype_4Bit)
122 ((<= l 8) Atype_8Bit)
123 ((<= l 16) Atype_16Bit)
124 ((<= l 32) Atype_32Bit)
125 (t Atype_T)))
126 (if (subtypep type 'CHARACTER)
127 Atype_Char
128 Atype_T)))))) */
129 if (eq(obj,S(bit))) { /* symbol BIT ? */
130 return Atype_Bit;
131 } else if (eq(obj,S(character))) { /* symbol CHARACTER ? */
132 return Atype_Char;
133 } else if (eq(obj,S(t))) { /* symbol T ? */
134 return Atype_T;
135 } else if (nullp(obj)) /* symbol NIL ? */
136 return Atype_NIL;
137 pushSTACK(obj); /* save obj */
138 /* (SUBTYPEP obj 'NIL) */
139 pushSTACK(obj); pushSTACK(S(nil)); funcall(S(subtypep),2);
140 if (!nullp(value1)) {
141 skipSTACK(1);
142 return Atype_NIL;
143 }
144 /* (SYS::SUBTYPE-INTEGER obj) */
145 pushSTACK(STACK_0); funcall(S(subtype_integer),1);
146 obj = popSTACK(); /* restore obj */
147 if ((mv_count>1) && integerp(value1)
148 && positivep(value1) && integerp(value2)) {
149 var uintL l = I_integer_length(value2); /* (INTEGER-LENGTH high) */
150 if (l<=1)
151 return Atype_Bit;
152 if (l<=2)
153 return Atype_2Bit;
154 if (l<=4)
155 return Atype_4Bit;
156 if (l<=8)
157 return Atype_8Bit;
158 if (l<=16)
159 return Atype_16Bit;
160 if (l<=32)
161 return Atype_32Bit;
162 }
163 /* (SUBTYPEP obj 'CHARACTER) */
164 pushSTACK(obj); pushSTACK(S(character)); funcall(S(subtypep),2);
165 if (!nullp(value1))
166 return Atype_Char;
167 return Atype_T;
168 }
169
170 /* Function: Creates a simple-vector with given elements.
171 vectorof(len)
172 > uintC len: desired vector length
173 > STACK_(len-1), ..., STACK_(0): len objects
174 < result: simple-vector containing these objects
175 Pops n objects off STACK.
176 can trigger GC */
vectorof(uintC len)177 modexp maygc object vectorof (uintC len) {
178 var object new_vector = allocate_vector(len);
179 if (len > 0) {
180 var gcv_object_t* topargptr = STACK STACKop len;
181 var gcv_object_t* argptr = topargptr;
182 var gcv_object_t* ptr = &TheSvector(new_vector)->data[0];
183 dotimespC(len,len, {
184 *ptr++ = NEXT(argptr);
185 });
186 set_args_end_pointer(topargptr);
187 }
188 return new_vector;
189 }
190
191 LISPFUN(vector,seclass_no_se,0,0,rest,nokey,0,NIL)
192 { /* (VECTOR {object}), CLTL p. 290 */
193 VALUES1(vectorof(argcount));
194 }
195
196 /* ======================================================================== */
197 /* Index checking, retrieving the storage vector */
198
199 /* An indirect array contains a pointer to another array:
200 TheIarray(array)->data.
201 The "storage vector" of an array is a 1-dimensional array, of the same
202 element type as the original array, without fill-pointer or adjustable bit;
203 for arrays of element type NIL, the "storage vector" is the symbol NIL.
204 It can be obtained by repeatedly taking TheIarray(array)->data, until
205 array satisfies array_simplep || simple_nilarray_p. */
206
207 /* Function: Follows the TheIarray(array)->data chain until the storage-vector
208 is reached, and thereby sums up displaced-offsets. This function is useful
209 for accessing a single array element.
210 iarray_displace(array,&index);
211 > array: indirect array
212 > index: row-major-index
213 < result: storage-vector
214 < index: absolute index into the storage vector
215 It is checked whether the addressed array element lies within the bounds of
216 every intermediate array.
217 It is not checked whether the chain is ultimately circular. */
iarray_displace(object array,uintL * index)218 local object iarray_displace (object array, uintL* index) {
219 while (1) {
220 if (*index >= TheIarray(array)->totalsize)
221 goto error_bad_index;
222 if (!(Iarray_flags(array) & bit(arrayflags_displaced_bit)))
223 goto notdisplaced;
224 /* array is displaced */
225 *index += TheIarray(array)->dims[0]; /* add displaced-offset */
226 array = TheIarray(array)->data; /* next array in the chain */
227 if (array_simplep(array)) /* next array indirect? */
228 goto simple;
229 }
230 notdisplaced:
231 /* array is indirect, but not displaced */
232 array = TheIarray(array)->data; /* next array is the storage-vector */
233 simple:
234 /* have reached the storage-vector, not indirect */
235 if (!simple_nilarray_p(array)) {
236 if (simple_string_p(array)) {
237 sstring_un_realloc(array);
238 if (*index >= Sstring_length(array))
239 goto error_bad_index;
240 } else {
241 if (*index >= Sarray_length(array))
242 goto error_bad_index;
243 }
244 }
245 return array;
246 error_bad_index:
247 error(error_condition,GETTEXT("index too large")); /* more details?? */
248 }
249
250 /* error: a displaced array does not fit into its target array. */
error_displaced_inconsistent(void)251 local _Noreturn void error_displaced_inconsistent (void) {
252 error(error_condition,GETTEXT("An array has been shortened by adjusting it while another array was displaced to it."));
253 }
254
255 /* Function: For an indirect array, returns the storage vector and the offset.
256 Also verifies that all elements of the array are physically present.
257 iarray_displace_check(array,size,&index)
258 > object array: indirect array
259 > uintL size: size
260 < result: storage vector
261 < index: is incremented by the offset into the storage vector */
iarray_displace_check(object array,uintL size,uintL * index)262 global object iarray_displace_check (object array, uintL size, uintL* index) {
263 while (1) {
264 if (*index+size > TheIarray(array)->totalsize)
265 goto error_bad_index;
266 if (!(Iarray_flags(array) & bit(arrayflags_displaced_bit)))
267 goto notdisplaced;
268 /* array is displaced */
269 *index += TheIarray(array)->dims[0]; /* add displaced-offset */
270 array = TheIarray(array)->data; /* next array in the chain */
271 if (array_simplep(array)) /* next array indirect? */
272 goto simple;
273 }
274 notdisplaced:
275 /* array is indirect, but not displaced */
276 array = TheIarray(array)->data; /* next array is the storage-vector */
277 simple:
278 /* have reached the storage-vector, not indirect */
279 if (!simple_nilarray_p(array)) {
280 if (simple_string_p(array)) {
281 sstring_un_realloc(array);
282 if (*index+size > Sstring_length(array))
283 goto error_bad_index;
284 } else {
285 if (*index+size > Sarray_length(array))
286 goto error_bad_index;
287 }
288 }
289 return array;
290 error_bad_index:
291 error_displaced_inconsistent();
292 }
293
294 /* Function: For an array, returns the storage vector and the offset.
295 Also verifies that all elements of the array are physically present.
296 array_displace_check(array,size,&index)
297 > object array: array
298 > uintV size: size
299 < result: storage vector
300 < index: is incremented by the offset into the storage vector */
array_displace_check(object array,uintV size,uintL * index)301 modexp object array_displace_check (object array, uintV size, uintL* index) {
302 if (array_simplep(array)) /* indirect array? */
303 goto simple;
304 while (1) {
305 if (*index+size > TheIarray(array)->totalsize)
306 goto error_bad_index;
307 if (!(Iarray_flags(array) & bit(arrayflags_displaced_bit)))
308 goto notdisplaced;
309 /* array is displaced */
310 *index += TheIarray(array)->dims[0]; /* add displaced-offset */
311 array = TheIarray(array)->data; /* next array in the chain */
312 if (array_simplep(array)) /* next array indirect? */
313 goto simple;
314 }
315 notdisplaced:
316 /* array is indirect, but not displaced */
317 array = TheIarray(array)->data; /* next array is the storage-vector */
318 simple:
319 /* have reached the storage-vector, not indirect */
320 if (!simple_nilarray_p(array)) {
321 if (simple_string_p(array)) {
322 sstring_un_realloc(array);
323 if (*index+size > Sstring_length(array))
324 goto error_bad_index;
325 } else {
326 if (*index+size > Sarray_length(array))
327 goto error_bad_index;
328 }
329 }
330 return array;
331 error_bad_index:
332 error_displaced_inconsistent();
333 }
334
335 /* ======================================================================== */
336 /* Accessing and storing a single element */
337
338 /* Returns the rank of an array.
339 arrayrank(array)
340 > array: an array
341 < object result: rank as a fixnum */
342 #define arrayrank(array) \
343 (mdarrayp(array) \
344 ? fixnum((uintL)Iarray_rank(array)) /* multi-dimensional array */ \
345 : Fixnum_1) /* vector has rank 1 */
346
347 /* error: bad number of subscripts
348 > array: array
349 > argcount: (wrong) number of subscripts */
error_subscript_count(object array,uintC argcount)350 local _Noreturn void error_subscript_count (object array, uintC argcount) {
351 pushSTACK(arrayrank(array));
352 pushSTACK(array);
353 pushSTACK(fixnum(argcount));
354 pushSTACK(TheSubr(subr_self)->name);
355 error(error_condition,GETTEXT("~S: got ~S subscripts, but ~S has rank ~S"));
356 }
357
358 /* error: bad subscript values
359 > argcount: number of subscripts
360 > STACK_(argcount): array
361 > STACK_(argcount-1),...,STACK_(0): subscripts */
error_subscript_type(uintC argcount)362 local _Noreturn void error_subscript_type (uintC argcount) {
363 var object list = listof(argcount); /* list of subscripts */
364 /* STACK_0 is now the array. */
365 pushSTACK(list);
366 pushSTACK(TheSubr(subr_self)->name);
367 error(error_condition,GETTEXT("~S: subscripts ~S for ~S are not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"));
368 }
369
370 /* error: bad subscript values
371 > argcount: number of subscripts
372 > STACK_(argcount): array
373 > STACK_(argcount-1),...,STACK_(0): subscripts */
error_subscript_range(uintC argcount,uintL subscript,uintL bound)374 local _Noreturn void error_subscript_range (uintC argcount, uintL subscript, uintL bound) {
375 var object list = listof(argcount); /* list of subscripts */
376 pushSTACK(list);
377 /* On STACK: array, subscript-list. */
378 pushSTACK(UL_to_I(subscript)); /* slot DATUM of TYPE-ERROR */
379 {
380 var object tmp;
381 pushSTACK(S(integer)); pushSTACK(Fixnum_0); pushSTACK(UL_to_I(bound));
382 tmp = listof(1); pushSTACK(tmp); tmp = listof(3);
383 pushSTACK(tmp); /* slot EXPECTED-TYPE of TYPE-ERROR */
384 }
385 pushSTACK(STACK_(1+2));
386 pushSTACK(STACK_(0+3));
387 pushSTACK(TheSubr(subr_self)->name);
388 error(type_error,GETTEXT("~S: subscripts ~S for ~S are out of range"));
389 }
390
391 /* checks subscripts for an AREF/STORE-access, removes them from STACK
392 and returns the row-major-index (>=0, <arraysize_limit).
393 test_subscripts(array,argptr,argcount)
394 > array : non-simpler array
395 > argptr : pointer to the Subscripts
396 > argcount : number of subscripts
397 < result : row-major-index */
test_subscripts(object array,gcv_object_t * argptr,uintC argcount)398 local uintL test_subscripts (object array, gcv_object_t* argptr, uintC argcount) {
399 var gcv_object_t* args_pointer = argptr; /* save argptr for later */
400 /* check number of subscripts: */
401 if (argcount != Iarray_rank(array)) /* should be = rank */
402 error_subscript_count(array,argcount);
403 /* check subscripts themself: */
404 var uintL row_major_index = 0;
405 var const uintL* dimptr = &TheIarray(array)->dims[0];
406 if (Iarray_flags(array) & bit(arrayflags_dispoffset_bit))
407 dimptr++; /* poss. skip displaced-offset */
408 {
409 var uintC count;
410 dotimesC(count,argcount, {
411 var object subscriptobj = NEXT(argptr); /* Subscript as object */
412 if (!(posfixnump(subscriptobj))) { /* subscript must be fixnum>=0. */
413 Before(args_pointer) = array;
414 error_subscript_type(argcount);
415 }
416 var uintV subscript = posfixnum_to_V(subscriptobj); /* as uintL */
417 var uintL dim = *dimptr++; /* corresponding dimension */
418 if (subscript>=dim) { /* subscript must be smaller than dimension */
419 Before(args_pointer) = array;
420 error_subscript_range(argcount,subscript,dim);
421 }
422 /* form row_major_index := row_major_index*dim+subscript: */
423 row_major_index =
424 mulu32_unchecked(row_major_index,dim)+subscript;
425 /* This does not produce an overflow, because it is
426 < product of all dimensions so far
427 <= product of all dimensions < arraysize_limit <= 2^32
428 (exception: When a later dimension is =0 .
429 But then there will be an error message, anyway.) */
430 });
431 }
432 set_args_end_pointer(args_pointer);
433 return row_major_index;
434 }
435
436 /* error: bad index
437 > array: array (usually a vector)
438 > STACK_0: (erroneous) index */
error_index_type(object array)439 local _Noreturn void error_index_type (object array) {
440 pushSTACK(STACK_0); /* TYPE-ERROR slot DATUM */
441 pushSTACK(O(type_array_index)); /* TYPE-ERROR slot EXPECTED-TYPE */
442 pushSTACK(array);
443 pushSTACK(STACK_(0+3));
444 pushSTACK(TheSubr(subr_self)->name);
445 error(type_error,GETTEXT("~S: index ~S for ~S is not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"));
446 }
447
448 /* error: bad index
449 > array: array (usually a vector)
450 > STACK_0: (erroneous) index */
error_index_range(object array,uintL bound)451 global _Noreturn void error_index_range (object array, uintL bound) {
452 var object tmp;
453 pushSTACK(STACK_0); /* TYPE-ERROR slot DATUM */
454 pushSTACK(array);
455 pushSTACK(S(integer)); pushSTACK(Fixnum_0); pushSTACK(UL_to_I(bound));
456 tmp = listof(1); pushSTACK(tmp); tmp = listof(3);
457 array = STACK_0;
458 STACK_0 = tmp; /* TYPE-ERROR slot EXPECTED-TYPE */
459 pushSTACK(array);
460 pushSTACK(STACK_(0+3));
461 pushSTACK(TheSubr(subr_self)->name);
462 error(type_error,GETTEXT("~S: index ~S for ~S is out of range"));
463 }
464
465 /* checks an index for a AREF/STORE-access into a simple vector.
466 test_index(vector)
467 > vector: not-reallocated simple Vector
468 > STACK_0: index
469 < result: index as uintL */
test_index(object vector)470 local uintL test_index (object vector) {
471 if (!posfixnump(STACK_0)) /* index must be fixnum>=0 . */
472 error_index_type(vector);
473 var uintV index = posfixnum_to_V(STACK_0); /* index as uintL */
474 var uintL length = (simple_string_p(vector) ? Sstring_length(vector) : Sarray_length(vector));
475 if (index >= length) /* index must be smaller then length */
476 error_index_range(vector,length);
477 return index;
478 }
479
480 /* checks subscripts for a AREF/STORE-access, removes them from STACK
481 and returns the row-major-index (>=0, <arraysize_limit) and the data vector.
482 subscripts_to_index(array,argptr,argcount, &index)
483 > array : array
484 > argptr : pointer to the subscripts
485 > argcount : number of subscripts
486 < index_ : index into the data vector
487 < result : the data vector */
subscripts_to_index(object array,gcv_object_t * argptr,uintC argcount,uintL * index_)488 local object subscripts_to_index (object array, gcv_object_t* argptr,
489 uintC argcount, uintL* index_) {
490 if (array_simplep(array)) { /* simple vector, will be treated separately: */
491 /* check number of subscripts: */
492 if (argcount != 1) /* should be = 1 */
493 error_subscript_count(array,argcount);
494 sstring_un_realloc(array);
495 /* check subscript itself: */
496 *index_ = test_index(array); /* index = row-major-index = subscript */
497 skipSTACK(1); return array;
498 } else { /* non-simple array */
499 /* check Subscripts, calculate row-major-index, clean up STACK: */
500 *index_ = test_subscripts(array,argptr,argcount);
501 /* fetch dat vector and absolut index: */
502 return iarray_displace(array,&(*index_));
503 }
504 }
505
506 /* error message: attempt to retrieve a value from (ARRAY NIL) */
error_nilarray_retrieve(void)507 modexp _Noreturn void error_nilarray_retrieve (void) {
508 pushSTACK(TheSubr(subr_self)->name);
509 error(error_condition,GETTEXT("~S: cannot retrieve values from an array of element type NIL"));
510 }
511
512 /* error message: attempt to store a value in (ARRAY NIL) */
error_nilarray_store(void)513 global _Noreturn void error_nilarray_store (void) {
514 pushSTACK(TheSubr(subr_self)->name);
515 error(error_condition,GETTEXT("~S: cannot store values in an array of element type NIL"));
516 }
517
518 /* error message: attempt to access a value from (ARRAY NIL) */
error_nilarray_access(void)519 global _Noreturn void error_nilarray_access (void) {
520 pushSTACK(TheSubr(subr_self)->name);
521 error(error_condition,GETTEXT("~S: cannot access values of an array of element type NIL"));
522 }
523
524 /* Function: Performs an AREF access.
525 storagevector_aref(storagevector,index)
526 > storagevector: a storage vector (simple vector or semi-simple byte vector)
527 > index: (already checked) index into the storage vector
528 < result: (AREF storagevector index)
529 can trigger GC - if the element type is (UNSIGNED-BYTE 32) */
storagevector_aref(object datenvektor,uintL index)530 global /*maygc*/ object storagevector_aref (object datenvektor, uintL index) {
531 GCTRIGGER_IF(Array_type(datenvektor) == Array_type_sb32vector,
532 GCTRIGGER1(datenvektor));
533 switch (Array_type(datenvektor)) {
534 case Array_type_svector: /* Simple-Vector */
535 { return TheSvector(datenvektor)->data[index]; }
536 case Array_type_sbvector: /* Simple-Bit-Vector */
537 { return ( sbvector_btst(datenvektor,index) ? Fixnum_1 : Fixnum_0 ); }
538 case Array_type_sb2vector:
539 { return fixnum((TheSbvector(datenvektor)->data[index/4]>>(2*((~index)%4)))&(bit(2)-1)); }
540 case Array_type_sb4vector:
541 { return fixnum((TheSbvector(datenvektor)->data[index/2]>>(4*((~index)%2)))&(bit(4)-1)); }
542 case Array_type_sb8vector:
543 { return fixnum(TheSbvector(datenvektor)->data[index]); }
544 case Array_type_sb16vector:
545 { return fixnum(((uint16*)&TheSbvector(datenvektor)->data[0])[index]); }
546 case Array_type_sb32vector:
547 { return UL_to_I(((uint32*)&TheSbvector(datenvektor)->data[0])[index]); }
548 case Array_type_sstring: /* Simple-String */
549 { return code_char(schar(datenvektor,index)); }
550 case Array_type_snilvector: /* (VECTOR NIL) */
551 error_nilarray_retrieve();
552 default: NOTREACHED;
553 }
554 }
555
556 /* error: attempting to store an invalid value in an array.
557 error_store(array,value); */
error_store(object array,object value)558 global _Noreturn void error_store (object array, object value) {
559 pushSTACK(value); /* TYPE-ERROR slot DATUM */
560 pushSTACK(NIL); /* TYPE-ERROR slot EXPECTED-TYPE */
561 if (!simple_nilarray_p(array)) {
562 pushSTACK(array);
563 STACK_1 = array_element_type(array); /* TYPE-ERROR slot EXPECTED-TYPE */
564 pushSTACK(STACK_2); /* value */
565 pushSTACK(TheSubr(subr_self)->name);
566 error(type_error,GETTEXT("~S: ~S does not fit into ~S, bad type"));
567 } else {
568 pushSTACK(STACK_1); /* value */
569 pushSTACK(TheSubr(subr_self)->name);
570 error(type_error,GETTEXT("~S: ~S cannot be stored in an array of element type NIL"));
571 }
572 }
573
574 /* performs a STORE-access.
575 storagevector_store(datenvektor,index,element,allowgc)
576 > datenvektor : a data vector (simple vector or semi-simple byte-vector)
577 > index : (checked) index into the data vector
578 > element : (unchecked) object to be written
579 > allowgc : whether GC is allowed, if datenvektor is a string and element is a character
580 > STACK_0 : array (for error-message)
581 < datenvektor: possibly reallocated storage vector
582 can trigger GC, if datenvektor is a string and element is a character */
storagevector_store(object datenvektor,uintL index,object element,bool allowgc)583 local /*maygc*/ object storagevector_store (object datenvektor, uintL index,
584 object element, bool allowgc) {
585 GCTRIGGER_IF(allowgc, GCTRIGGER2(datenvektor,element));
586 switch (Array_type(datenvektor)) {
587 case Array_type_svector: /* Simple-Vector */
588 TheSvector(datenvektor)->data[index] = element;
589 return datenvektor;
590 case Array_type_sbvector: { /* Simple-Bit-Vector */
591 var uintB* addr = &TheSbvector(datenvektor)->data[index/8];
592 var uintL bitnummer = (~index)%8; /* 7 - (index mod 8) */
593 if (eq(element,Fixnum_0)) {
594 *addr &= ~bit(bitnummer);
595 return datenvektor;
596 } else if (eq(element,Fixnum_1)) {
597 *addr |= bit(bitnummer);
598 return datenvektor;
599 }
600 }
601 break;
602 case Array_type_sb2vector: {
603 var uintV value;
604 if (posfixnump(element) && ((value = posfixnum_to_V(element)) < bit(2))) {
605 var uintB* ptr = &TheSbvector(datenvektor)->data[index/4];
606 *ptr ^= (*ptr ^ (value<<(2*((~index)%4)))) & ((bit(2)-1)<<(2*((~index)%4)));
607 return datenvektor;
608 }
609 }
610 break;
611 case Array_type_sb4vector: {
612 var uintV value;
613 if (posfixnump(element) && ((value = posfixnum_to_V(element)) < bit(4))) {
614 var uintB* ptr = &TheSbvector(datenvektor)->data[index/2];
615 *ptr ^= (*ptr ^ (value<<(4*((~index)%2)))) & ((bit(4)-1)<<(4*((~index)%2)));
616 return datenvektor;
617 }
618 }
619 break;
620 case Array_type_sb8vector: {
621 var uintV value;
622 if (posfixnump(element) && ((value = posfixnum_to_V(element)) < bit(8))) {
623 TheSbvector(datenvektor)->data[index] = value;
624 return datenvektor;
625 }
626 }
627 break;
628 case Array_type_sb16vector: {
629 var uintV value;
630 if (posfixnump(element) && ((value = posfixnum_to_V(element)) < bit(16))) {
631 ((uint16*)&TheSbvector(datenvektor)->data[0])[index] = value;
632 return datenvektor;
633 }
634 }
635 break;
636 case Array_type_sb32vector:
637 ((uint32*)&TheSbvector(datenvektor)->data[0])[index] = I_to_UL(element); /* poss. error-message does I_to_UL */
638 return datenvektor;
639 #ifdef TYPECODES
640 case_sstring:
641 if (sstring_immutable(TheSstring(datenvektor)))
642 error_sstring_immutable(datenvektor);
643 #ifdef HAVE_SMALL_SSTRING
644 switch (sstring_eltype(TheSstring(datenvektor))) {
645 case Sstringtype_8Bit: goto case_s8string;
646 case Sstringtype_16Bit: goto case_s16string;
647 case Sstringtype_32Bit: goto case_s32string;
648 default: NOTREACHED;
649 }
650 #else
651 goto case_s32string;
652 #endif
653 #else
654 case Rectype_Imm_S8string:
655 case Rectype_Imm_S16string:
656 case Rectype_Imm_S32string: /* immutable Simple-String */
657 error_sstring_immutable(datenvektor);
658 #ifdef HAVE_SMALL_SSTRING
659 case Rectype_S8string: /* mutable Simple-String */
660 goto case_s8string;
661 case Rectype_S16string: /* mutable Simple-String */
662 goto case_s16string;
663 case Rectype_S32string: /* mutable Simple-String */
664 goto case_s32string;
665 #else
666 case Rectype_S8string: case Rectype_S16string: case Rectype_S32string:
667 goto case_s32string;
668 #endif
669 #endif
670 #ifdef HAVE_SMALL_SSTRING
671 case_s8string:
672 if (charp(element)) {
673 if (char_int(element) < cint8_limit)
674 TheS8string(datenvektor)->data[index] = char_int(element);
675 else if (allowgc) {
676 if (char_int(element) < cint16_limit) {
677 datenvektor = reallocate_small_string(datenvektor,Sstringtype_16Bit);
678 TheS16string(TheSistring(datenvektor)->data)->data[index] = char_int(element);
679 } else {
680 datenvektor = reallocate_small_string(datenvektor,Sstringtype_32Bit);
681 TheS32string(TheSistring(datenvektor)->data)->data[index] = char_int(element);
682 }
683 } else
684 NOTREACHED;
685 return datenvektor;
686 }
687 break;
688 case_s16string: /* mutable Simple-String */
689 if (charp(element)) {
690 if (char_int(element) < cint16_limit)
691 TheS16string(datenvektor)->data[index] = char_int(element);
692 else if (allowgc) {
693 datenvektor = reallocate_small_string(datenvektor,Sstringtype_32Bit);
694 TheS32string(TheSistring(datenvektor)->data)->data[index] = char_int(element);
695 } else
696 NOTREACHED;
697 return datenvektor;
698 }
699 break;
700 #endif
701 case_s32string: /* mutable Simple-String */
702 if (charp(element)) {
703 TheS32string(datenvektor)->data[index] = char_int(element);
704 return datenvektor;
705 }
706 break;
707 case Array_type_snilvector: /* (VECTOR NIL) */
708 break;
709 default: NOTREACHED;
710 }
711 /* Object was of wrong type. */
712 error_store(STACK_0,element);
713 }
714
715 LISPFUN(aref,seclass_read,1,0,rest,nokey,0,NIL)
716 { /* (AREF array {subscript}), CLTL p. 290 */
717 var object array = check_array(Before(rest_args_pointer)); /* fetch array */
718 /* process subscripts and fetch data vector and index: */
719 var uintL index;
720 var object datenvektor =
721 subscripts_to_index(array,rest_args_pointer,argcount, &index);
722 /* fetch element of the data vector: */
723 VALUES1(storagevector_aref(datenvektor,index));
724 skipSTACK(1);
725 }
726
727 LISPFUN(store,seclass_default,2,0,rest,nokey,0,NIL)
728 { /* (SYS::STORE array {subscript} object)
729 = (SETF (AREF array {subscript}) object), CLTL p. 291 */
730 rest_args_pointer skipSTACKop 1; /* pointer to first Subscript */
731 var object array = Before(rest_args_pointer) = check_array(Before(rest_args_pointer)); /* fetch array */
732 var object element = popSTACK();
733 /* process subscripts and fetch data vector and index: */
734 var uintL index;
735 var object datenvektor =
736 subscripts_to_index(array,rest_args_pointer,argcount, &index);
737 /* store element in the data vector: */
738 pushSTACK(STACK_0); STACK_1 = element;
739 /* Stack layout: element, array. */
740 storagevector_store(datenvektor,index,element,true);
741 VALUES1(STACK_1);
742 skipSTACK(2);
743 }
744
745 LISPFUNNR(svref,2)
746 { /* (SVREF simple-vector index), CLTL p. 291 */
747 /* check simple-vector: */
748 if (!simple_vector_p(STACK_1))
749 error_no_svector(TheSubr(subr_self)->name,STACK_1);
750 /* check index: */
751 var uintL index = test_index(STACK_1);
752 /* fetch element: */
753 VALUES1(TheSvector(STACK_1)->data[index]);
754 skipSTACK(2);
755 }
756
757 LISPFUNN(svstore,3)
758 { /* (SYS::SVSTORE simple-vector index element)
759 = (SETF (SVREF simple-vector index) element), CLTL p. 291 */
760 var object element = popSTACK();
761 /* check simple-vector: */
762 if (!simple_vector_p(STACK_1))
763 error_no_svector(TheSubr(subr_self)->name,STACK_1);
764 /* check index: */
765 var uintL index = test_index(STACK_1);
766 /* store element: */
767 TheSvector(STACK_1)->data[index] = element;
768 VALUES1(element);
769 skipSTACK(2);
770 }
771
772 LISPFUNN(psvstore,3)
773 { /* (SYS::%SVSTORE element simple-vector index)
774 = (SETF (SVREF simple-vector index) element) */
775 /* check simple-vector: */
776 if (!simple_vector_p(STACK_1))
777 error_no_svector(TheSubr(subr_self)->name,STACK_1);
778 /* check index: */
779 var uintL index = test_index(STACK_1);
780 /* store element: */
781 VALUES1(TheSvector(STACK_1)->data[index] = STACK_2);
782 skipSTACK(3);
783 }
784
785 LISPFUNNR(row_major_aref,2)
786 { /* (ROW-MAJOR-AREF array index), CLtL2 p. 450 */
787 var object array = check_array(STACK_1);
788 /* check index: */
789 if (!posfixnump(STACK_0))
790 error_index_type(array);
791 var uintV indexv = posfixnum_to_V(STACK_0);
792 if (indexv >= array_total_size(array)) /* index must be smaller than size */
793 error_index_range(array,array_total_size(array));
794 var uintL index = indexv;
795 if (array_simplep(array)) {
796 sstring_un_realloc(array);
797 } else {
798 array = iarray_displace(array,&index);
799 }
800 VALUES1(storagevector_aref(array,index));
801 skipSTACK(2);
802 }
803
804 LISPFUNN(row_major_store,3)
805 { /* (SYS::ROW-MAJOR-STORE array index element)
806 = (SETF (ROW-MAJOR-AREF array index) element), CLtL2 p. 450 */
807 var object array = STACK_2 = check_array(STACK_2);
808 var object element = popSTACK();
809 /* check index: */
810 if (!posfixnump(STACK_0))
811 error_index_type(array);
812 var uintV indexv = posfixnum_to_V(STACK_0);
813 if (indexv >= array_total_size(array)) /* index must be smaller than size */
814 error_index_range(array,array_total_size(array));
815 var uintL index = indexv;
816 STACK_0 = array; STACK_1 = element;
817 /* Stack layout: element, array. */
818 if (array_simplep(array)) {
819 sstring_un_realloc(array);
820 } else {
821 array = iarray_displace(array,&index);
822 }
823 storagevector_store(array,index,element,true);
824 VALUES1(STACK_1);
825 skipSTACK(2);
826 }
827
828 /* ======================================================================== */
829 /* Information about an array */
830
831 /* return Atype for the given array
832 exported for the sake of modules */
array_atype(object array)833 modexp uintBWL array_atype (object array)
834 {
835 switch (Array_type(array)) {
836 case Array_type_mdarray: /* general array -> look at Arrayflags */
837 case Array_type_string: /* STRING or (VECTOR NIL) */
838 { return Iarray_flags(array) & arrayflags_atype_mask; }
839 case Array_type_sbvector:
840 case Array_type_sb2vector:
841 case Array_type_sb4vector:
842 case Array_type_sb8vector:
843 case Array_type_sb16vector:
844 case Array_type_sb32vector:
845 { return sbNvector_atype(array); }
846 case Array_type_bvector:
847 case Array_type_b2vector:
848 case Array_type_b4vector:
849 case Array_type_b8vector:
850 case Array_type_b16vector:
851 case Array_type_b32vector:
852 { return bNvector_atype(array); }
853 case Array_type_sstring:
854 { return Atype_Char; }
855 case Array_type_svector:
856 case Array_type_vector: /* [GENERAL-]VECTOR */
857 { return Atype_T; }
858 #if 0 /* not necessary */
859 case Array_type_snilvector:
860 { return Atype_NIL; }
861 #endif
862 default: NOTREACHED;
863 }
864 }
865
866 /* Function: Returns the element-type of an array.
867 array_element_type(array)
868 > array: an array
869 < result: element-type, one of the symbols T, BIT, CHARACTER, or a list
870 can trigger GC */
array_element_type(object array)871 global maygc object array_element_type (object array) {
872 var uintBWL atype = array_atype(array);
873 switch (atype) {
874 case Atype_T: { return S(t); } /* T */
875 case Atype_Bit: { return S(bit); } /* BIT */
876 case Atype_Char: { return S(character); } /* CHARACTER */
877 case Atype_2Bit: /* (UNSIGNED-BYTE 2) */
878 case Atype_4Bit: /* (UNSIGNED-BYTE 4) */
879 case Atype_8Bit: /* (UNSIGNED-BYTE 8) */
880 case Atype_16Bit: /* (UNSIGNED-BYTE 16) */
881 case Atype_32Bit: { /* (UNSIGNED-BYTE 32) */
882 pushSTACK(S(unsigned_byte));
883 pushSTACK(fixnum(bit(atype)));
884 } return listof(2);
885 case Atype_NIL: { return S(nil); } /* (VECTOR NIL) -> NIL */
886 default: NOTREACHED;
887 }
888 }
889
890 LISPFUNNF(array_element_type,1)
891 { /* (ARRAY-ELEMENT-TYPE array), CLTL p. 291 */
892 var object array = check_array(popSTACK());
893 VALUES1(array_element_type(array));
894 }
895
896 LISPFUNNF(array_rank,1)
897 { /* (ARRAY-RANK array), CLTL p. 292 */
898 var object array = check_array(popSTACK());
899 VALUES1(arrayrank(array));
900 }
901
902 LISPFUNNR(array_dimension,2)
903 { /* (ARRAY-DIMENSION array axis-number), CLTL p. 292 */
904 var object array = check_array(STACK_1);
905 var object axis_number = STACK_0;
906 skipSTACK(2);
907 if (array_simplep(array)) {
908 /* simple vector: axis-number must be =0, value is then the length. */
909 if (eq(axis_number,Fixnum_0)) {
910 if (simple_string_p(array)) {
911 sstring_un_realloc(array);
912 VALUES1(fixnum(Sstring_length(array)));
913 } else {
914 VALUES1(fixnum(Sarray_length(array)));
915 }
916 return;
917 } else
918 goto error_axis;
919 } else { /* non-simple array */
920 if (posfixnump(axis_number)) { /* axis-number must be a fixnum >=0, */
921 var uintV axis = posfixnum_to_V(axis_number);
922 if (axis < (uintL)Iarray_rank(array)) { /* and <rank */
923 var uintL* dimptr = &TheIarray(array)->dims[0];
924 if (Iarray_flags(array) & bit(arrayflags_dispoffset_bit))
925 dimptr++; /* poss. skip displaced-offset */
926 VALUES1(fixnum(dimptr[axis])); return;
927 } else
928 goto error_axis;
929 } else
930 goto error_axis;
931 }
932 error_axis:
933 pushSTACK(array);
934 pushSTACK(axis_number); /* TYPE-ERROR slot DATUM */
935 { /* TYPE-ERROR slot EXPECTED-TYPE */
936 var object tmp;
937 pushSTACK(S(integer)); pushSTACK(Fixnum_0); pushSTACK(arrayrank(array));
938 tmp = listof(1); pushSTACK(tmp); tmp = listof(3); pushSTACK(tmp);
939 }
940 pushSTACK(STACK_2); /* array */
941 pushSTACK(STACK_2); /* axis_number */
942 pushSTACK(TheSubr(subr_self)->name);
943 error(type_error,GETTEXT("~S: ~S is not an nonnegative integer less than the rank of ~S"));
944 }
945
946 /* Returns the rank of an array.
947 array_rank(array)
948 > array: an array
949 < uintL result: its rank = number of dimensions
950 exists for the sake of modules */
array_rank(object array)951 modexp uintL array_rank (object array) {
952 if (mdarrayp(array))
953 /* multi-dimensional array */
954 return Iarray_rank(array);
955 else
956 /* vector has rank 1 */
957 return 1;
958 }
959
960 /* Returns the dimensions of an array.
961 get_array_dimensions(array,rank,&dimensions[]);
962 > array: an array
963 > uintL rank: = array_rank(array)
964 > uintL dimensions[0..rank-1]: room for rank dimensions
965 < uintL dimensions[0..rank-1]: the array's dimensions
966 exists for the sake of modules */
get_array_dimensions(object array,uintL rank,uintL * dimensions)967 modexp void get_array_dimensions (object array, uintL rank, uintL* dimensions) {
968 if (array_simplep(array)) {
969 /* simple vector */
970 ASSERT(rank == 1);
971 if (simple_string_p(array)) {
972 sstring_un_realloc(array);
973 dimensions[0] = Sstring_length(array);
974 } else
975 dimensions[0] = Sarray_length(array);
976 } else {
977 ASSERT(rank == Iarray_rank(array));
978 if (rank > 0) {
979 var uintL* dimptr = &TheIarray(array)->dims[0];
980 if (Iarray_flags(array) & bit(arrayflags_dispoffset_bit))
981 dimptr++; /* poss. skip displaced-offset */
982 dotimespL(rank,rank, { *dimensions++ = *dimptr++; });
983 }
984 }
985 }
986
987 /* Function: Returns the list of dimensions of an array.
988 array_dimensions(array)
989 > array: an array
990 < result: list of its dimensions
991 can trigger GC */
array_dimensions(object array)992 global maygc object array_dimensions (object array) {
993 if (array_simplep(array)) { /* simple vector, form (LIST length) */
994 var object len; /* length as fixnum (non endangered by GC) */
995 if (simple_string_p(array)) {
996 sstring_un_realloc(array);
997 len = fixnum(Sstring_length(array));
998 } else {
999 len = fixnum(Sarray_length(array));
1000 }
1001 var object new_cons = allocate_cons();
1002 Car(new_cons) = len; Cdr(new_cons) = NIL;
1003 return new_cons;
1004 } else { /* non-simple array: */
1005 /* All dimensions as fixnums on the STACK, then turn it into a list. */
1006 var uintC rank = Iarray_rank(array);
1007 if (rank > 0) {
1008 var uintL* dimptr = &TheIarray(array)->dims[0];
1009 if (Iarray_flags(array) & bit(arrayflags_dispoffset_bit))
1010 dimptr++; /* poss. skip displaced-offset */
1011 get_space_on_STACK(sizeof(gcv_object_t)*(uintL)rank); /* check STACK */
1012 {
1013 var uintC count;
1014 dotimespC(count,rank, { /* next dimension as fixnum into the stack: */
1015 pushSTACK(fixnum(*dimptr++));
1016 });
1017 }
1018 }
1019 return listof(rank); /* form list */
1020 }
1021 }
1022
1023 LISPFUNNR(array_dimensions,1)
1024 { /* (ARRAY-DIMENSIONS array), CLTL p. 292 */
1025 var object array = check_array(popSTACK());
1026 VALUES1(array_dimensions(array));
1027 }
1028
1029 /* Function: Returns the dimensions of an array and their partial products.
1030 iarray_dims_sizes(array,&dims_sizes);
1031 > array: indirect array of rank r
1032 > struct { uintL dim; uintL dimprod; } dims_sizes[r]: room for the result
1033 < for i=1,...r: dims_sizes[r-i] = { Dim_i, Dim_i * ... * Dim_r } */
iarray_dims_sizes(object array,array_dim_size_t * dims_sizes)1034 global void iarray_dims_sizes (object array, array_dim_size_t* dims_sizes) {
1035 var uintC r = Iarray_rank(array); /* rank */
1036 if (r > 0) {
1037 var const uintL* dimptr = &TheIarray(array)->dims[0];
1038 if (Iarray_flags(array) & bit(arrayflags_dispoffset_bit))
1039 dimptr++; /* poss. skip displaced-offset */
1040 dimptr = &dimptr[(uintL)r]; /* pointer behind the dimensions */
1041 var uintL produkt = 1;
1042 dotimespC(r,r, { /* loop over the r dimensions from behind */
1043 var uintL dim = *--dimptr; /* next dimension */
1044 produkt = mulu32_unchecked(produkt,dim); /* multiply to the product */
1045 /* There will be no overflow, because this is
1046 < product of the dimensions so far
1047 <= product of all dimensions < arraysize_limit <= 2^32 .
1048 (exception: if a dimension of smaller number is =0 .
1049 But then the current product is anyway irrelevant, because
1050 each loop over this dimension is an empty loop.) */
1051 dims_sizes->dim = dim; dims_sizes->dimprod = produkt;
1052 dims_sizes++;
1053 });
1054 }
1055 }
1056
1057 LISPFUNNR(array_total_size,1)
1058 { /* (ARRAY-TOTAL-SIZE array), CLTL p. 292 */
1059 var object array = check_array(popSTACK());
1060 VALUES1(fixnum(array_total_size(array)));
1061 }
1062
1063 LISPFUN(array_in_bounds_p,seclass_read,1,0,rest,nokey,0,NIL)
1064 { /* (ARRAY-IN-BOUNDS-P array {subscript}), CLTL p. 292 */
1065 var gcv_object_t* argptr = rest_args_pointer;
1066 var object array = check_array(BEFORE(rest_args_pointer)); /* fetch array */
1067 if (array_simplep(array)) { /* simple vector is treated separately: */
1068 /* check number of subscripts: */
1069 if (argcount != 1) /* should be = 1 */
1070 error_subscript_count(array,argcount);
1071 /* check subscript itself: */
1072 var object subscriptobj = STACK_0; /* subscript as object */
1073 if (!integerp(subscriptobj)) /* must be an integer */
1074 error_index_type(array);
1075 /* subscript must be fixnum>=0 , */
1076 /* subscript as uintL must be smaller than length: */
1077 if (!posfixnump(subscriptobj)) goto no;
1078 if (simple_string_p(array)) {
1079 sstring_un_realloc(array);
1080 if (!(posfixnum_to_V(subscriptobj) < Sstring_length(array))) goto no;
1081 } else {
1082 if (!(posfixnum_to_V(subscriptobj) < Sarray_length(array))) goto no;
1083 }
1084 goto yes;
1085 } else { /* non-simple array */
1086 /* check number of subscripts: */
1087 if (!(argcount == Iarray_rank(array))) /* should be = rank */
1088 error_subscript_count(array,argcount);
1089 /* check subscripts itself: */
1090 if (argcount > 0) {
1091 var uintL* dimptr = &TheIarray(array)->dims[0];
1092 if (Iarray_flags(array) & bit(arrayflags_dispoffset_bit))
1093 dimptr++; /* poss. skip displaced-offset */
1094 var uintC count;
1095 dotimespC(count,argcount, {
1096 var object subscriptobj = NEXT(argptr); /* subscript as object */
1097 if (!integerp(subscriptobj)) { /* must be an integer */
1098 Next(rest_args_pointer) = array;
1099 error_subscript_type(argcount);
1100 }
1101 /* subscript must be fixnum>=0 , and subscript as uintL
1102 must be smaller than the corresponding dimension: */
1103 if (!( posfixnump(subscriptobj)
1104 && (posfixnum_to_V(subscriptobj) < *dimptr++) ))
1105 goto no;
1106 });
1107 }
1108 goto yes;
1109 }
1110 yes:
1111 VALUES1(T); set_args_end_pointer(rest_args_pointer); return;
1112 no:
1113 VALUES1(NIL); set_args_end_pointer(rest_args_pointer); return;
1114 }
1115
1116 LISPFUN(array_row_major_index,seclass_read,1,0,rest,nokey,0,NIL)
1117 { /* (ARRAY-ROW-MAJOR-INDEX array {subscript}), CLTL p. 293 */
1118 var object array = check_array(Before(rest_args_pointer)); /* fetch array */
1119 var uintL index;
1120 if (array_simplep(array)) { /* simple vector is treated separately: */
1121 /* check number of subscripts: */
1122 if (argcount != 1) /* should be = 1 */
1123 error_subscript_count(array,argcount);
1124 sstring_un_realloc(array);
1125 /* check subscript itself: */
1126 test_index(array);
1127 VALUES1(popSTACK()); /* Index = Row-Major-Index = Subscript */
1128 skipSTACK(1);
1129 } else { /* non-simple array */
1130 /* check subscripts, calculate row-major-index, clean up STACK: */
1131 index = test_subscripts(array,rest_args_pointer,argcount);
1132 /* return index as fixnum: */
1133 VALUES1(fixnum(index));
1134 skipSTACK(1);
1135 }
1136 }
1137
1138 LISPFUNNF(adjustable_array_p,1)
1139 { /* (ADJUSTABLE-ARRAY-P array), CLTL p. 293 */
1140 var object array = check_array(popSTACK()); /* fetch argument */
1141 VALUES_IF(!array_simplep(array)
1142 && (Iarray_flags(array) & bit(arrayflags_adjustable_bit)));
1143 }
1144
1145 LISPFUNN(array_displacement,1)
1146 { /* (ARRAY-DISPLACEMENT array), CLHS */
1147 var object array = check_array(popSTACK()); /* fetch argument */
1148 if (!array_simplep(array)
1149 && (Iarray_flags(array) & bit(arrayflags_displaced_bit))) {
1150 VALUES2(TheIarray(array)->data, /* next array */
1151 fixnum(TheIarray(array)->dims[0])); /* displaced offset */
1152 } else {
1153 VALUES2(NIL, Fixnum_0);
1154 }
1155 }
1156
1157 /* ======================================================================== */
1158 /* Bit arrays and bit vectors */
1159
1160 /* error: not a bit array
1161 error_bit_array()
1162 > array: array, that is not a bit-array */
error_bit_array(object array)1163 local _Noreturn void error_bit_array (object array) {
1164 pushSTACK(array); /* TYPE-ERROR slot DATUM */
1165 pushSTACK(O(type_array_bit)); /* TYPE-ERROR slot EXPECTED-TYPE */
1166 pushSTACK(array);
1167 pushSTACK(TheSubr(subr_self)->name);
1168 error(type_error,GETTEXT("~S: ~S is not an array of bits"));
1169 }
1170
1171 LISPFUN(bit,seclass_read,1,0,rest,nokey,0,NIL)
1172 { /* (BIT bit-array {subscript}), CLTL p. 293 */
1173 var object array = check_array(Before(rest_args_pointer)); /* fetch array */
1174 /* process subscripts and fetch data vector and index: */
1175 var uintL index;
1176 var object datenvektor =
1177 subscripts_to_index(array,rest_args_pointer,argcount, &index);
1178 if (!simple_bit_vector_p(Atype_Bit,datenvektor))
1179 error_bit_array(array);
1180 /* data vector is a simple-bit-vector. Fetch element of the data vector: */
1181 VALUES1(( sbvector_btst(datenvektor,index) ? Fixnum_1 : Fixnum_0 ));
1182 skipSTACK(1);
1183 }
1184
1185 LISPFUN(sbit,seclass_read,1,0,rest,nokey,0,NIL)
1186 { /* (SBIT bit-array {subscript}), CLTL p. 293 */
1187 var object array = check_array(Before(rest_args_pointer)); /* fetch array */
1188 /* process subscripts and fetch data vector and index: */
1189 var uintL index;
1190 var object datenvektor =
1191 subscripts_to_index(array,rest_args_pointer,argcount, &index);
1192 if (!simple_bit_vector_p(Atype_Bit,datenvektor))
1193 error_bit_array(array);
1194 /* data vector is a simple-bit-vector. Fetch element of the data vector: */
1195 VALUES1(( sbvector_btst(datenvektor,index) ? Fixnum_1 : Fixnum_0 ));
1196 skipSTACK(1);
1197 }
1198
1199 /* For subroutines for bit vectors:
1200 We work with bit-blocks with bitpack bits.
1201 uint_bitpack_t is an unsigned integer with bitpack bits.
1202 uint_2bitpack_t is an unsigned integer with 2*bitpack bits.
1203 R_bitpack(x) returns the right (lower) half of a uint_2bitpack_t.
1204 L_bitpack(x) returns the left (upper) half of a uint_2bitpack_t.
1205 LR_2bitpack(x,y) returns for x,y the uint_2bitpack_t concatenated from
1206 the left half x and the right half y.
1207 Use LR_0_bitpack(y) if x=0, LR_bitpack_0(x) if y=0. */
1208 #if defined(WIDE_HARD) && BIG_ENDIAN_P && (varobject_alignment%4 == 0)
1209 /* On big-endian-64-bit-machines we can work with 32 bit at a
1210 time (so long as varobject_alignment is divisible by 4 bytes): */
1211 #define bitpack 32
1212 #define uint_bitpack_t uint32
1213 #define uint_2bitpack_t uint64
1214 #define R_bitpack(x) ((uint32)(uint64)(x))
1215 #define L_bitpack(x) ((uint32)((uint64)(x)>>32))
1216 #define LR_2bitpack(x,y) (((uint64)(uint32)(x)<<32)|(uint64)(uint32)(y))
1217 #define LR_0_bitpack(y) ((uint64)(uint32)(y))
1218 #define LR_bitpack_0(x) ((uint64)(uint32)(x)<<32)
1219 #elif BIG_ENDIAN_P && (varobject_alignment%2 == 0)
1220 /* On big-endian-machines we can work with 16 bit at a time
1221 (so long as varobject_alignment is divisible by 2 bytes): */
1222 #define bitpack 16
1223 #define uint_bitpack_t uint16
1224 #define uint_2bitpack_t uint32
1225 #define R_bitpack(x) low16(x)
1226 #define L_bitpack(x) high16(x)
1227 #define LR_2bitpack(x,y) highlow32(x,y)
1228 #define LR_0_bitpack(y) ((uint32)(uint16)(y))
1229 #define LR_bitpack_0(x) highlow32_0(x)
1230 #else
1231 /* Otherwise we can take only 8 bits at a time: */
1232 #define bitpack 8
1233 #define uint_bitpack_t uint8
1234 #define uint_2bitpack_t uint16
1235 #define R_bitpack(x) ((uint_bitpack_t)(uint_2bitpack_t)(x))
1236 #define L_bitpack(x) ((uint_bitpack_t)((uint_2bitpack_t)(x) >> bitpack))
1237 #define LR_2bitpack(x,y) \
1238 (((uint_2bitpack_t)(uint_bitpack_t)(x) << bitpack) \
1239 | (uint_2bitpack_t)(uint_bitpack_t)(y))
1240 #define LR_0_bitpack(y) LR_2bitpack(0,y)
1241 #define LR_bitpack_0(x) LR_2bitpack(x,0)
1242 #endif
1243
1244 /* Function: Compares two slices of simple-bit-vectors.
1245 bit_compare(array1,index1,array2,index2,count)
1246 > array1: first simple-bit-vector
1247 > index1: absolute index into array1
1248 > array2: second simple-bit-vector
1249 > index2: absolute index into array2
1250 > count: number of bits to be compared, > 0
1251 < result: true, if both slices are the same, bit for bit, else false. */
bit_compare(object array1,uintL index1,object array2,uintL index2,uintL bitcount)1252 global bool bit_compare (object array1, uintL index1,
1253 object array2, uintL index2,
1254 uintL bitcount)
1255 {
1256 var const uint_bitpack_t* ptr1 = &((uint_bitpack_t*)(&TheSbvector(array1)->data[0]))[index1/bitpack];
1257 var const uint_bitpack_t* ptr2 = &((uint_bitpack_t*)(&TheSbvector(array2)->data[0]))[index2/bitpack];
1258 /* ptr1 points to the first word of the 1st bit-array.
1259 ptr2 points to the first word of the 2nd bit-array. */
1260 index1 = index1 % bitpack; /* bit-offset in the 1st bit-array */
1261 index2 = index2 % bitpack; /* bit-offset in the 2nd bit-array */
1262 if (index1 == index2) { /* process first word: */
1263 if (index1 != 0) {
1264 var uintL count1 = bitpack - index1;
1265 if (count1 >= bitcount) {
1266 /* compare bits bitpack-index1-1..bitpack-index1-bitcount
1267 in *ptr1 und *ptr2. */
1268 return (((*ptr1 ^ *ptr2) & (bit(count1)-bit(count1-bitcount))) == 0);
1269 }
1270 if (((*ptr1 ^ *ptr2) & (bit(count1)-1)) != 0)
1271 return false;
1272 ptr1++;
1273 ptr2++;
1274 bitcount -= count1; /* still > 0 */
1275 }
1276 /* Now we can assume index1 = index2 = 0 . */
1277 var uintL bitpackcount = bitcount/bitpack;
1278 /* bitpackcount = number of entire words */
1279 var uintL bitcount_rest = bitcount % bitpack;
1280 /* bitcount_rest = number of remaining bits */
1281 /* simple loop, because all bit-offsets in word are =0 : */
1282 dotimesL(bitpackcount,bitpackcount, {
1283 if (*ptr1++ != *ptr2++)
1284 return false;
1285 });
1286 /* bitcount_rest = number of bits still to be compared */
1287 if (bitcount_rest!=0) {
1288 /* compare last word: */
1289 if (!(( (*ptr1 ^ *ptr2)
1290 & /* set bitmask with bits bitpack-1..bitpack-bitcount_rest */
1291 ~( (uint_bitpack_t)(bitm(bitpack)-1) >> bitcount_rest)) ==0))
1292 return false;
1293 }
1294 return true;
1295 } else {
1296 /* complicated loop: */
1297 var uintL bitpackcount = bitcount/bitpack;
1298 /* bitpackcount = number of entire words */
1299 var uintL bitcount_rest = bitcount % bitpack;
1300 /* bitcount_rest = number of remaining bits
1301 We distinguish three cases in order to avoid a memory overrun bug.
1302 The tighter loops are just an added benefit for speed. */
1303 if (index1 == 0) {
1304 /* index1 = 0, index2 > 0. */
1305 var uint_2bitpack_t carry2 = LR_bitpack_0((*ptr2++) << index2);
1306 /* carry2 has in its upper bitpack-index2 bits
1307 (bits 2*bitpack-1..bitpack+index2)
1308 the affected bits of the 1st word of the 2nd array, else nulls. */
1309 dotimesL(bitpackcount,bitpackcount, {
1310 /* comparison loop (wordwise):
1311 after n>=0 loop runs ptr1 is advanced by n,
1312 nd ptr2 is advanced by n+1 words, which means pointer to
1313 the next word of the 1st resp. 2nd array,
1314 bitpackcount = number of entire words to be combined - n,
1315 carry2 = carry from 2nd array
1316 (in the bitpack-index2 upper bits, else null). */
1317 if (!(*ptr1++
1318 ==
1319 ( carry2 |=
1320 LR_0_bitpack(*ptr2++) /* read next word of the 2nd array */
1321 << index2, /* add to carry2 */
1322 L_bitpack(carry2)))) /* and use the left word from it */
1323 return false;
1324 carry2 = LR_bitpack_0(R_bitpack(carry2)); /* carry2 := right word of carry2 */
1325 });
1326 /* still bitcount_rest bits to compare: */
1327 if (bitcount_rest!=0) { /* compare last word: */
1328 if (!(((*ptr1++
1329 ^
1330 (carry2 |=
1331 LR_0_bitpack(*ptr2++) /* read the next word of the 2nd array */
1332 << index2, /* add to carry2 */
1333 L_bitpack(carry2))) /* and use the left word from it */
1334 & /* set bitmask with bits bitpack-1..bitpack-bitcount_rest */
1335 ~( (uint_bitpack_t)(bitm(bitpack)-1) >> bitcount_rest)) ==0))
1336 return false;
1337 }
1338 return true;
1339 } else if (index2 == 0) { /* index1 > 0, index2 = 0. */
1340 var uint_2bitpack_t carry1 = LR_bitpack_0((*ptr1++) << index1);
1341 /* carry1 has in its upper bitpack-index1 bits
1342 (bits 2*bitpack-1..bitpack+index1)
1343 the affected bits of the 1st word of the 1st array, else nulls. */
1344 dotimesL(bitpackcount,bitpackcount, {
1345 /* comparison loop (wordwise):
1346 after n>=0 loop runs, ptr1 is advanced by n+1,
1347 and ptr2 is advanced by n words, which means pointer to
1348 the next word to be read of the 1st resp. 2nd array,
1349 bitpackcount = number of entire words to be combined
1350 carry1 = carry from 1st array
1351 (in the bitpack-index1 upper bits, else null). */
1352 if (!((carry1 |=
1353 LR_0_bitpack(*ptr1++) /* read the next word of the 1st array */
1354 << index1, /* add to carry1 */
1355 L_bitpack(carry1)) /* and use the left word from it */
1356 ==
1357 *ptr2++))
1358 return false;
1359 carry1 = LR_bitpack_0(R_bitpack(carry1)); /* carry1 := right word of carry1 */
1360 });
1361 /* Still bitcount_rest bits to compare: */
1362 if (bitcount_rest!=0) {
1363 /* compare last word: */
1364 if (!((((carry1 |=
1365 LR_0_bitpack(*ptr1++) /* read the next word of 1st array */
1366 << index1, /* add to carry1 */
1367 L_bitpack(carry1)) /* and use the left word from it */
1368 ^
1369 *ptr2++)
1370 & /* set bitmask with bits bitpack-1..bitpack-bitcount_rest */
1371 ~( (uint_bitpack_t)(bitm(bitpack)-1) >> bitcount_rest)) ==0))
1372 return false;
1373 }
1374 return true;
1375 } else {
1376 var uint_2bitpack_t carry1 = LR_bitpack_0((*ptr1++) << index1);
1377 /* carry1 has in its upper bitpack-index1 bits
1378 (bits 2*bitpack-1..bitpack+index1)
1379 the affected bits of the 1st word of the 1st array, else nulls. */
1380 var uint_2bitpack_t carry2 = LR_bitpack_0((*ptr2++) << index2);
1381 /* carry2 has in its upper bitpack-index2 bits
1382 (bits 2*bitpack-1..bitpack+index2)
1383 the affected bits of the 1st word of the 2nd array, else nulls. */
1384 dotimesL(bitpackcount,bitpackcount, {
1385 /* comparison loop (wordwise):
1386 After n>=0 loop runs ptr1 and ptr2 are advanced
1387 by n+1 words, which means pointer to the
1388 next word to be read of the 1st resp. 2nd array,
1389 bitpackcount = number of entire words to be combined - n,
1390 carry1 = carry from 1st array
1391 (in the bitpack-index1 upper bits, else null),
1392 carry2 = carryfrom 2nd array
1393 (in the bitpack-index2 upper bits, else null). */
1394 if (!((carry1 |=
1395 LR_0_bitpack(*ptr1++) /* read next word of the 1st array */
1396 << index1, /* add to carry1 */
1397 L_bitpack(carry1)) /* and use the left word from it */
1398 ==
1399 ( carry2 |=
1400 LR_0_bitpack(*ptr2++) /* read next word of the 2nd array */
1401 << index2, /* add to carry2 */
1402 L_bitpack(carry2)))) /* and use the left word from it */
1403 return false;
1404 carry1 = LR_bitpack_0(R_bitpack(carry1)); /* carry1 := right word of carry1 */
1405 carry2 = LR_bitpack_0(R_bitpack(carry2)); /* carry2 := right word of carry2 */
1406 });
1407 /* still bitcount_rest bits to compare: */
1408 if (bitcount_rest!=0) { /* compare last word: */
1409 if (!((((carry1 |=
1410 LR_0_bitpack(*ptr1++) /* read next word of 1st array */
1411 << index1, /* add to carry1 */
1412 L_bitpack(carry1)) /* and use the left word from it */
1413 ^
1414 ( carry2 |=
1415 LR_0_bitpack(*ptr2++) /* read next word of the 2nd array */
1416 << index2, /* add to carry2 */
1417 L_bitpack(carry2))) /* and use the left word from it */
1418 & /* set bitmask with bits bitpack-1..bitpack-bitcount_rest */
1419 ~( (uint_bitpack_t)(bitm(bitpack)-1) >> bitcount_rest)) ==0))
1420 return false;
1421 }
1422 return true;
1423 }
1424 }
1425 }
1426
1427 /* Function: Copies a slice of a simple-bit-vector into another
1428 simple-bit-vector.
1429 bit_copy(array1,index1,array2,index2,count);
1430 > array1: source simple-bit-vector
1431 > index1: absolute index into array1
1432 > array2: destination simple-bit-vector
1433 > index2: absolute index into array2
1434 > count: number of bits to be copied, > 0 */
bit_copy(object array1,uintL index1,object array2,uintL index2,uintL bitcount)1435 local void bit_copy (object array1, uintL index1,
1436 object array2, uintL index2,
1437 uintL bitcount)
1438 {
1439 var const uint_bitpack_t* ptr1 = &((uint_bitpack_t*)(&TheSbvector(array1)->data[0]))[index1/bitpack];
1440 var uint_bitpack_t* ptr2 = &((uint_bitpack_t*)(&TheSbvector(array2)->data[0]))[index2/bitpack];
1441 /* ptr1 point to the first affected word in array1
1442 ptr2 point to the first affected word in array2 */
1443 index1 = index1 % bitpack; /* bit-offset in array1 */
1444 index2 = index2 % bitpack; /* bit-offset in array2 */
1445 if (index1 == index2) {
1446 /* Treat the first word. */
1447 if (index1 != 0) {
1448 var uintL count1 = bitpack - index1;
1449 if (count1 >= bitcount) {
1450 /* copy bits bitpack-index1-1..bitpack-index1-bitcount
1451 from *ptr1 to *ptr2 */
1452 *ptr2 ^= (bit(count1)-bit(count1-bitcount)) & (*ptr2 ^ *ptr1);
1453 return;
1454 }
1455 *ptr2 ^= (bit(count1)-1) & (*ptr2 ^ *ptr1);
1456 ptr1++;
1457 ptr2++;
1458 bitcount -= count1; /* still > 0 */
1459 }
1460 /* We can now assume index1 = index2 = 0. */
1461 var uintL bitpackcount = bitcount/bitpack;
1462 /* bitpackcount = number of complete words */
1463 var uintL bitcount_rest = bitcount % bitpack;
1464 /* bitcount_rest = number of remaining bits */
1465 /* simple loop, since all bit offsets are 0. */
1466 dotimesL(bitpackcount,bitpackcount, {
1467 *ptr2++ = *ptr1++;
1468 });
1469 if (bitcount_rest!=0)
1470 *ptr2 ^= ~( (uint_bitpack_t)(bitm(bitpack)-1) >> bitcount_rest) & (*ptr2 ^ *ptr1);
1471 } else {
1472 var uintL bitpackcount = bitcount/bitpack;
1473 /* bitpackcount = number of complete words */
1474 var uintL bitcount_rest = bitcount % bitpack;
1475 /* bitcount_rest = number of remaining bits */
1476 var uint_2bitpack_t carry2 =
1477 LR_bitpack_0( ( ~ ( (uint_bitpack_t)(bitm(bitpack)-1) >> index2) ) & *ptr2 );
1478 /* The upper index2 bits of carry2 are exactly those bits of *ptr2
1479 which must not be modified.
1480 We distinguish two cases in order to avoid a memory overrun bug.
1481 The tighter loop is just an added benefit for speed. */
1482 if (index1 == 0) {
1483 while (1) {
1484 /* After n>=0 rounds ptr1 has advanced by n words, i.e. it points
1485 to the next word to be read, and ptr2 has advanced by n words, i.e.
1486 it points to the next word to be written. bitpackcount has been
1487 decremented by n. */
1488 carry2 |= LR_bitpack_0(*ptr1++) >> index2;
1489 if (bitpackcount==0)
1490 break;
1491 *ptr2++ = L_bitpack(carry2);
1492 carry2 = LR_bitpack_0(R_bitpack(carry2));
1493 bitpackcount--;
1494 }
1495 } else { /* index1 > 0. */
1496 var uint_2bitpack_t carry1 = LR_bitpack_0((*ptr1++) << index1);
1497 /* The upper bitpack-index1 bits of carry1 are the affected bits of
1498 the first word of array1. The other bits in carry1 are zero. */
1499 while (1) {
1500 /* After n>=0 rounds ptr1 has advanced by n+1 words, i.e. it points
1501 to the next word to be read, and ptr2 has advanced by n words, i.e.
1502 it points to the next word to be written. bitpackcount has been
1503 decremented by n. */
1504 var uint_bitpack_t temp =
1505 (carry1 |= LR_0_bitpack(*ptr1++) << index1, L_bitpack(carry1));
1506 carry1 = LR_bitpack_0(R_bitpack(carry1));
1507 carry2 |= LR_bitpack_0(temp) >> index2;
1508 if (bitpackcount==0)
1509 break;
1510 *ptr2++ = L_bitpack(carry2);
1511 carry2 = LR_bitpack_0(R_bitpack(carry2));
1512 bitpackcount--;
1513 }
1514 }
1515 /* Special handling for the last word (now containd in the bits
1516 2*bitpack-index2-1..bitpack-index2 of carry2): Only bitcount_rest
1517 bits must be stored in array2 */
1518 bitcount_rest = index2+bitcount_rest;
1519 var uint_bitpack_t last_carry;
1520 if (bitcount_rest>=bitpack) {
1521 *ptr2++ = L_bitpack(carry2);
1522 last_carry = R_bitpack(carry2);
1523 bitcount_rest -= bitpack;
1524 } else {
1525 last_carry = L_bitpack(carry2);
1526 }
1527 if (bitcount_rest!=0)
1528 *ptr2 ^= (*ptr2 ^ last_carry) & (~( (uint_bitpack_t)(bitm(bitpack)-1) >> bitcount_rest ));
1529 }
1530 }
1531
1532 /* subroutine for bitvector-operations:
1533 bit_op(array1,index1,array2,index2,array3,index3,op,count);
1534 > array1: first bit-array,
1535 > index1: absolute index in array1
1536 > array2: second bit-array,
1537 > index2: absolute index in array2
1538 > array3: third bit-array,
1539 > index3: absoluter Index in array3
1540 > op: address of the operation
1541 > count: number of bits to combine, > 0
1542 bit_op_fun_t is a function that combines two bitpack-bit-words: */
1543 typedef uint_bitpack_t bit_op_fun_t (uint_bitpack_t x, uint_bitpack_t y);
bit_op(object array1,uintL index1,object array2,uintL index2,object array3,uintL index3,bit_op_fun_t * op,uintL bitcount)1544 local void bit_op (object array1, uintL index1,
1545 object array2, uintL index2,
1546 object array3, uintL index3,
1547 bit_op_fun_t* op, uintL bitcount)
1548 {
1549 var const uint_bitpack_t* ptr1 = &((uint_bitpack_t*)(&TheSbvector(array1)->data[0]))[index1/bitpack];
1550 var const uint_bitpack_t* ptr2 = &((uint_bitpack_t*)(&TheSbvector(array2)->data[0]))[index2/bitpack];
1551 var uint_bitpack_t* ptr3 = &((uint_bitpack_t*)(&TheSbvector(array3)->data[0]))[index3/bitpack];
1552 /* ptr1 points to the first word of the 1st bit-array.
1553 ptr2 points to the first word of the 2nd bit-array.
1554 ptr3 points to the first word of the 3rd bit-array. */
1555 var uintL bitpackcount = bitcount/bitpack;
1556 /* bitpackcount = number of entire words */
1557 var uintL bitcount_rest = bitcount % bitpack;
1558 /* bitcount_rest = number of remaining bits */
1559 index1 = index1 % bitpack; /* bit-offset in the 1st bit-array */
1560 index2 = index2 % bitpack; /* bit-offset in the 2nd bit-array */
1561 index3 = index3 % bitpack; /* bit-offset in the 3rd bit-array */
1562 if ((index1==0) && (index2==0) && (index3==0)) {
1563 /* simple loop, since all bit offsets in word are =0. */
1564 dotimesL(bitpackcount,bitpackcount, {
1565 *ptr3++ = (*op)(*ptr1++,*ptr2++);
1566 });
1567 /* bitcount_rest = remaining bits to file */
1568 if (bitcount_rest!=0) {
1569 /* file last word: */
1570 var uint_bitpack_t temp = (*op)(*ptr1,*ptr2);
1571 *ptr3 =
1572 ( ~
1573 ( (uint_bitpack_t)(bitm(bitpack)-1) >> bitcount_rest)
1574 /* set bitmask with bits bitpack-bitcount_rest-1..0 */
1575 /* set bitmask with bits bitpack-1..bitpack-bitcount_rest */
1576 &
1577 (*ptr3 ^ temp)) /* bits to change */
1578 ^ *ptr3;
1579 }
1580 } else {
1581 /* complicated loop: */
1582 var uint_2bitpack_t carry3 =
1583 LR_bitpack_0(
1584 (~
1585 (
1586 (uint_bitpack_t)(bitm(bitpack)-1) >> index3)
1587 /* set bitmask with bits bitpack-index3-1..0 */
1588 ) /* set bitmask with bits bitpack-1..bitpack-index3 */
1589 & (*ptr3));
1590 /* carry3 has in its upper index3 bits (bits 2*bitpack-1..2*bitpack-index3)
1591 precisely the bits of *ptr3 that must not be changed.
1592 We distinguish four cases in order to avoid a memory overrun bug.
1593 The tighter loops are just an added benefit for speed. */
1594 if (index1 == 0) {
1595 if (index2 == 0) {
1596 /* index1 = 0, index2 = 0. */
1597 while (1) {
1598 /* combination loop (wordwise):
1599 After n>=0 loop runs ptr1 and ptr2 are advanced
1600 by n words, which means pointer to the
1601 next word to read from the 1st resp. 2nd array,
1602 ptr3 is advanced by n words, which means pointer to the
1603 next word to write from the 3rd array,
1604 bitpackcount = number of entire words - n,
1605 carry3 = carry of bits still to save
1606 (in the index3 upper bits, else null). */
1607 var uint_bitpack_t temp =
1608 (*op)(*ptr1++,*ptr2++) ; /* combine both via *op */
1609 carry3 |= LR_bitpack_0(temp) >> index3;
1610 /* store the upper bitpack+index3 bits from carry3. */
1611 if (bitpackcount==0)
1612 break;
1613 *ptr3++ = L_bitpack(carry3); /* store bitpack bits */
1614 carry3 = LR_bitpack_0(R_bitpack(carry3)); /* and keep index3 bits for later. */
1615 bitpackcount--;
1616 }
1617 } else {
1618 /* index1 = 0, index2 > 0. */
1619 var uint_2bitpack_t carry2 = LR_bitpack_0((*ptr2++) << index2);
1620 /* carry2 has in its upper bitpack-index2 bits
1621 (bits 2*bitpack-1..bitpack+index2)
1622 the affected bits of the 1st word of the 2nd array, else nulls. */
1623 while (1) {
1624 /* combination loop (wordwise):
1625 After n>=0 loop runs ptr1 is advanced by n words
1626 and ptr2 has advanced by n+1 words, which means pointer to the
1627 next word to read from the 1st resp. 2nd array,
1628 ptr3 is advanced by n words, which means pointer to the
1629 next word to write from the 3rd array,
1630 bitpackcount = number of entire words - n,
1631 carry2 = carry from second array
1632 (in the bitpack-index2 upper bits, else Null),
1633 carry3 = carry of bits still to save
1634 (in the index3 upper bits, else null). */
1635 var uint_bitpack_t temp =
1636 (*op)(*ptr1++,
1637 ( carry2 |=
1638 LR_0_bitpack(*ptr2++) /* read next word of the 2nd array */
1639 << index2, /* add to carry2 */
1640 L_bitpack(carry2) /* and use the left word from it */
1641 )) ; /* combine both via *op */
1642 carry2 = LR_bitpack_0(R_bitpack(carry2)); /* carry2 := right word of carry2 */
1643 carry3 |= LR_bitpack_0(temp) >> index3;
1644 /* save the upper bitpack+index3 bits from carry3. */
1645 if (bitpackcount==0)
1646 break;
1647 *ptr3++ = L_bitpack(carry3); /* save bitpack bits */
1648 carry3 = LR_bitpack_0(R_bitpack(carry3)); /* and keep index3 bits for later. */
1649 bitpackcount--;
1650 }
1651 }
1652 } else {
1653 if (index2 == 0) {
1654 /* index1 > 0, index2 = 0. */
1655 var uint_2bitpack_t carry1 = LR_bitpack_0((*ptr1++) << index1);
1656 /* carry1 has in its upper bitpack-index1 bits
1657 (bits 2*bitpack-1..bitpack+index1)
1658 the affected bits of the 1st word of the 1st array, else nulls. */
1659 while (1) {
1660 /* combination loop (wordwise):
1661 After n>=0 loop runs ptr1 is advanced by n+1 words
1662 and ptr2 has advanced by n words, which means pointer to the
1663 next word to read from the 1st resp. 2nd array,
1664 ptr3 is advanced by n words, which means pointer to the
1665 next word to write from the 3rd array,
1666 bitpackcount = number of entire words - n,
1667 carry1 = carry from first array
1668 (in the bitpack-index1 upper bits, else Null),
1669 carry3 = carry of bits still to save
1670 (in the index3 upper bits, else null). */
1671 var uint_bitpack_t temp =
1672 (*op)(
1673 ( carry1 |=
1674 LR_0_bitpack(*ptr1++) /* read the next word of 1st array */
1675 << index1, /* add to carry1 */
1676 L_bitpack(carry1) /* and use the left word from it */
1677 ),
1678 *ptr2++) ; /* combine both via *op */
1679 carry1 = LR_bitpack_0(R_bitpack(carry1)); /* carry1 := right word of carry1 */
1680 carry3 |= LR_bitpack_0(temp) >> index3;
1681 /* store the upper bitpack+index3 bits of carry3. */
1682 if (bitpackcount==0)
1683 break;
1684 *ptr3++ = L_bitpack(carry3); /* store bitpack bits */
1685 carry3 = LR_bitpack_0(R_bitpack(carry3)); /* and keep index3 bits for later. */
1686 bitpackcount--;
1687 }
1688 } else {
1689 /* index1 > 0, index2 > 0. */
1690 var uint_2bitpack_t carry1 = LR_bitpack_0((*ptr1++) << index1);
1691 /* carry1 has in its upper bitpack-index1 bits
1692 (bits 2*bitpack-1..bitpack+index1)
1693 the affected bits of the 1st word of the 1st array, else nulls. */
1694 var uint_2bitpack_t carry2 = LR_bitpack_0((*ptr2++) << index2);
1695 /* carry2 has in its upper bitpack-index2 bits
1696 (bits 2*bitpack-1..bitpack+index2)
1697 the affected bits of the 1st word of the 2nd array, else nulls. */
1698 while (1) {
1699 /* combination loop (wordwise):
1700 After n>=0 loop runs ptr1 and ptr2 are advanced
1701 by n+1 words, which means pointer to the
1702 next word to read from the 1st resp. 2nd array,
1703 ptr3 is advanced by n words, which means pointer to the
1704 next word to write from the 3rd array,
1705 bitpackcount = number of entire words - n,
1706 carry1 = carry from first array
1707 (in the bitpack-index1 upper bits, else Null),
1708 carry2 = carry from second array
1709 (in the bitpack-index2 upper bits, else Null),
1710 carry3 = carry of bits still to save
1711 (in the index3 upper bits, else null). */
1712 var uint_bitpack_t temp =
1713 (*op)(
1714 ( carry1 |=
1715 LR_0_bitpack(*ptr1++) /* read next word of 1st array */
1716 << index1, /* add to carry1 */
1717 L_bitpack(carry1) /* and use the left word from it */
1718 ),
1719 ( carry2 |=
1720 LR_0_bitpack(*ptr2++) /* read next word of 2nd array */
1721 << index2, /* add to carry2 */
1722 L_bitpack(carry2) /* and use the left word from it */
1723 )
1724 ) ; /* combine both via *op */
1725 carry1 = LR_bitpack_0(R_bitpack(carry1)); /* carry1 := right word of carry1 */
1726 carry2 = LR_bitpack_0(R_bitpack(carry2)); /* carry2 := right word of carry2 */
1727 carry3 |= LR_bitpack_0(temp) >> index3;
1728 /* store the upper bitpack+index3 bits of carry3. */
1729 if (bitpackcount==0)
1730 break;
1731 *ptr3++ = L_bitpack(carry3); /* store bitpack bits */
1732 carry3 = LR_bitpack_0(R_bitpack(carry3)); /* and keep index3 bits for later. */
1733 bitpackcount--;
1734 }
1735 }
1736 }
1737 /* treat last (half) data word specially:
1738 From the last word (now in the bits
1739 2*bitpack-index3-1..bitpack-index3 of carry3)
1740 only bitcount_rest bits may be stored in the 3rd array. */
1741 bitcount_rest = index3+bitcount_rest;
1742 var uint_bitpack_t last_carry;
1743 /* store the upper bitcount_rest bits: */
1744 if (bitcount_rest>=bitpack) {
1745 *ptr3++ = L_bitpack(carry3);
1746 last_carry = R_bitpack(carry3);
1747 bitcount_rest -= bitpack;
1748 } else {
1749 last_carry = L_bitpack(carry3);
1750 }
1751 /* store the remaining bitcount_rest bits of last_carry: */
1752 if (bitcount_rest!=0)
1753 *ptr3 ^=
1754 (*ptr3 ^ last_carry)
1755 & (~( (uint_bitpack_t)(bitm(bitpack)-1) >> bitcount_rest ));
1756 /* bitmask, where the upper bitcount_rest bits are set */
1757 }
1758 }
1759
1760 /* subroutine for bit-combination with 2 operands
1761 bit_up(op)
1762 > STACK_2: bit-array1
1763 > STACK_1: bit-array2
1764 > STACK_0: result-bit-array or #<UNBOUND>
1765 > op: address of the combination routine
1766 < value1/mv_count: function value
1767 tests the arguments, cleans up STACK. */
bit_up(bit_op_fun_t * op)1768 local Values bit_up (bit_op_fun_t* op)
1769 {
1770 /* main distinction: vector / multi-dimensional array */
1771 var uintL len; /* length (of the 1st array), if vectors */
1772 var uintC rank; /* rank and */
1773 var uintL* dimptr; /* pointer to dimensions, if multi-dimensional */
1774 /* examine type of bit-array1 and branch accordingly: */
1775 #ifndef TYPECODES
1776 if (!orecordp(STACK_2))
1777 goto error2;
1778 #endif
1779 switch (Array_type(STACK_2)) {
1780 case Array_type_sbvector:
1781 len = Sbvector_length(STACK_2); goto vector;
1782 case Array_type_bvector:
1783 len = TheIarray(STACK_2)->totalsize; goto vector;
1784 case Array_type_mdarray: {
1785 var Iarray array1 = TheIarray(STACK_2);
1786 /* bit-array1 must have the element type BIT : */
1787 if ((iarray_flags(array1) & arrayflags_atype_mask) != Atype_Bit)
1788 goto error2;
1789 /* store rank: */
1790 rank = iarray_rank(array1);
1791 /* store dimensions: */
1792 dimptr = &array1->dims[0];
1793 if (iarray_flags(array1) & bit(arrayflags_dispoffset_bit))
1794 dimptr++;
1795 /* Totalsize is the number of the bits to combine: */
1796 len = array1->totalsize;
1797 goto array;
1798 }
1799 default:
1800 goto error2;
1801 }
1802 vector: /* The first argument is a bit-vector, with length len. */
1803 /* test, if this also applies to the other(s) : */
1804 /* check bit-array2: */
1805 #ifndef TYPECODES
1806 if (!orecordp(STACK_1))
1807 goto error2;
1808 #endif
1809 switch (Array_type(STACK_1)) {
1810 case Array_type_sbvector:
1811 if (len != Sbvector_length(STACK_1))
1812 goto error2;
1813 break;
1814 case Array_type_bvector:
1815 if (len != TheIarray(STACK_1)->totalsize)
1816 goto error2;
1817 break;
1818 default:
1819 goto error2;
1820 }
1821 { /* check bit-array3: */
1822 var object array3 = STACK_0;
1823 if (missingp(array3)) { /* unbound or NIL? */
1824 /* yes -> create new vector: */
1825 STACK_0 = allocate_bit_vector(Atype_Bit,len);
1826 } else if (eq(array3,T)) {
1827 STACK_0 = STACK_2; /* instead of T, use bit-array1 */
1828 } else {
1829 #ifndef TYPECODES
1830 if (!orecordp(STACK_0))
1831 goto error3;
1832 #endif
1833 switch (Array_type(STACK_0)) {
1834 case Array_type_sbvector:
1835 if (len != Sbvector_length(array3))
1836 goto error3;
1837 break;
1838 case Array_type_bvector:
1839 if (len != TheIarray(array3)->totalsize)
1840 goto error3;
1841 break;
1842 default:
1843 goto error3;
1844 }
1845 }
1846 }
1847 goto weiter;
1848 array: /* first argument was a multi-dimensional bit-array */
1849 /* with Rank rank, Dimensions at dimptr and Totalsize len. */
1850 /* check bit-array2: */
1851 #ifndef TYPECODES
1852 if (!orecordp(STACK_1))
1853 goto error2;
1854 #endif
1855 switch (Array_type(STACK_1)) {
1856 case Array_type_mdarray: {
1857 var Iarray array2 = TheIarray(STACK_1);
1858 /* bit-array2 must have the element type BIT : */
1859 if ((iarray_flags(array2) & arrayflags_atype_mask) != Atype_Bit)
1860 goto error2;
1861 /* compare rank: */
1862 if (rank != iarray_rank(array2))
1863 goto error2;
1864 /* compare dimensions: */
1865 if (rank > 0) {
1866 var uintC count;
1867 var uintL* dimptr1 = dimptr;
1868 var uintL* dimptr2 = &array2->dims[0];
1869 if (iarray_flags(array2) & bit(arrayflags_dispoffset_bit))
1870 dimptr2++;
1871 dotimespC(count,rank, {
1872 if (*dimptr1++ != *dimptr2++)
1873 goto error2;
1874 });
1875 }
1876 }
1877 break;
1878 default:
1879 goto error2;
1880 }
1881 { /* check bit-array3: */
1882 var object array3 = STACK_0;
1883 if (missingp(array3)) { /* unbound or NIL? */
1884 /* yes -> create new array: */
1885 STACK_0 = allocate_bit_vector(Atype_Bit,len); /* create bitvector */
1886 array3 = allocate_iarray(Atype_Bit,rank,Array_type_mdarray); /* create array */
1887 TheIarray(array3)->data = STACK_0; /* store data vector */
1888 TheIarray(array3)->totalsize = len;
1889 /* store dimensions: */
1890 if (rank > 0) {
1891 var uintC count;
1892 /* dimptr1 is the same as dimptr, but we have to re-init it
1893 becase of the GC-safety issues: the above allocations
1894 might have invalidated dimptr */
1895 var uintL* dimptr1 = &TheIarray(STACK_2)->dims[0];
1896 var uintL* dimptr2 = &TheIarray(array3)->dims[0];
1897 if (iarray_flags(TheIarray(STACK_2)) & bit(arrayflags_dispoffset_bit))
1898 dimptr1++;
1899 dotimespC(count,rank, { *dimptr2++ = *dimptr1++;});
1900 }
1901 STACK_0 = array3; /* store new array */
1902 } else if (eq(array3,T)) {
1903 STACK_0 = STACK_2; /* instead of T, use bit-array1 */
1904 } else {
1905 #ifndef TYPECODES
1906 if (!orecordp(STACK_0))
1907 goto error3;
1908 #endif
1909 switch (Array_type(STACK_0)) {
1910 case Array_type_mdarray: {
1911 var Iarray iarr3 = TheIarray(STACK_0);
1912 /* bit-array3 must have the element type BIT : */
1913 if ((iarray_flags(iarr3) & arrayflags_atype_mask) != Atype_Bit)
1914 goto error3;
1915 /* compare rank: */
1916 if (rank != iarray_rank(iarr3))
1917 goto error3;
1918 /* compare dimensions: */
1919 if (rank > 0) {
1920 var uintC count;
1921 var uintL* dimptr1 = dimptr;
1922 var uintL* dimptr2 = &iarr3->dims[0];
1923 if (iarray_flags(iarr3) & bit(arrayflags_dispoffset_bit))
1924 dimptr2++;
1925 dotimespC(count,rank, {
1926 if (*dimptr1++ != *dimptr2++)
1927 goto error3;
1928 });
1929 }
1930 }
1931 break;
1932 default:
1933 goto error3;
1934 }
1935 }
1936 }
1937 weiter: /* preparations are completed: */
1938 /* STACK_2 = bit-array1, STACK_1 = bit-array2, STACK_0 = bit-array3, */
1939 /* all of the same dimensions, with len bits. */
1940 if (len > 0) {
1941 var uintL index1 = 0; /* index in data vector of bit-array1 */
1942 var object array1 = /* data vector of bit-array1 */
1943 (simple_bit_vector_p(Atype_Bit,STACK_2)
1944 ? (object)STACK_2
1945 : iarray_displace_check(STACK_2,len,&index1));
1946 var uintL index2 = 0; /* index in data vector of bit-array2 */
1947 var object array2 = /* data vector of bit-array2 */
1948 (simple_bit_vector_p(Atype_Bit,STACK_1)
1949 ? (object)STACK_1
1950 : iarray_displace_check(STACK_1,len,&index2));
1951 var uintL index3 = 0; /* index in data vector of bit-array3 */
1952 var object array3 = /* data vector of bit-array3 */
1953 (simple_bit_vector_p(Atype_Bit,STACK_0)
1954 ? (object)STACK_0
1955 : iarray_displace_check(STACK_0,len,&index3));
1956 /* Go ahead: */
1957 bit_op(array1,index1,array2,index2,array3,index3,op,len);
1958 }
1959 /* done: */
1960 VALUES1(popSTACK()); /* bit-array3 is the value */
1961 skipSTACK(2);
1962 return;
1963 error2: { /* error-message for (at least) 2 arguments */
1964 var object array1 = STACK_2;
1965 var object array2 = STACK_1;
1966 pushSTACK(array2); pushSTACK(array1);
1967 pushSTACK(TheSubr(subr_self)->name);
1968 error(error_condition,
1969 GETTEXT("~S: The arguments ~S and ~S should be arrays of bits with the same dimensions"));
1970 }
1971 error3: { /* error-message for 3 arguments */
1972 var object array1 = STACK_2;
1973 var object array2 = STACK_1;
1974 /* array3 already in STACK_0 */
1975 pushSTACK(array2); pushSTACK(array1);
1976 pushSTACK(TheSubr(subr_self)->name);
1977 error(error_condition,
1978 GETTEXT("~S: The arguments ~S, ~S and ~S should be arrays of bits with the same dimensions"));
1979 }
1980 }
1981
1982 /* The operators for BIT-AND etc.: */
bitpack_and(uint_bitpack_t x,uint_bitpack_t y)1983 local uint_bitpack_t bitpack_and (uint_bitpack_t x, uint_bitpack_t y)
1984 { return x&y; }
bitpack_ior(uint_bitpack_t x,uint_bitpack_t y)1985 local uint_bitpack_t bitpack_ior (uint_bitpack_t x, uint_bitpack_t y)
1986 { return x|y; }
bitpack_xor(uint_bitpack_t x,uint_bitpack_t y)1987 local uint_bitpack_t bitpack_xor (uint_bitpack_t x, uint_bitpack_t y)
1988 { return x^y; }
bitpack_eqv(uint_bitpack_t x,uint_bitpack_t y)1989 local uint_bitpack_t bitpack_eqv (uint_bitpack_t x, uint_bitpack_t y)
1990 { return ~(x^y); }
bitpack_nand(uint_bitpack_t x,uint_bitpack_t y)1991 local uint_bitpack_t bitpack_nand (uint_bitpack_t x, uint_bitpack_t y)
1992 { return ~(x&y); }
bitpack_nor(uint_bitpack_t x,uint_bitpack_t y)1993 local uint_bitpack_t bitpack_nor (uint_bitpack_t x, uint_bitpack_t y)
1994 { return ~(x|y); }
bitpack_andc1(uint_bitpack_t x,uint_bitpack_t y)1995 local uint_bitpack_t bitpack_andc1 (uint_bitpack_t x, uint_bitpack_t y)
1996 { return (~x)&y; }
bitpack_andc2(uint_bitpack_t x,uint_bitpack_t y)1997 local uint_bitpack_t bitpack_andc2 (uint_bitpack_t x, uint_bitpack_t y)
1998 { return x&(~y); }
bitpack_orc1(uint_bitpack_t x,uint_bitpack_t y)1999 local uint_bitpack_t bitpack_orc1 (uint_bitpack_t x, uint_bitpack_t y)
2000 { return (~x)|y; }
bitpack_orc2(uint_bitpack_t x,uint_bitpack_t y)2001 local uint_bitpack_t bitpack_orc2 (uint_bitpack_t x, uint_bitpack_t y)
2002 { return x|(~y); }
bitpack_not(uint_bitpack_t x,uint_bitpack_t y)2003 local uint_bitpack_t bitpack_not (uint_bitpack_t x, uint_bitpack_t y)
2004 { unused(y); return ~x; }
2005
2006 LISPFUN(bit_and,seclass_default,2,1,norest,nokey,0,NIL)
2007 { /* (BIT-AND bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2008 return_Values bit_up(&bitpack_and);
2009 }
2010
2011 LISPFUN(bit_ior,seclass_default,2,1,norest,nokey,0,NIL)
2012 { /* (BIT-IOR bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2013 return_Values bit_up(&bitpack_ior);
2014 }
2015
2016 LISPFUN(bit_xor,seclass_default,2,1,norest,nokey,0,NIL)
2017 { /* (BIT-XOR bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2018 return_Values bit_up(&bitpack_xor);
2019 }
2020
2021 LISPFUN(bit_eqv,seclass_default,2,1,norest,nokey,0,NIL)
2022 { /* (BIT-EQV bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2023 return_Values bit_up(&bitpack_eqv);
2024 }
2025
2026 LISPFUN(bit_nand,seclass_default,2,1,norest,nokey,0,NIL)
2027 { /* (BIT-NAND bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2028 return_Values bit_up(&bitpack_nand);
2029 }
2030
2031 LISPFUN(bit_nor,seclass_default,2,1,norest,nokey,0,NIL)
2032 { /* (BIT-NOR bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2033 return_Values bit_up(&bitpack_nor);
2034 }
2035
2036 LISPFUN(bit_andc1,seclass_default,2,1,norest,nokey,0,NIL)
2037 { /* (BIT-ANDC1 bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2038 return_Values bit_up(&bitpack_andc1);
2039 }
2040
2041 LISPFUN(bit_andc2,seclass_default,2,1,norest,nokey,0,NIL)
2042 { /* (BIT-ANDC2 bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2043 return_Values bit_up(&bitpack_andc2);
2044 }
2045
2046 LISPFUN(bit_orc1,seclass_default,2,1,norest,nokey,0,NIL)
2047 { /* (BIT-ORC1 bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2048 return_Values bit_up(&bitpack_orc1);
2049 }
2050
2051 LISPFUN(bit_orc2,seclass_default,2,1,norest,nokey,0,NIL)
2052 { /* (BIT-ORC2 bit-array1 bit-array2 [result-bit-array]), CLTL p. 294 */
2053 return_Values bit_up(&bitpack_orc2);
2054 }
2055
2056 LISPFUN(bit_not,seclass_default,1,1,norest,nokey,0,NIL)
2057 { /* (BIT-NOT bit-array [result-bit-array]), CLTL p. 295 */
2058 /* double first argument (is ignored during the operation): */
2059 var object array3 = STACK_0;
2060 pushSTACK(array3);
2061 STACK_1 = STACK_2;
2062 return_Values bit_up(&bitpack_not);
2063 }
2064
2065 /* ======================================================================== */
2066 /* Polymorphic copying */
2067
2068 /* Function: Copies a slice of an array array1 into another array array2.
2069 elt_copy(dv1,index1,dv2,index2,count);
2070 > dv1: source storage-vector
2071 > index1: start index in dv1
2072 > dv2: destination storage-vector
2073 > index2: start index in dv2
2074 > count: number of elements to be copied, > 0
2075 can trigger GC - if dv1 and dv2 have different element types or
2076 if both are strings and dv1 is wider than dv2 */
2077 global /*maygc*/ void elt_copy (object dv1, uintL index1,
2078 object dv2, uintL index2, uintL count);
2079 local void elt_copy_Bit_Bit (object dv1, uintL index1, object dv2, uintL index2, uintL count);
2080 local void elt_copy_2Bit_2Bit (object dv1, uintL index1, object dv2, uintL index2, uintL count);
2081 local void elt_copy_4Bit_4Bit (object dv1, uintL index1, object dv2, uintL index2, uintL count);
elt_copy_T_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)2082 local void elt_copy_T_T (object dv1, uintL index1,
2083 object dv2, uintL index2, uintL count) {
2084 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
2085 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
2086 dotimespL(count,count, {
2087 *ptr2++ = *ptr1++;
2088 });
2089 }
elt_copy_Char_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)2090 local void elt_copy_Char_T (object dv1, uintL index1,
2091 object dv2, uintL index2, uintL count) {
2092 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
2093 SstringDispatch(dv1,X1, {
2094 var const cintX1* ptr1 = &((SstringX1)TheVarobject(dv1))->data[index1];
2095 dotimespL(count,count, {
2096 *ptr2++ = code_char(as_chart(*ptr1)); ptr1++;
2097 });
2098 });
2099 }
elt_copy_Bit_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)2100 local void elt_copy_Bit_T (object dv1, uintL index1,
2101 object dv2, uintL index2, uintL count) {
2102 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/8];
2103 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
2104 dotimespL(count,count, {
2105 *ptr2++ = fixnum((*ptr1 >> ((~index1)%8)) & (bit(1)-1));
2106 index1++;
2107 ptr1 += ((index1%8)==0);
2108 });
2109 }
elt_copy_2Bit_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)2110 local void elt_copy_2Bit_T (object dv1, uintL index1,
2111 object dv2, uintL index2, uintL count) {
2112 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/4];
2113 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
2114 dotimespL(count,count, {
2115 *ptr2++ = fixnum((*ptr1 >> (2*((~index1)%4))) & (bit(2)-1));
2116 index1++;
2117 ptr1 += ((index1%4)==0);
2118 });
2119 }
elt_copy_4Bit_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)2120 local void elt_copy_4Bit_T (object dv1, uintL index1,
2121 object dv2, uintL index2, uintL count) {
2122 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/2];
2123 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
2124 dotimespL(count,count, {
2125 *ptr2++ = fixnum((*ptr1 >> (4*((~index1)%2))) & (bit(4)-1));
2126 index1++;
2127 ptr1 += ((index1%2)==0);
2128 });
2129 }
elt_copy_8Bit_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)2130 local void elt_copy_8Bit_T (object dv1, uintL index1,
2131 object dv2, uintL index2, uintL count) {
2132 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1];
2133 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
2134 dotimespL(count,count, {
2135 *ptr2++ = fixnum(*ptr1++);
2136 });
2137 }
elt_copy_16Bit_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)2138 local void elt_copy_16Bit_T (object dv1, uintL index1,
2139 object dv2, uintL index2, uintL count) {
2140 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
2141 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
2142 dotimespL(count,count, {
2143 *ptr2++ = fixnum(*ptr1++);
2144 });
2145 }
elt_copy_32Bit_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)2146 local maygc void elt_copy_32Bit_T (object dv1, uintL index1,
2147 object dv2, uintL index2, uintL count) {
2148 #if (intLsize<=oint_data_len)
2149 /* UL_to_I(x) = fixnum(x), cannot trigger GC */
2150 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
2151 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
2152 dotimespL(count,count, {
2153 *ptr2++ = fixnum(*ptr1++);
2154 });
2155 #else
2156 pushSTACK(dv1);
2157 pushSTACK(dv2);
2158 dotimespL(count,count, {
2159 var object x = UL_to_I(((uint32*)&TheSbvector(STACK_1)->data[0])[index1++]);
2160 TheSvector(STACK_0)->data[index2++] = x;
2161 });
2162 skipSTACK(2);
2163 #endif
2164 }
elt_copy_T_Char(object dv1,uintL index1,object dv2,uintL index2,uintL count)2165 local maygc void elt_copy_T_Char (object dv1, uintL index1,
2166 object dv2, uintL index2, uintL count) {
2167 if (simple_nilarray_p(dv2)) error_nilarray_store();
2168 check_sstring_mutable(dv2);
2169 restart_it:
2170 SstringCase(dv2,{
2171 for (;;) {
2172 var object value = TheSvector(dv1)->data[index1++];
2173 if (!charp(value)) error_store(dv2,value);
2174 if (as_cint(char_code(value)) < cint8_limit) {
2175 TheS8string(dv2)->data[index2++] = as_cint(char_code(value));
2176 if (--count == 0)
2177 break;
2178 } else {
2179 dv2 = sstring_store(dv2,index2++,char_code(value));
2180 if (--count == 0)
2181 break;
2182 if (sstring_reallocatedp(TheSstring(dv2))) { /* reallocated? */
2183 dv2 = TheSistring(dv2)->data;
2184 goto restart_it;
2185 }
2186 }
2187 }
2188 },{
2189 for (;;) {
2190 var object value = TheSvector(dv1)->data[index1++];
2191 if (!charp(value)) error_store(dv2,value);
2192 if (as_cint(char_code(value)) < cint16_limit) {
2193 TheS16string(dv2)->data[index2++] = as_cint(char_code(value));
2194 if (--count == 0)
2195 break;
2196 } else {
2197 dv2 = sstring_store(dv2,index2++,char_code(value));
2198 if (--count == 0)
2199 break;
2200 if (sstring_reallocatedp(TheSstring(dv2))) { /* reallocated? */
2201 dv2 = TheSistring(dv2)->data;
2202 goto restart_it;
2203 }
2204 }
2205 }
2206 },{
2207 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
2208 var cint32* ptr2 = &TheS32string(dv2)->data[index2];
2209 dotimespL(count,count, {
2210 var object value = *ptr1++;
2211 if (!charp(value)) error_store(dv2,value);
2212 *ptr2++ = as_cint(char_code(value));
2213 });
2214 },{
2215 NOTREACHED;
2216 });
2217 }
elt_copy_Char_Char(object dv1,uintL index1,object dv2,uintL index2,uintL count)2218 local /*maygc*/ void elt_copy_Char_Char (object dv1, uintL index1,
2219 object dv2, uintL index2, uintL count) {
2220 GCTRIGGER_IF(sstring_eltype(TheSstring(dv1)) > sstring_eltype(TheSstring(dv2)),
2221 GCTRIGGER2(dv1,dv2));
2222 if (simple_nilarray_p(dv2)) error_nilarray_store();
2223 check_sstring_mutable(dv2);
2224 SstringCase(dv1,{
2225 var const cint8* ptr1 = &TheS8string(dv1)->data[index1];
2226 SstringCase(dv2,{
2227 /* Equivalent to copy_8bit_8bit, but we inline it here. */
2228 var cint8* ptr2 = &TheS8string(dv2)->data[index2];
2229 dotimespL(count,count, {
2230 *ptr2++ = *ptr1++;
2231 });
2232 },{
2233 /* Equivalent to copy_8bit_16bit, but we inline it here. */
2234 var cint16* ptr2 = &TheS16string(dv2)->data[index2];
2235 dotimespL(count,count, {
2236 *ptr2++ = *ptr1++;
2237 });
2238 },{
2239 /* Equivalent to copy_8bit_32bit, but we inline it here. */
2240 var cint32* ptr2 = &TheS32string(dv2)->data[index2];
2241 dotimespL(count,count, {
2242 *ptr2++ = *ptr1++;
2243 });
2244 },{
2245 NOTREACHED;
2246 });
2247 },{
2248 restart16:
2249 SstringCase(dv2,{
2250 pushSTACK(dv1);
2251 for (;;) {
2252 var chart ch = as_chart(TheS16string(dv1)->data[index1++]);
2253 if (as_cint(ch) < cint8_limit) {
2254 TheS8string(dv2)->data[index2++] = as_cint(ch);
2255 if (--count == 0)
2256 break;
2257 } else {
2258 dv2 = sstring_store(dv2,index2++,ch);
2259 if (--count == 0)
2260 break;
2261 if (sstring_reallocatedp(TheSstring(dv2))) { /* reallocated? */
2262 dv2 = TheSistring(dv2)->data;
2263 dv1 = popSTACK();
2264 goto restart16;
2265 }
2266 }
2267 }
2268 skipSTACK(1);
2269 },{
2270 /* Equivalent to copy_16bit_16bit, but we inline it here. */
2271 var const cint16* ptr1 = &TheS16string(dv1)->data[index1];
2272 var cint16* ptr2 = &TheS16string(dv2)->data[index2];
2273 dotimespL(count,count, {
2274 *ptr2++ = *ptr1++;
2275 });
2276 },{
2277 /* Equivalent to copy_16bit_32bit, but we inline it here. */
2278 var const cint16* ptr1 = &TheS16string(dv1)->data[index1];
2279 var cint32* ptr2 = &TheS32string(dv2)->data[index2];
2280 dotimespL(count,count, {
2281 *ptr2++ = *ptr1++;
2282 });
2283 },{
2284 NOTREACHED;
2285 });
2286 },{
2287 restart32:
2288 SstringCase(dv2,{
2289 pushSTACK(dv1);
2290 for (;;) {
2291 var chart ch = as_chart(TheS32string(dv1)->data[index1++]);
2292 if (as_cint(ch) < cint8_limit) {
2293 TheS8string(dv2)->data[index2++] = as_cint(ch);
2294 if (--count == 0)
2295 break;
2296 } else {
2297 dv2 = sstring_store(dv2,index2++,ch);
2298 if (--count == 0)
2299 break;
2300 if (sstring_reallocatedp(TheSstring(dv2))) { /* reallocated? */
2301 dv2 = TheSistring(dv2)->data;
2302 dv1 = popSTACK();
2303 goto restart32;
2304 }
2305 }
2306 }
2307 skipSTACK(1);
2308 },{
2309 pushSTACK(dv1);
2310 for (;;) {
2311 var chart ch = as_chart(TheS32string(dv1)->data[index1++]);
2312 if (as_cint(ch) < cint16_limit) {
2313 TheS16string(dv2)->data[index2++] = as_cint(ch);
2314 if (--count == 0)
2315 break;
2316 } else {
2317 dv2 = sstring_store(dv2,index2++,ch);
2318 if (--count == 0)
2319 break;
2320 if (sstring_reallocatedp(TheSstring(dv2))) { /* reallocated? */
2321 dv2 = TheSistring(dv2)->data;
2322 dv1 = popSTACK();
2323 goto restart32;
2324 }
2325 }
2326 }
2327 skipSTACK(1);
2328 },{
2329 /* Equivalent to copy_32bit_32bit, but we inline it here. */
2330 var const cint32* ptr1 = &TheS32string(dv1)->data[index1];
2331 var cint32* ptr2 = &TheS32string(dv2)->data[index2];
2332 dotimespL(count,count, {
2333 *ptr2++ = *ptr1++;
2334 });
2335 },{
2336 NOTREACHED;
2337 });
2338 },{
2339 error_nilarray_retrieve();
2340 });
2341 }
elt_copy_T_Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2342 local void elt_copy_T_Bit (object dv1, uintL index1,
2343 object dv2, uintL index2, uintL count) {
2344 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
2345 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/8];
2346 dotimespL(count,count, {
2347 var object value = *ptr1++;
2348 if (!uint1_p(value)) error_store(dv2,value);
2349 *ptr2 ^= (*ptr2 ^ (I_to_uint8(value) << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
2350 index2++;
2351 ptr2 += ((index2%8)==0);
2352 });
2353 }
2354 #define elt_copy_Bit_Bit(dv1,index1,dv2,index2,count) \
2355 bit_copy(dv1,index1,dv2,index2,count)
elt_copy_2Bit_Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2356 local void elt_copy_2Bit_Bit (object dv1, uintL index1,
2357 object dv2, uintL index2, uintL count) {
2358 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/4];
2359 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/8];
2360 dotimespL(count,count, {
2361 var uint8 value = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
2362 if (value >= bit(1)) error_store(dv2,fixnum(value));
2363 *ptr2 ^= (*ptr2 ^ (value << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
2364 index1++;
2365 ptr1 += ((index1%4)==0);
2366 index2++;
2367 ptr2 += ((index2%8)==0);
2368 });
2369 }
elt_copy_4Bit_Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2370 local void elt_copy_4Bit_Bit (object dv1, uintL index1,
2371 object dv2, uintL index2, uintL count) {
2372 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/2];
2373 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/8];
2374 dotimespL(count,count, {
2375 var uint8 value = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
2376 if (value >= bit(1)) error_store(dv2,fixnum(value));
2377 *ptr2 ^= (*ptr2 ^ (value << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
2378 index1++;
2379 ptr1 += ((index1%2)==0);
2380 index2++;
2381 ptr2 += ((index2%8)==0);
2382 });
2383 }
elt_copy_8Bit_Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2384 local void elt_copy_8Bit_Bit (object dv1, uintL index1,
2385 object dv2, uintL index2, uintL count) {
2386 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1];
2387 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/8];
2388 dotimespL(count,count, {
2389 var uint8 value = *ptr1++;
2390 if (value >= bit(1)) error_store(dv2,fixnum(value));
2391 *ptr2 ^= (*ptr2 ^ (value << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
2392 index2++;
2393 ptr2 += ((index2%8)==0);
2394 });
2395 }
elt_copy_16Bit_Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2396 local void elt_copy_16Bit_Bit (object dv1, uintL index1,
2397 object dv2, uintL index2, uintL count) {
2398 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
2399 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/8];
2400 dotimespL(count,count, {
2401 var uint16 value = *ptr1++;
2402 if (value >= bit(1)) error_store(dv2,fixnum(value));
2403 *ptr2 ^= (*ptr2 ^ (value << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
2404 index2++;
2405 ptr2 += ((index2%8)==0);
2406 });
2407 }
elt_copy_32Bit_Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2408 local void elt_copy_32Bit_Bit (object dv1, uintL index1,
2409 object dv2, uintL index2, uintL count) {
2410 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
2411 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/8];
2412 dotimespL(count,count, {
2413 var uint32 value = *ptr1++;
2414 if (value >= bit(1)) {
2415 pushSTACK(dv2);
2416 var object tmp = UL_to_I(value);
2417 error_store(popSTACK(),tmp);
2418 }
2419 *ptr2 ^= (*ptr2 ^ (value << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
2420 index2++;
2421 ptr2 += ((index2%8)==0);
2422 });
2423 }
elt_copy_T_2Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2424 local void elt_copy_T_2Bit (object dv1, uintL index1,
2425 object dv2, uintL index2, uintL count) {
2426 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
2427 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/4];
2428 dotimespL(count,count, {
2429 var object value = *ptr1++;
2430 if (!uint2_p(value)) error_store(dv2,value);
2431 *ptr2 ^= (*ptr2 ^ (I_to_uint8(value) << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
2432 index2++;
2433 ptr2 += ((index2%4)==0);
2434 });
2435 }
elt_copy_Bit_2Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2436 local void elt_copy_Bit_2Bit (object dv1, uintL index1,
2437 object dv2, uintL index2, uintL count) {
2438 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/8];
2439 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/4];
2440 dotimespL(count,count, {
2441 var uint8 value = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
2442 *ptr2 ^= (*ptr2 ^ (value << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
2443 index1++;
2444 ptr1 += ((index1%8)==0);
2445 index2++;
2446 ptr2 += ((index2%4)==0);
2447 });
2448 }
2449 #define elt_copy_2Bit_2Bit(dv1,index1,dv2,index2,count) \
2450 bit_copy(dv1,(index1)<<1,dv2,(index2)<<1,(count)<<1)
elt_copy_4Bit_2Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2451 local void elt_copy_4Bit_2Bit (object dv1, uintL index1,
2452 object dv2, uintL index2, uintL count) {
2453 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/2];
2454 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/4];
2455 dotimespL(count,count, {
2456 var uint8 value = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
2457 if (value >= bit(2)) error_store(dv2,fixnum(value));
2458 *ptr2 ^= (*ptr2 ^ (value << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
2459 index1++;
2460 ptr1 += ((index1%2)==0);
2461 index2++;
2462 ptr2 += ((index2%4)==0);
2463 });
2464 }
elt_copy_8Bit_2Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2465 local void elt_copy_8Bit_2Bit (object dv1, uintL index1,
2466 object dv2, uintL index2, uintL count) {
2467 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1];
2468 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/4];
2469 dotimespL(count,count, {
2470 var uint8 value = *ptr1++;
2471 if (value >= bit(2)) error_store(dv2,fixnum(value));
2472 *ptr2 ^= (*ptr2 ^ (value << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
2473 index2++;
2474 ptr2 += ((index2%4)==0);
2475 });
2476 }
elt_copy_16Bit_2Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2477 local void elt_copy_16Bit_2Bit (object dv1, uintL index1,
2478 object dv2, uintL index2, uintL count) {
2479 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
2480 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/4];
2481 dotimespL(count,count, {
2482 var uint16 value = *ptr1++;
2483 if (value >= bit(2)) error_store(dv2,fixnum(value));
2484 *ptr2 ^= (*ptr2 ^ (value << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
2485 index2++;
2486 ptr2 += ((index2%4)==0);
2487 });
2488 }
elt_copy_32Bit_2Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2489 local void elt_copy_32Bit_2Bit (object dv1, uintL index1,
2490 object dv2, uintL index2, uintL count) {
2491 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
2492 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/4];
2493 dotimespL(count,count, {
2494 var uint32 value = *ptr1++;
2495 if (value >= bit(2)) {
2496 pushSTACK(dv2);
2497 var object tmp = UL_to_I(value);
2498 error_store(popSTACK(),tmp);
2499 }
2500 *ptr2 ^= (*ptr2 ^ (value << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
2501 index2++;
2502 ptr2 += ((index2%4)==0);
2503 });
2504 }
elt_copy_T_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2505 local void elt_copy_T_4Bit (object dv1, uintL index1,
2506 object dv2, uintL index2, uintL count) {
2507 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
2508 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/2];
2509 dotimespL(count,count, {
2510 var object value = *ptr1++;
2511 if (!uint4_p(value)) error_store(dv2,value);
2512 *ptr2 ^= (*ptr2 ^ (I_to_uint8(value) << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
2513 index2++;
2514 ptr2 += ((index2%2)==0);
2515 });
2516 }
elt_copy_Bit_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2517 local void elt_copy_Bit_4Bit (object dv1, uintL index1,
2518 object dv2, uintL index2, uintL count) {
2519 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/8];
2520 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/2];
2521 dotimespL(count,count, {
2522 var uint8 value = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
2523 *ptr2 ^= (*ptr2 ^ (value << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
2524 index1++;
2525 ptr1 += ((index1%8)==0);
2526 index2++;
2527 ptr2 += ((index2%2)==0);
2528 });
2529 }
elt_copy_2Bit_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2530 local void elt_copy_2Bit_4Bit (object dv1, uintL index1,
2531 object dv2, uintL index2, uintL count) {
2532 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/4];
2533 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/2];
2534 dotimespL(count,count, {
2535 var uint8 value = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
2536 *ptr2 ^= (*ptr2 ^ (value << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
2537 index1++;
2538 ptr1 += ((index1%4)==0);
2539 index2++;
2540 ptr2 += ((index2%2)==0);
2541 });
2542 }
2543 #define elt_copy_4Bit_4Bit(dv1,index1,dv2,index2,count) \
2544 bit_copy(dv1,(index1)<<2,dv2,(index2)<<2,(count)<<2)
elt_copy_8Bit_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2545 local void elt_copy_8Bit_4Bit (object dv1, uintL index1,
2546 object dv2, uintL index2, uintL count) {
2547 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1];
2548 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/2];
2549 dotimespL(count,count, {
2550 var uint8 value = *ptr1++;
2551 if (value >= bit(4)) error_store(dv2,fixnum(value));
2552 *ptr2 ^= (*ptr2 ^ (value << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
2553 index2++;
2554 ptr2 += ((index2%2)==0);
2555 });
2556 }
elt_copy_16Bit_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2557 local void elt_copy_16Bit_4Bit (object dv1, uintL index1,
2558 object dv2, uintL index2, uintL count) {
2559 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
2560 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/2];
2561 dotimespL(count,count, {
2562 var uint16 value = *ptr1++;
2563 if (value >= bit(4)) error_store(dv2,fixnum(value));
2564 *ptr2 ^= (*ptr2 ^ (value << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
2565 index2++;
2566 ptr2 += ((index2%2)==0);
2567 });
2568 }
elt_copy_32Bit_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2569 local void elt_copy_32Bit_4Bit (object dv1, uintL index1,
2570 object dv2, uintL index2, uintL count) {
2571 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
2572 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/2];
2573 dotimespL(count,count, {
2574 var uint32 value = *ptr1++;
2575 if (value >= bit(4)) {
2576 pushSTACK(dv2);
2577 var object tmp = UL_to_I(value);
2578 error_store(popSTACK(),tmp);
2579 }
2580 *ptr2 ^= (*ptr2 ^ (value << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
2581 index2++;
2582 ptr2 += ((index2%2)==0);
2583 });
2584 }
elt_copy_T_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2585 local void elt_copy_T_8Bit (object dv1, uintL index1,
2586 object dv2, uintL index2, uintL count) {
2587 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
2588 var uint8* ptr2 = &TheSbvector(dv2)->data[index2];
2589 dotimespL(count,count, {
2590 var object value = *ptr1++;
2591 if (!uint8_p(value)) error_store(dv2,value);
2592 *ptr2++ = I_to_uint8(value);
2593 });
2594 }
elt_copy_Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2595 local void elt_copy_Bit_8Bit (object dv1, uintL index1,
2596 object dv2, uintL index2, uintL count) {
2597 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/8];
2598 var uint8* ptr2 = &TheSbvector(dv2)->data[index2];
2599 dotimespL(count,count, {
2600 *ptr2++ = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
2601 index1++;
2602 ptr1 += ((index1%8)==0);
2603 });
2604 }
elt_copy_2Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2605 local void elt_copy_2Bit_8Bit (object dv1, uintL index1,
2606 object dv2, uintL index2, uintL count) {
2607 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/4];
2608 var uint8* ptr2 = &TheSbvector(dv2)->data[index2];
2609 dotimespL(count,count, {
2610 *ptr2++ = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
2611 index1++;
2612 ptr1 += ((index1%4)==0);
2613 });
2614 }
elt_copy_4Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2615 local void elt_copy_4Bit_8Bit (object dv1, uintL index1,
2616 object dv2, uintL index2, uintL count) {
2617 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/2];
2618 var uint8* ptr2 = &TheSbvector(dv2)->data[index2];
2619 dotimespL(count,count, {
2620 *ptr2++ = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
2621 index1++;
2622 ptr1 += ((index1%2)==0);
2623 });
2624 }
elt_copy_8Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2625 local void elt_copy_8Bit_8Bit (object dv1, uintL index1,
2626 object dv2, uintL index2, uintL count) {
2627 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1];
2628 var uint8* ptr2 = &TheSbvector(dv2)->data[index2];
2629 dotimespL(count,count, {
2630 *ptr2++ = *ptr1++;
2631 });
2632 }
elt_copy_16Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2633 local void elt_copy_16Bit_8Bit (object dv1, uintL index1,
2634 object dv2, uintL index2, uintL count) {
2635 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
2636 var uint8* ptr2 = &TheSbvector(dv2)->data[index2];
2637 dotimespL(count,count, {
2638 var uint16 value = *ptr1++;
2639 if (value >= bit(8)) error_store(dv2,fixnum(value));
2640 *ptr2++ = value;
2641 });
2642 }
elt_copy_32Bit_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2643 local void elt_copy_32Bit_8Bit (object dv1, uintL index1,
2644 object dv2, uintL index2, uintL count) {
2645 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
2646 var uint8* ptr2 = &TheSbvector(dv2)->data[index2];
2647 dotimespL(count,count, {
2648 var uint32 value = *ptr1++;
2649 if (value >= bit(8)) {
2650 pushSTACK(dv2);
2651 var object tmp = UL_to_I(value);
2652 error_store(popSTACK(),tmp);
2653 }
2654 *ptr2++ = value;
2655 });
2656 }
elt_copy_T_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2657 local void elt_copy_T_16Bit (object dv1, uintL index1,
2658 object dv2, uintL index2, uintL count) {
2659 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
2660 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
2661 dotimespL(count,count, {
2662 var object value = *ptr1++;
2663 if (!uint16_p(value)) error_store(dv2,value);
2664 *ptr2++ = I_to_uint16(value);
2665 });
2666 }
elt_copy_Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2667 local void elt_copy_Bit_16Bit (object dv1, uintL index1,
2668 object dv2, uintL index2, uintL count) {
2669 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/8];
2670 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
2671 dotimespL(count,count, {
2672 *ptr2++ = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
2673 index1++;
2674 ptr1 += ((index1%8)==0);
2675 });
2676 }
elt_copy_2Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2677 local void elt_copy_2Bit_16Bit (object dv1, uintL index1,
2678 object dv2, uintL index2, uintL count) {
2679 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/4];
2680 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
2681 dotimespL(count,count, {
2682 *ptr2++ = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
2683 index1++;
2684 ptr1 += ((index1%4)==0);
2685 });
2686 }
elt_copy_4Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2687 local void elt_copy_4Bit_16Bit (object dv1, uintL index1,
2688 object dv2, uintL index2, uintL count) {
2689 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/2];
2690 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
2691 dotimespL(count,count, {
2692 *ptr2++ = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
2693 index1++;
2694 ptr1 += ((index1%2)==0);
2695 });
2696 }
elt_copy_8Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2697 local void elt_copy_8Bit_16Bit (object dv1, uintL index1,
2698 object dv2, uintL index2, uintL count) {
2699 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1];
2700 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
2701 dotimespL(count,count, {
2702 *ptr2++ = *ptr1++;
2703 });
2704 }
elt_copy_16Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2705 local void elt_copy_16Bit_16Bit (object dv1, uintL index1,
2706 object dv2, uintL index2, uintL count) {
2707 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
2708 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
2709 dotimespL(count,count, {
2710 *ptr2++ = *ptr1++;
2711 });
2712 }
elt_copy_32Bit_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2713 local void elt_copy_32Bit_16Bit (object dv1, uintL index1,
2714 object dv2, uintL index2, uintL count) {
2715 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
2716 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
2717 dotimespL(count,count, {
2718 var uint32 value = *ptr1++;
2719 if (value >= bit(16)) {
2720 pushSTACK(dv2);
2721 var object tmp = UL_to_I(value);
2722 error_store(popSTACK(),tmp);
2723 }
2724 *ptr2++ = value;
2725 });
2726 }
elt_copy_T_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2727 local void elt_copy_T_32Bit (object dv1, uintL index1,
2728 object dv2, uintL index2, uintL count) {
2729 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
2730 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
2731 dotimespL(count,count, {
2732 var object value = *ptr1++;
2733 if (!uint32_p(value)) error_store(dv2,value);
2734 *ptr2++ = I_to_uint32(value);
2735 });
2736 }
elt_copy_Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2737 local void elt_copy_Bit_32Bit (object dv1, uintL index1,
2738 object dv2, uintL index2, uintL count) {
2739 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/8];
2740 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
2741 dotimespL(count,count, {
2742 *ptr2++ = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
2743 index1++;
2744 ptr1 += ((index1%8)==0);
2745 });
2746 }
elt_copy_2Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2747 local void elt_copy_2Bit_32Bit (object dv1, uintL index1,
2748 object dv2, uintL index2, uintL count) {
2749 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/4];
2750 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
2751 dotimespL(count,count, {
2752 *ptr2++ = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
2753 index1++;
2754 ptr1 += ((index1%4)==0);
2755 });
2756 }
elt_copy_4Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2757 local void elt_copy_4Bit_32Bit (object dv1, uintL index1,
2758 object dv2, uintL index2, uintL count) {
2759 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/2];
2760 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
2761 dotimespL(count,count, {
2762 *ptr2++ = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
2763 index1++;
2764 ptr1 += ((index1%2)==0);
2765 });
2766 }
elt_copy_8Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2767 local void elt_copy_8Bit_32Bit (object dv1, uintL index1,
2768 object dv2, uintL index2, uintL count) {
2769 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1];
2770 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
2771 dotimespL(count,count, {
2772 *ptr2++ = *ptr1++;
2773 });
2774 }
elt_copy_16Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2775 local void elt_copy_16Bit_32Bit (object dv1, uintL index1,
2776 object dv2, uintL index2, uintL count) {
2777 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
2778 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
2779 dotimespL(count,count, {
2780 *ptr2++ = *ptr1++;
2781 });
2782 }
elt_copy_32Bit_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)2783 local void elt_copy_32Bit_32Bit (object dv1, uintL index1,
2784 object dv2, uintL index2, uintL count) {
2785 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
2786 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
2787 dotimespL(count,count, {
2788 *ptr2++ = *ptr1++;
2789 });
2790 }
elt_copy(object dv1,uintL index1,object dv2,uintL index2,uintL count)2791 global /*maygc*/ void elt_copy (object dv1, uintL index1,
2792 object dv2, uintL index2, uintL count) {
2793 GCTRIGGER_IF(Array_type(dv1) != Array_type(dv2)
2794 || (simple_string_p(dv1) && simple_string_p(dv2)
2795 && sstring_eltype(TheSstring(dv1)) > sstring_eltype(TheSstring(dv2))),
2796 GCTRIGGER2(dv1,dv2));
2797 switch (Array_type(dv1)) {
2798 case Array_type_svector: /* Simple-Vector */
2799 switch (Array_type(dv2)) {
2800 case Array_type_svector: /* Simple-Vector */
2801 elt_copy_T_T(dv1,index1,dv2,index2,count); return;
2802 case Array_type_sbvector: /* Simple-Bit-Vector */
2803 elt_copy_T_Bit(dv1,index1,dv2,index2,count); return;
2804 case Array_type_sb2vector:
2805 elt_copy_T_2Bit(dv1,index1,dv2,index2,count); return;
2806 case Array_type_sb4vector:
2807 elt_copy_T_4Bit(dv1,index1,dv2,index2,count); return;
2808 case Array_type_sb8vector:
2809 elt_copy_T_8Bit(dv1,index1,dv2,index2,count); return;
2810 case Array_type_sb16vector:
2811 elt_copy_T_16Bit(dv1,index1,dv2,index2,count); return;
2812 case Array_type_sb32vector:
2813 elt_copy_T_32Bit(dv1,index1,dv2,index2,count); return;
2814 case Array_type_sstring: /* Simple-String */
2815 elt_copy_T_Char(dv1,index1,dv2,index2,count); return;
2816 case Array_type_snilvector: /* (VECTOR NIL) */
2817 break; /* error_store because count > 0 */
2818 default: NOTREACHED;
2819 }
2820 break;
2821 case Array_type_sbvector: /* Simple-Bit-Vector */
2822 switch (Array_type(dv2)) {
2823 case Array_type_svector: /* Simple-Vector */
2824 elt_copy_Bit_T(dv1,index1,dv2,index2,count); return;
2825 case Array_type_sbvector: /* Simple-Bit-Vector */
2826 elt_copy_Bit_Bit(dv1,index1,dv2,index2,count); return;
2827 case Array_type_sb2vector:
2828 elt_copy_Bit_2Bit(dv1,index1,dv2,index2,count); return;
2829 case Array_type_sb4vector:
2830 elt_copy_Bit_4Bit(dv1,index1,dv2,index2,count); return;
2831 case Array_type_sb8vector:
2832 elt_copy_Bit_8Bit(dv1,index1,dv2,index2,count); return;
2833 case Array_type_sb16vector:
2834 elt_copy_Bit_16Bit(dv1,index1,dv2,index2,count); return;
2835 case Array_type_sb32vector:
2836 elt_copy_Bit_32Bit(dv1,index1,dv2,index2,count); return;
2837 case Array_type_sstring: /* Simple-String */
2838 case Array_type_snilvector: /* (VECTOR NIL) */
2839 break; /* error_store because count > 0 */
2840 default: NOTREACHED;
2841 }
2842 break;
2843 case Array_type_sb2vector:
2844 switch (Array_type(dv2)) {
2845 case Array_type_svector: /* Simple-Vector */
2846 elt_copy_2Bit_T(dv1,index1,dv2,index2,count); return;
2847 case Array_type_sbvector: /* Simple-Bit-Vector */
2848 elt_copy_2Bit_Bit(dv1,index1,dv2,index2,count); return;
2849 case Array_type_sb2vector:
2850 elt_copy_2Bit_2Bit(dv1,index1,dv2,index2,count); return;
2851 case Array_type_sb4vector:
2852 elt_copy_2Bit_4Bit(dv1,index1,dv2,index2,count); return;
2853 case Array_type_sb8vector:
2854 elt_copy_2Bit_8Bit(dv1,index1,dv2,index2,count); return;
2855 case Array_type_sb16vector:
2856 elt_copy_2Bit_16Bit(dv1,index1,dv2,index2,count); return;
2857 case Array_type_sb32vector:
2858 elt_copy_2Bit_32Bit(dv1,index1,dv2,index2,count); return;
2859 case Array_type_sstring: /* Simple-String */
2860 case Array_type_snilvector: /* (VECTOR NIL) */
2861 break; /* error_store because count > 0 */
2862 default: NOTREACHED;
2863 }
2864 break;
2865 case Array_type_sb4vector:
2866 switch (Array_type(dv2)) {
2867 case Array_type_svector: /* Simple-Vector */
2868 elt_copy_4Bit_T(dv1,index1,dv2,index2,count); return;
2869 case Array_type_sbvector: /* Simple-Bit-Vector */
2870 elt_copy_4Bit_Bit(dv1,index1,dv2,index2,count); return;
2871 case Array_type_sb2vector:
2872 elt_copy_4Bit_2Bit(dv1,index1,dv2,index2,count); return;
2873 case Array_type_sb4vector:
2874 elt_copy_4Bit_4Bit(dv1,index1,dv2,index2,count); return;
2875 case Array_type_sb8vector:
2876 elt_copy_4Bit_8Bit(dv1,index1,dv2,index2,count); return;
2877 case Array_type_sb16vector:
2878 elt_copy_4Bit_16Bit(dv1,index1,dv2,index2,count); return;
2879 case Array_type_sb32vector:
2880 elt_copy_4Bit_32Bit(dv1,index1,dv2,index2,count); return;
2881 case Array_type_sstring: /* Simple-String */
2882 case Array_type_snilvector: /* (VECTOR NIL) */
2883 break; /* error_store because count > 0 */
2884 default: NOTREACHED;
2885 }
2886 break;
2887 case Array_type_sb8vector:
2888 switch (Array_type(dv2)) {
2889 case Array_type_svector: /* Simple-Vector */
2890 elt_copy_8Bit_T(dv1,index1,dv2,index2,count); return;
2891 case Array_type_sbvector: /* Simple-Bit-Vector */
2892 elt_copy_8Bit_Bit(dv1,index1,dv2,index2,count); return;
2893 case Array_type_sb2vector:
2894 elt_copy_8Bit_2Bit(dv1,index1,dv2,index2,count); return;
2895 case Array_type_sb4vector:
2896 elt_copy_8Bit_4Bit(dv1,index1,dv2,index2,count); return;
2897 case Array_type_sb8vector:
2898 elt_copy_8Bit_8Bit(dv1,index1,dv2,index2,count); return;
2899 case Array_type_sb16vector:
2900 elt_copy_8Bit_16Bit(dv1,index1,dv2,index2,count); return;
2901 case Array_type_sb32vector:
2902 elt_copy_8Bit_32Bit(dv1,index1,dv2,index2,count); return;
2903 case Array_type_sstring: /* Simple-String */
2904 case Array_type_snilvector: /* (VECTOR NIL) */
2905 break; /* error_store because count > 0 */
2906 default: NOTREACHED;
2907 }
2908 break;
2909 case Array_type_sb16vector:
2910 switch (Array_type(dv2)) {
2911 case Array_type_svector: /* Simple-Vector */
2912 elt_copy_16Bit_T(dv1,index1,dv2,index2,count); return;
2913 case Array_type_sbvector: /* Simple-Bit-Vector */
2914 elt_copy_16Bit_Bit(dv1,index1,dv2,index2,count); return;
2915 case Array_type_sb2vector:
2916 elt_copy_16Bit_2Bit(dv1,index1,dv2,index2,count); return;
2917 case Array_type_sb4vector:
2918 elt_copy_16Bit_4Bit(dv1,index1,dv2,index2,count); return;
2919 case Array_type_sb8vector:
2920 elt_copy_16Bit_8Bit(dv1,index1,dv2,index2,count); return;
2921 case Array_type_sb16vector:
2922 elt_copy_16Bit_16Bit(dv1,index1,dv2,index2,count); return;
2923 case Array_type_sb32vector:
2924 elt_copy_16Bit_32Bit(dv1,index1,dv2,index2,count); return;
2925 case Array_type_sstring: /* Simple-String */
2926 case Array_type_snilvector: /* (VECTOR NIL) */
2927 break; /* error_store because count > 0 */
2928 default: NOTREACHED;
2929 }
2930 break;
2931 case Array_type_sb32vector:
2932 switch (Array_type(dv2)) {
2933 case Array_type_svector: /* Simple-Vector */
2934 elt_copy_32Bit_T(dv1,index1,dv2,index2,count); return;
2935 case Array_type_sbvector: /* Simple-Bit-Vector */
2936 elt_copy_32Bit_Bit(dv1,index1,dv2,index2,count); return;
2937 case Array_type_sb2vector:
2938 elt_copy_32Bit_2Bit(dv1,index1,dv2,index2,count); return;
2939 case Array_type_sb4vector:
2940 elt_copy_32Bit_4Bit(dv1,index1,dv2,index2,count); return;
2941 case Array_type_sb8vector:
2942 elt_copy_32Bit_8Bit(dv1,index1,dv2,index2,count); return;
2943 case Array_type_sb16vector:
2944 elt_copy_32Bit_16Bit(dv1,index1,dv2,index2,count); return;
2945 case Array_type_sb32vector:
2946 elt_copy_32Bit_32Bit(dv1,index1,dv2,index2,count); return;
2947 case Array_type_sstring: /* Simple-String */
2948 case Array_type_snilvector: /* (VECTOR NIL) */
2949 break; /* error_store because count > 0 */
2950 default: NOTREACHED;
2951 }
2952 break;
2953 case Array_type_sstring: /* Simple-String */
2954 switch (Array_type(dv2)) {
2955 case Array_type_svector: /* Simple-Vector */
2956 elt_copy_Char_T(dv1,index1,dv2,index2,count); return;
2957 case Array_type_sbvector: /* Simple-Bit-Vector */
2958 case Array_type_sb2vector:
2959 case Array_type_sb4vector:
2960 case Array_type_sb8vector:
2961 case Array_type_sb16vector:
2962 case Array_type_sb32vector:
2963 case Array_type_snilvector: /* (VECTOR NIL) */
2964 break; /* error_store because count > 0 */
2965 case Array_type_sstring: /* Simple-String */
2966 elt_copy_Char_Char(dv1,index1,dv2,index2,count); return;
2967 default: NOTREACHED;
2968 }
2969 break;
2970 case Array_type_snilvector: /* (VECTOR NIL) */
2971 switch (Array_type(dv2)) {
2972 case Array_type_snilvector:
2973 return;
2974 case Array_type_svector: /* Simple-Vector */
2975 case Array_type_sbvector: /* Simple-Bit-Vector */
2976 case Array_type_sb2vector:
2977 case Array_type_sb4vector:
2978 case Array_type_sb8vector:
2979 case Array_type_sb16vector:
2980 case Array_type_sb32vector:
2981 case Array_type_sstring: /* Simple-String */
2982 error_nilarray_retrieve();
2983 default: NOTREACHED;
2984 }
2985 default: NOTREACHED;
2986 }
2987 pushSTACK(dv2);
2988 var object elt1 = storagevector_aref(dv1,index1);
2989 error_store(popSTACK(),elt1);
2990 }
2991
2992 /* Function: Copies a slice of an array array1 into another array array2 of
2993 the same element type. Handles overlapping arrays correctly.
2994 elt_move(dv1,index1,dv2,index2,count);
2995 > dv1: source storage-vector
2996 > index1: start index in dv1
2997 > dv2: destination storage-vector
2998 > index2: start index in dv2
2999 > count: number of elements to be copied, > 0
3000 can trigger GC - if both are strings and dv1 is wider than dv2 */
3001 global /*maygc*/ void elt_move (object dv1, uintL index1,
3002 object dv2, uintL index2, uintL count);
elt_move_T(object dv1,uintL index1,object dv2,uintL index2,uintL count)3003 local void elt_move_T (object dv1, uintL index1,
3004 object dv2, uintL index2, uintL count) {
3005 if (eq(dv1,dv2) && index1 < index2 && index2 < index1+count) {
3006 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1+count];
3007 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2+count];
3008 dotimespL(count,count, {
3009 *--ptr2 = *--ptr1;
3010 });
3011 } else {
3012 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
3013 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
3014 dotimespL(count,count, {
3015 *ptr2++ = *ptr1++;
3016 });
3017 }
3018 }
elt_move_Char(object dv1,uintL index1,object dv2,uintL index2,uintL count)3019 local /*maygc*/ void elt_move_Char (object dv1, uintL index1,
3020 object dv2, uintL index2, uintL count) {
3021 GCTRIGGER_IF(sstring_eltype(TheSstring(dv1)) > sstring_eltype(TheSstring(dv2)),
3022 GCTRIGGER2(dv1,dv2));
3023 if (simple_nilarray_p(dv2)) error_nilarray_store();
3024 check_sstring_mutable(dv2);
3025 if (eq(dv1,dv2) && index1 < index2 && index2 < index1+count) {
3026 SstringDispatch(dv1,X, {
3027 var const cintX* ptr1 = &((SstringX)TheVarobject(dv1))->data[index1+count];
3028 var cintX* ptr2 = &((SstringX)TheVarobject(dv2))->data[index2+count];
3029 dotimespL(count,count, {
3030 *--ptr2 = *--ptr1;
3031 });
3032 });
3033 } else {
3034 /* Too large to inline. */
3035 elt_copy_Char_Char(dv1,index1,dv2,index2,count);
3036 }
3037 }
elt_move_Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)3038 local void elt_move_Bit (object dv1, uintL index1,
3039 object dv2, uintL index2, uintL count) {
3040 if (eq(dv1,dv2) && index1 < index2+64 && index2 < index1+count+64) {
3041 if (index1 < index2 && index2 < index1+count) {
3042 index1 += count;
3043 index2 += count;
3044 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/8];
3045 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/8];
3046 dotimespL(count,count, {
3047 ptr1 -= ((index1%8)==0);
3048 index1--;
3049 ptr2 -= ((index2%8)==0);
3050 index2--;
3051 var uint8 value = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
3052 *ptr2 ^= (*ptr2 ^ (value << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
3053 });
3054 } else {
3055 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/8];
3056 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/8];
3057 dotimespL(count,count, {
3058 var uint8 value = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
3059 *ptr2 ^= (*ptr2 ^ (value << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
3060 index1++;
3061 ptr1 += ((index1%8)==0);
3062 index2++;
3063 ptr2 += ((index2%8)==0);
3064 });
3065 }
3066 } else
3067 elt_copy_Bit_Bit(dv1,index1,dv2,index2,count);
3068 }
elt_move_2Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)3069 local void elt_move_2Bit (object dv1, uintL index1,
3070 object dv2, uintL index2, uintL count) {
3071 if (eq(dv1,dv2) && index1 < index2+32 && index2 < index1+count+32) {
3072 if (index1 < index2 && index2 < index1+count) {
3073 index1 += count;
3074 index2 += count;
3075 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/4];
3076 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/4];
3077 dotimespL(count,count, {
3078 ptr1 -= ((index1%4)==0);
3079 index1--;
3080 ptr2 -= ((index2%4)==0);
3081 index2--;
3082 var uint8 value = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
3083 *ptr2 ^= (*ptr2 ^ (value << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
3084 });
3085 } else {
3086 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/4];
3087 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/4];
3088 dotimespL(count,count, {
3089 var uint8 value = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
3090 *ptr2 ^= (*ptr2 ^ (value << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
3091 index1++;
3092 ptr1 += ((index1%4)==0);
3093 index2++;
3094 ptr2 += ((index2%4)==0);
3095 });
3096 }
3097 } else
3098 elt_copy_2Bit_2Bit(dv1,index1,dv2,index2,count);
3099 }
elt_move_4Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)3100 local void elt_move_4Bit (object dv1, uintL index1,
3101 object dv2, uintL index2, uintL count) {
3102 if (eq(dv1,dv2) && index1 < index2+16 && index2 < index1+count+16) {
3103 if (index1 < index2 && index2 < index1+count) {
3104 index1 += count;
3105 index2 += count;
3106 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/2];
3107 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/2];
3108 dotimespL(count,count, {
3109 ptr1 -= ((index1%2)==0);
3110 index1--;
3111 ptr2 -= ((index2%2)==0);
3112 index2--;
3113 var uint8 value = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
3114 *ptr2 ^= (*ptr2 ^ (value << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
3115 });
3116 } else {
3117 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/2];
3118 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/2];
3119 dotimespL(count,count, {
3120 var uint8 value = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
3121 *ptr2 ^= (*ptr2 ^ (value << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
3122 index1++;
3123 ptr1 += ((index1%2)==0);
3124 index2++;
3125 ptr2 += ((index2%2)==0);
3126 });
3127 }
3128 } else
3129 elt_copy_4Bit_4Bit(dv1,index1,dv2,index2,count);
3130 }
elt_move_8Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)3131 local void elt_move_8Bit (object dv1, uintL index1,
3132 object dv2, uintL index2, uintL count) {
3133 if (eq(dv1,dv2) && index1 < index2 && index2 < index1+count) {
3134 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1+count];
3135 var uint8* ptr2 = &TheSbvector(dv2)->data[index2+count];
3136 dotimespL(count,count, {
3137 *--ptr2 = *--ptr1;
3138 });
3139 } else {
3140 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1];
3141 var uint8* ptr2 = &TheSbvector(dv2)->data[index2];
3142 dotimespL(count,count, {
3143 *ptr2++ = *ptr1++;
3144 });
3145 }
3146 }
elt_move_16Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)3147 local void elt_move_16Bit (object dv1, uintL index1,
3148 object dv2, uintL index2, uintL count) {
3149 if (eq(dv1,dv2) && index1 < index2 && index2 < index1+count) {
3150 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1+count];
3151 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2+count];
3152 dotimespL(count,count, {
3153 *--ptr2 = *--ptr1;
3154 });
3155 } else {
3156 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
3157 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
3158 dotimespL(count,count, {
3159 *ptr2++ = *ptr1++;
3160 });
3161 }
3162 }
elt_move_32Bit(object dv1,uintL index1,object dv2,uintL index2,uintL count)3163 local void elt_move_32Bit (object dv1, uintL index1,
3164 object dv2, uintL index2, uintL count) {
3165 if (eq(dv1,dv2) && index1 < index2 && index2 < index1+count) {
3166 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1+count];
3167 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2+count];
3168 dotimespL(count,count, {
3169 *--ptr2 = *--ptr1;
3170 });
3171 } else {
3172 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
3173 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
3174 dotimespL(count,count, {
3175 *ptr2++ = *ptr1++;
3176 });
3177 }
3178 }
elt_move(object dv1,uintL index1,object dv2,uintL index2,uintL count)3179 global /*maygc*/ void elt_move (object dv1, uintL index1,
3180 object dv2, uintL index2, uintL count) {
3181 GCTRIGGER_IF(simple_string_p(dv1) && simple_string_p(dv2)
3182 && sstring_eltype(TheSstring(dv1)) > sstring_eltype(TheSstring(dv2)),
3183 GCTRIGGER2(dv1,dv2));
3184 ASSERT(Array_type(dv1) == Array_type(dv2));
3185 switch (Array_type(dv1)) {
3186 case Array_type_svector: /* Simple-Vector */
3187 elt_move_T(dv1,index1,dv2,index2,count);
3188 break;
3189 case Array_type_sbvector: /* Simple-Bit-Vector */
3190 elt_move_Bit(dv1,index1,dv2,index2,count);
3191 break;
3192 case Array_type_sb2vector:
3193 elt_move_2Bit(dv1,index1,dv2,index2,count);
3194 break;
3195 case Array_type_sb4vector:
3196 elt_move_4Bit(dv1,index1,dv2,index2,count);
3197 break;
3198 case Array_type_sb8vector:
3199 elt_move_8Bit(dv1,index1,dv2,index2,count);
3200 break;
3201 case Array_type_sb16vector:
3202 elt_move_16Bit(dv1,index1,dv2,index2,count);
3203 break;
3204 case Array_type_sb32vector:
3205 elt_move_32Bit(dv1,index1,dv2,index2,count);
3206 break;
3207 case Array_type_sstring: /* Simple-String */
3208 elt_move_Char(dv1,index1,dv2,index2,count);
3209 break;
3210 case Array_type_snilvector:
3211 return;
3212 default: NOTREACHED;
3213 }
3214 }
3215
3216 /* Function: Fills a slice of an array with an element.
3217 elt_fill(dv,index,count,element)
3218 > dv: destination storage-vector
3219 > index: start index in dv
3220 > count: number of elements to be filled
3221 < result: true if element does not fit, false when done
3222 can trigger GC */
elt_fill(object dv,uintL index,uintL count,object element)3223 global maygc bool elt_fill (object dv, uintL index, uintL count, object element) {
3224 #define SIMPLE_FILL(p,c,e) dotimespL(c,c, { *p++ = e; })
3225 switch (Array_type(dv)) {
3226 case Array_type_svector: /* Simple-Vector */
3227 if (count > 0) {
3228 var gcv_object_t* ptr = &TheSvector(dv)->data[index];
3229 SIMPLE_FILL(ptr,count,element);
3230 }
3231 break;
3232 #if 0 /* unoptimized */
3233 case Array_type_sbvector: /* Simple-Bit-Vector */
3234 if (!uint1_p(element)) return true;
3235 if (count > 0) {
3236 var uint8 x = I_to_uint8(element);
3237 var uint8* ptr = &TheSbvector(dv)->data[index/8];
3238 dotimespL(count,count, {
3239 *ptr ^= (*ptr ^ (x << ((~index)%8))) & ((bit(1)-1) << ((~index)%8));
3240 index++;
3241 ptr += ((index%8)==0);
3242 });
3243 }
3244 break;
3245 case Array_type_sb2vector:
3246 if (!uint2_p(element)) return true;
3247 if (count > 0) {
3248 var uint8 x = I_to_uint8(element);
3249 var uint8* ptr = &TheSbvector(dv)->data[index/4];
3250 dotimespL(count,count, {
3251 *ptr ^= (*ptr ^ (x << (2*((~index)%4)))) & ((bit(2)-1) << (2*((~index)%4)));
3252 index++;
3253 ptr += ((index%4)==0);
3254 });
3255 }
3256 break;
3257 case Array_type_sb4vector:
3258 if (!uint4_p(element)) return true;
3259 if (count > 0) {
3260 var uint8 x = I_to_uint8(element);
3261 var uint8* ptr = &TheSbvector(dv)->data[index/2];
3262 dotimespL(count,count, {
3263 *ptr ^= (*ptr ^ (x << (4*((~index)%2)))) & ((bit(4)-1) << (4*((~index)%2)));
3264 index++;
3265 ptr += ((index%2)==0);
3266 });
3267 }
3268 break;
3269 case Array_type_sb8vector:
3270 if (!uint8_p(element)) return true;
3271 if (count > 0) {
3272 var uint8 x = I_to_uint8(element);
3273 var uint8* ptr = &TheSbvector(dv)->data[index];
3274 SIMPLE_FILL(ptr,count,x);
3275 }
3276 break;
3277 case Array_type_sb16vector:
3278 if (!uint16_p(element)) return true;
3279 if (count > 0) {
3280 var uint16 x = I_to_uint16(element);
3281 var uint16* ptr = &((uint16*)&TheSbvector(dv)->data[0])[index];
3282 SIMPLE_FILL(ptr,count,x);
3283 }
3284 break;
3285 case Array_type_sb32vector:
3286 if (!uint32_p(element)) return true;
3287 if (count > 0) {
3288 var uint32 x = I_to_uint32(element);
3289 var uint32* ptr = &((uint32*)&TheSbvector(dv)->data[0])[index];
3290 SIMPLE_FILL(ptr,count,x);
3291 }
3292 break;
3293 #else /* optimized: use 32-bit accesses where possible */
3294 var uint32 x;
3295 case Array_type_sbvector: /* Simple-Bit-Vector */
3296 if (!uint1_p(element)) return true;
3297 if (count == 0) break;
3298 x = I_to_uint8(element);
3299 x |= x << 1;
3300 x |= x << 2;
3301 x |= x << 4;
3302 if (index & 7) {
3303 var uint8* ptr = &TheSbvector(dv)->data[index/8];
3304 var uintL i = 8-(index&7);
3305 if (i >= count) {
3306 *ptr ^= (*ptr ^ x) & (bit(i)-bit(i-count));
3307 break;
3308 }
3309 *ptr ^= (*ptr ^ x) & (bit(i)-1);
3310 count -= i;
3311 index += i;
3312 }
3313 index = index/8;
3314 if (count & 7) {
3315 var uint8* ptr = &TheSbvector(dv)->data[index+count/8];
3316 *ptr ^= (*ptr ^ x) & (bit(8)-bit(8-(count&7)));
3317 count = count & ~7;
3318 if (count == 0) break;
3319 }
3320 count = count/8;
3321 goto store8;
3322 case Array_type_sb2vector:
3323 if (!uint2_p(element)) return true;
3324 if (count == 0) break;
3325 x = I_to_uint8(element);
3326 x |= x << 2;
3327 x |= x << 4;
3328 if (index & 3) {
3329 var uint8* ptr = &TheSbvector(dv)->data[index/4];
3330 var uintL i = 4-(index&3);
3331 if (i >= count) {
3332 *ptr ^= (*ptr ^ x) & (bit(2*i)-bit(2*(i-count)));
3333 break;
3334 }
3335 *ptr ^= (*ptr ^ x) & (bit(2*i)-1);
3336 count -= i;
3337 index += i;
3338 }
3339 index = index/4;
3340 if (count & 3) {
3341 var uint8* ptr = &TheSbvector(dv)->data[index+count/4];
3342 *ptr ^= (*ptr ^ x) & (bit(8)-bit(8-2*(count&3)));
3343 count = count & ~3;
3344 if (count == 0) break;
3345 }
3346 count = count/4;
3347 goto store8;
3348 case Array_type_sb4vector:
3349 if (!uint4_p(element)) return true;
3350 if (count == 0) break;
3351 x = I_to_uint8(element);
3352 x |= x << 4;
3353 if (index & 1) {
3354 var uint8* ptr = &TheSbvector(dv)->data[index/2];
3355 *ptr ^= (*ptr ^ x) & (bit(4)-1);
3356 index++;
3357 if (--count == 0) break;
3358 }
3359 index = index/2;
3360 if (count & 1) {
3361 var uint8* ptr = &TheSbvector(dv)->data[index+count/2];
3362 *ptr ^= (*ptr ^ x) & (bit(8)-bit(4));
3363 if (--count == 0) break;
3364 }
3365 count = count/2;
3366 goto store8;
3367 case Array_type_sb8vector:
3368 if (!uint8_p(element)) return true;
3369 if (count == 0) break;
3370 x = I_to_uint8(element);
3371 store8:
3372 if (index & 1) {
3373 TheSbvector(dv)->data[index] = x;
3374 index++;
3375 if (--count == 0) break;
3376 }
3377 if (count & 1) {
3378 TheSbvector(dv)->data[index+count-1] = x;
3379 if (--count == 0) break;
3380 }
3381 count = count/2;
3382 index = index/2;
3383 x |= x << 8;
3384 goto store16;
3385 case Array_type_sb16vector:
3386 if (!uint16_p(element)) return true;
3387 if (count == 0) break;
3388 x = I_to_uint16(element);
3389 store16:
3390 if (index & 1) {
3391 ((uint16*)&TheSbvector(dv)->data[0])[index] = x;
3392 index++;
3393 if (--count == 0) break;
3394 }
3395 if (count & 1) {
3396 ((uint16*)&TheSbvector(dv)->data[0])[index+count-1] = x;
3397 if (--count == 0) break;
3398 }
3399 count = count/2;
3400 index = index/2;
3401 x |= x << 16;
3402 goto store32;
3403 case Array_type_sb32vector:
3404 if (!uint32_p(element)) return true;
3405 if (count == 0) break;
3406 x = I_to_uint32(element);
3407 store32:
3408 {
3409 var uint32* ptr = &((uint32*)&TheSbvector(dv)->data[0])[index];
3410 SIMPLE_FILL(ptr,count,x);
3411 }
3412 break;
3413 #endif
3414 case Array_type_sstring: /* Simple-String */
3415 if (!charp(element)) return true;
3416 if (count > 0) {
3417 sstring_un_realloc(dv);
3418 check_sstring_mutable(dv);
3419 var chart c = char_code(element);
3420 /* The first store can cause reallocation, the remaining ones cannot. */
3421 dv = sstring_store(dv,index++,c);
3422 sstring_un_realloc1(dv); /* reallocated? */
3423 if (--count > 0) {
3424 SstringDispatch(dv,X, {
3425 var cintX* ptr = &((SstringX)TheVarobject(dv))->data[index];
3426 SIMPLE_FILL(ptr,count,as_cint(c));
3427 });
3428 }
3429 }
3430 break;
3431 case Array_type_snilvector: /* (VECTOR NIL) */
3432 return true;
3433 default: NOTREACHED;
3434 }
3435 return false;
3436 #undef SIMPLE_FILL
3437 }
3438
3439 /* Function: Reverses a slice of an array, copying it into another array
3440 of the same element type.
3441 elt_reverse(dv1,index1,dv2,index2,count);
3442 > dv1: source storage-vector
3443 > index1: start index in dv1
3444 > dv2: destination storage-vector
3445 > index2: start index in dv2
3446 > count: number of elements to be copied, > 0
3447 can trigger GC */
elt_reverse(object dv1,uintL index1,object dv2,uintL index2,uintL count)3448 global maygc void elt_reverse (object dv1, uintL index1,
3449 object dv2, uintL index2, uintL count) {
3450 #define SIMPLE_REVERSE(p1,p2,c) dotimespL(c,c, { *p2-- = *p1++; })
3451 index2 += count-1;
3452 switch (Array_type(dv1)) {
3453 case Array_type_svector: { /* Simple-Vector */
3454 var const gcv_object_t* ptr1 = &TheSvector(dv1)->data[index1];
3455 var gcv_object_t* ptr2 = &TheSvector(dv2)->data[index2];
3456 SIMPLE_REVERSE(ptr1,ptr2,count);
3457 }
3458 break;
3459 case Array_type_sbvector: { /* Simple-Bit-Vector */
3460 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/8];
3461 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/8];
3462 dotimespL(count,count, {
3463 var uint8 value = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
3464 *ptr2 ^= (*ptr2 ^ (value << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
3465 index1++;
3466 ptr1 += ((index1%8)==0);
3467 ptr2 -= ((index2%8)==0);
3468 index2--;
3469 });
3470 }
3471 break;
3472 case Array_type_sb2vector: {
3473 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/4];
3474 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/4];
3475 dotimespL(count,count, {
3476 var uint8 value = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
3477 *ptr2 ^= (*ptr2 ^ (value << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
3478 index1++;
3479 ptr1 += ((index1%4)==0);
3480 ptr2 -= ((index2%4)==0);
3481 index2--;
3482 });
3483 }
3484 break;
3485 case Array_type_sb4vector: {
3486 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1/2];
3487 var uint8* ptr2 = &TheSbvector(dv2)->data[index2/2];
3488 dotimespL(count,count, {
3489 var uint8 value = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
3490 *ptr2 ^= (*ptr2 ^ (value << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
3491 index1++;
3492 ptr1 += ((index1%2)==0);
3493 ptr2 -= ((index2%2)==0);
3494 index2--;
3495 });
3496 }
3497 break;
3498 case Array_type_sb8vector: {
3499 var const uint8* ptr1 = &TheSbvector(dv1)->data[index1];
3500 var uint8* ptr2 = &TheSbvector(dv2)->data[index2];
3501 SIMPLE_REVERSE(ptr1,ptr2,count);
3502 }
3503 break;
3504 case Array_type_sb16vector: {
3505 var const uint16* ptr1 = &((uint16*)&TheSbvector(dv1)->data[0])[index1];
3506 var uint16* ptr2 = &((uint16*)&TheSbvector(dv2)->data[0])[index2];
3507 SIMPLE_REVERSE(ptr1,ptr2,count);
3508 }
3509 break;
3510 case Array_type_sb32vector: {
3511 var const uint32* ptr1 = &((uint32*)&TheSbvector(dv1)->data[0])[index1];
3512 var uint32* ptr2 = &((uint32*)&TheSbvector(dv2)->data[0])[index2];
3513 SIMPLE_REVERSE(ptr1,ptr2,count);
3514 }
3515 break;
3516 case Array_type_sstring: { /* Simple-String */
3517 check_sstring_mutable(dv2);
3518 SstringCase(dv1,{
3519 var const cint8* ptr1 = &TheS8string(dv1)->data[index1];
3520 SstringCase(dv2,{
3521 var cint8* ptr2 = &TheS8string(dv2)->data[index2];
3522 SIMPLE_REVERSE(ptr1,ptr2,count);
3523 },{
3524 var cint16* ptr2 = &TheS16string(dv2)->data[index2];
3525 SIMPLE_REVERSE(ptr1,ptr2,count);
3526 },{
3527 var cint32* ptr2 = &TheS32string(dv2)->data[index2];
3528 SIMPLE_REVERSE(ptr1,ptr2,count);
3529 },{
3530 error_nilarray_store();
3531 });
3532 },{
3533 restart16:
3534 SstringCase(dv2,{
3535 pushSTACK(dv1);
3536 for (;;) {
3537 var chart ch = as_chart(TheS16string(dv1)->data[index1++]);
3538 dv2 = sstring_store(dv2,index2--,ch);
3539 if (--count == 0)
3540 break;
3541 if (sstring_reallocatedp(TheSstring(dv2))) { /* reallocated? */
3542 dv2 = TheSistring(dv2)->data;
3543 dv1 = popSTACK();
3544 goto restart16;
3545 }
3546 }
3547 skipSTACK(1);
3548 },{
3549 var const cint16* ptr1 = &TheS16string(dv1)->data[index1];
3550 var cint16* ptr2 = &TheS16string(dv2)->data[index2];
3551 SIMPLE_REVERSE(ptr1,ptr2,count);
3552 },{
3553 var const cint16* ptr1 = &TheS16string(dv1)->data[index1];
3554 var cint32* ptr2 = &TheS32string(dv2)->data[index2];
3555 SIMPLE_REVERSE(ptr1,ptr2,count);
3556 },{
3557 error_nilarray_store();
3558 });
3559 },{
3560 restart32:
3561 SstringCase(dv2,{
3562 pushSTACK(dv1);
3563 for (;;) {
3564 var chart ch = as_chart(TheS32string(dv1)->data[index1++]);
3565 dv2 = sstring_store(dv2,index2--,ch);
3566 if (--count == 0)
3567 break;
3568 if (sstring_reallocatedp(TheSstring(dv2))) { /* reallocated? */
3569 dv2 = TheSistring(dv2)->data;
3570 dv1 = popSTACK();
3571 goto restart32;
3572 }
3573 }
3574 skipSTACK(1);
3575 },{
3576 pushSTACK(dv1);
3577 for (;;) {
3578 var chart ch = as_chart(TheS32string(dv1)->data[index1++]);
3579 dv2 = sstring_store(dv2,index2--,ch);
3580 if (--count == 0)
3581 break;
3582 if (sstring_reallocatedp(TheSstring(dv2))) { /* reallocated? */
3583 dv2 = TheSistring(dv2)->data;
3584 dv1 = popSTACK();
3585 goto restart32;
3586 }
3587 }
3588 skipSTACK(1);
3589 },{
3590 var const cint32* ptr1 = &TheS32string(dv1)->data[index1];
3591 var cint32* ptr2 = &TheS32string(dv2)->data[index2];
3592 SIMPLE_REVERSE(ptr1,ptr2,count);
3593 },{
3594 error_nilarray_store();
3595 });
3596 },{
3597 error_nilarray_retrieve();
3598 });
3599 }
3600 break;
3601 case Array_type_snilvector:
3602 error_nilarray_retrieve();
3603 default: NOTREACHED;
3604 }
3605 #undef SIMPLE_REVERSE
3606 }
3607
3608 /* Function: Reverses a slice of an array destructively.
3609 elt_nreverse(dv,index,count);
3610 > dv: storage-vector
3611 > index: start index in dv
3612 > count: number of elements to be reversed, > 0 */
elt_nreverse(object dv,uintL index,uintL count)3613 global void elt_nreverse (object dv, uintL index, uintL count) {
3614 #define SIMPLE_NREVERSE(TYPE,p1,p2,c) \
3615 dotimespL(c,c, { var TYPE tmp = *p1; *p1++ = *p2; *p2-- = tmp; })
3616 var uintL index1 = index;
3617 var uintL index2 = index+count-1;
3618 count = floor(count,2);
3619 switch (Array_type(dv)) {
3620 case Array_type_svector: /* Simple-Vector */
3621 if (count > 0) {
3622 var gcv_object_t* ptr1 = &TheSvector(dv)->data[index1];
3623 var gcv_object_t* ptr2 = &TheSvector(dv)->data[index2];
3624 SIMPLE_NREVERSE(gcv_object_t,ptr1,ptr2,count);
3625 }
3626 break;
3627 case Array_type_sbvector: /* Simple-Bit-Vector */
3628 if (count > 0) {
3629 var uint8* ptr1 = &TheSbvector(dv)->data[index1/8];
3630 var uint8* ptr2 = &TheSbvector(dv)->data[index2/8];
3631 dotimespL(count,count, {
3632 var uint8 x1 = (*ptr1 >> ((~index1)%8)) & (bit(1)-1);
3633 var uint8 x2 = (*ptr2 >> ((~index2)%8)) & (bit(1)-1);
3634 *ptr1 ^= (*ptr1 ^ (x2 << ((~index1)%8))) & ((bit(1)-1) << ((~index1)%8));
3635 *ptr2 ^= (*ptr2 ^ (x1 << ((~index2)%8))) & ((bit(1)-1) << ((~index2)%8));
3636 index1++;
3637 ptr1 += ((index1%8)==0);
3638 ptr2 -= ((index2%8)==0);
3639 index2--;
3640 });
3641 }
3642 break;
3643 case Array_type_sb2vector:
3644 if (count > 0) {
3645 var uint8* ptr1 = &TheSbvector(dv)->data[index1/4];
3646 var uint8* ptr2 = &TheSbvector(dv)->data[index2/4];
3647 dotimespL(count,count, {
3648 var uint8 x1 = (*ptr1 >> (2*((~index1)%4))) & (bit(2)-1);
3649 var uint8 x2 = (*ptr2 >> (2*((~index2)%4))) & (bit(2)-1);
3650 *ptr1 ^= (*ptr1 ^ (x2 << (2*((~index1)%4)))) & ((bit(2)-1) << (2*((~index1)%4)));
3651 *ptr2 ^= (*ptr2 ^ (x1 << (2*((~index2)%4)))) & ((bit(2)-1) << (2*((~index2)%4)));
3652 index1++;
3653 ptr1 += ((index1%4)==0);
3654 ptr2 -= ((index2%4)==0);
3655 index2--;
3656 });
3657 }
3658 break;
3659 case Array_type_sb4vector:
3660 if (count > 0) {
3661 var uint8* ptr1 = &TheSbvector(dv)->data[index1/2];
3662 var uint8* ptr2 = &TheSbvector(dv)->data[index2/2];
3663 dotimespL(count,count, {
3664 var uint8 x1 = (*ptr1 >> (4*((~index1)%2))) & (bit(4)-1);
3665 var uint8 x2 = (*ptr2 >> (4*((~index2)%2))) & (bit(4)-1);
3666 *ptr1 ^= (*ptr1 ^ (x2 << (4*((~index1)%2)))) & ((bit(4)-1) << (4*((~index1)%2)));
3667 *ptr2 ^= (*ptr2 ^ (x1 << (4*((~index2)%2)))) & ((bit(4)-1) << (4*((~index2)%2)));
3668 index1++;
3669 ptr1 += ((index1%2)==0);
3670 ptr2 -= ((index2%2)==0);
3671 index2--;
3672 });
3673 }
3674 break;
3675 case Array_type_sb8vector:
3676 if (count > 0) {
3677 var uint8* ptr1 = &TheSbvector(dv)->data[index1];
3678 var uint8* ptr2 = &TheSbvector(dv)->data[index2];
3679 SIMPLE_NREVERSE(uint8,ptr1,ptr2,count);
3680 }
3681 break;
3682 case Array_type_sb16vector:
3683 if (count > 0) {
3684 var uint16* ptr1 = &((uint16*)&TheSbvector(dv)->data[0])[index1];
3685 var uint16* ptr2 = &((uint16*)&TheSbvector(dv)->data[0])[index2];
3686 SIMPLE_NREVERSE(uint16,ptr1,ptr2,count);
3687 }
3688 break;
3689 case Array_type_sb32vector:
3690 if (count > 0) {
3691 var uint32* ptr1 = &((uint32*)&TheSbvector(dv)->data[0])[index1];
3692 var uint32* ptr2 = &((uint32*)&TheSbvector(dv)->data[0])[index2];
3693 SIMPLE_NREVERSE(uint32,ptr1,ptr2,count);
3694 }
3695 break;
3696 case Array_type_sstring: /* Simple-String */
3697 check_sstring_mutable(dv);
3698 if (count > 0) {
3699 SstringDispatch(dv,X, {
3700 var cintX* ptr1 = &((SstringX)TheVarobject(dv))->data[index1];
3701 var cintX* ptr2 = &((SstringX)TheVarobject(dv))->data[index2];
3702 SIMPLE_NREVERSE(cintX,ptr1,ptr2,count);
3703 });
3704 }
3705 break;
3706 case Array_type_snilvector:
3707 error_nilarray_retrieve();
3708 default: NOTREACHED;
3709 }
3710 #undef SIMPLE_NREVERSE
3711 }
3712
3713 /* ======================================================================== */
3714 /* Fill pointers, extendable vectors */
3715
3716 /* Function: Tests whether an array has a fill-pointer.
3717 array_has_fill_pointer_p(array)
3718 > array: ein Array
3719 < result: true, if it has a fill-pointer, else false. */
array_has_fill_pointer_p(object array)3720 global bool array_has_fill_pointer_p (object array) {
3721 if (simplep(array)) {
3722 return false;
3723 } else {
3724 if (Iarray_flags(array) & bit(arrayflags_fillp_bit))
3725 return true;
3726 else
3727 return false;
3728 }
3729 }
3730
3731 LISPFUNNR(array_has_fill_pointer_p,1)
3732 { /* (ARRAY-HAS-FILL-POINTER-P array), CLTL p. 296 */
3733 var object array = check_array(popSTACK());
3734 VALUES_IF(array_has_fill_pointer_p(array));
3735 }
3736
3737 /* signal an error when the vector does not have a fill pointer */
error_no_fillp(object vec)3738 local _Noreturn void error_no_fillp (object vec) {
3739 pushSTACK(vec); /* TYPE-ERROR slot DATUM */
3740 pushSTACK(O(type_vector_with_fill_pointer)); /* TYPE-ERROR slot EXPECTED-TYPE */
3741 pushSTACK(vec); pushSTACK(TheSubr(subr_self)->name);
3742 error(type_error,GETTEXT("~S: vector ~S has no fill pointer"));
3743 }
3744
3745 /* check, if object is a vector with fill-pointer, and returns
3746 the address of the fill-pointer.
3747 *get_fill_pointer(obj) is the fill-pointer itself.
3748 get_fill_pointer(obj)[-1] is the length (dimension 0) of the vector. */
get_fill_pointer(object obj)3749 local uintL* get_fill_pointer (object obj) {
3750 /* obj must be a vector: */
3751 if (!vectorp(obj))
3752 error_vector(obj);
3753 /* must not be simple & must have a fill-pointer */
3754 if (simplep(obj) || !(Iarray_flags(obj) & bit(arrayflags_fillp_bit)))
3755 error_no_fillp(obj);
3756 /* where is the fill-pointer? */
3757 return ((Iarray_flags(obj) & bit(arrayflags_dispoffset_bit))
3758 ? &TheIarray(obj)->dims[2] /* behind displaced-offset and dimension 0 */
3759 : &TheIarray(obj)->dims[1]); /* behind dimension 0 */
3760 }
3761
3762 LISPFUNNR(fill_pointer,1) { /* (FILL-POINTER vector), CLTL p. 296 */
3763 var object obj = popSTACK();
3764 VALUES1(fixnum(* get_fill_pointer(obj))); /* get fill-pointer as Fixnum */
3765 }
3766
3767 LISPFUNN(set_fill_pointer,2)
3768 { /* (SYS::SET-FILL-POINTER vector index)
3769 = (SETF (FILL-POINTER vector) index), CLTL p. 296 */
3770 var uintL* fillp = get_fill_pointer(STACK_1); /* fillpointer-address */
3771 if (!posfixnump(STACK_0)) /* new fill-pointer must be fixnum>=0 . */
3772 error_index_type(STACK_1);
3773 var uintV newfillp = posfixnum_to_V(STACK_0); /* as uintL */
3774 if (!(newfillp <= fillp[-1])) /* must be <= length */
3775 error_index_range(STACK_1,fillp[-1]+1);
3776 *fillp = newfillp; /* store new fill-pointer */
3777 VALUES1(STACK_0); /* return new fill-pointer */
3778 skipSTACK(2);
3779 }
3780
3781 LISPFUNN(vector_push,2) /* (VECTOR-PUSH new-element vector), CLTL p. 296 */
3782 {
3783 var uintL* fillp = get_fill_pointer(STACK_0); /* fillpointer-address */
3784 var uintL oldfillp = *fillp; /* old value of the fillpointer */
3785 if (oldfillp >= fillp[-1]) { /* Fill-Pointer at the end? */
3786 VALUES1(NIL); /* return NIL */
3787 } else {
3788 var uintL index = oldfillp;
3789 var object datenvektor = iarray_displace(STACK_0,&index);
3790 storagevector_store(datenvektor,index,STACK_1,true); /* store new-element */
3791 fillp = get_fill_pointer(STACK_0); /* fill pointer address, again */
3792 (*fillp)++; /* increase fill-pointer */
3793 VALUES1(fixnum(oldfillp));
3794 /* old fill-pointer as vaue */
3795 }
3796 skipSTACK(2);
3797 }
3798
3799 LISPFUNN(vector_pop,1) /* (VECTOR-POP vector), CLTL p. 296 */
3800 {
3801 var object array = popSTACK();
3802 var uintL* fillp = get_fill_pointer(array);
3803 if (*fillp==0) {
3804 /* fill-pointer was =0 -> error-message */
3805 pushSTACK(array); pushSTACK(TheSubr(subr_self)->name);
3806 error(error_condition,GETTEXT("~S: ~S has length zero"));
3807 } else {
3808 var uintL index = --(*fillp); /* decrease fill-pointer */
3809 var object datenvektor = iarray_displace(array,&index);
3810 VALUES1(storagevector_aref(datenvektor,index)); /* return element */
3811 }
3812 }
3813
3814 /* Vector will be too long -> error */
error_extension(object extension)3815 local _Noreturn void error_extension (object extension) {
3816 pushSTACK(extension); pushSTACK(TheSubr(subr_self)->name);
3817 error(error_condition,
3818 GETTEXT("~S: extending the vector by ~S elements makes it too long"));
3819 }
3820
3821 LISPFUN(vector_push_extend,seclass_default,2,1,norest,nokey,0,NIL)
3822 { /* (VECTOR-PUSH-EXTEND new-element vector [extension]), CLTL p. 296 */
3823 var uintL* fillp = get_fill_pointer(STACK_1); /* fillpointer-address */
3824 var uintL oldfillp = *fillp; /* old value of the fillpointer */
3825 if (oldfillp < fillp[-1]) { /* fill-pointer not yet at the end? */
3826 skipSTACK(1);
3827 var uintL index = oldfillp;
3828 var object datenvektor = iarray_displace(STACK_0,&index);
3829 storagevector_store(datenvektor,index,STACK_1,true); /* store new-element */
3830 fillp = get_fill_pointer(STACK_0); /* fill pointer address, again */
3831 (*fillp)++; /* increase fill-pointer */
3832 } else { /* fill-pointer at the end -> try to extend the vector: */
3833 var object extension = popSTACK();
3834 var object array = STACK_0;
3835 if (!(Iarray_flags(array) & bit(arrayflags_adjustable_bit))) {
3836 /* vector not adjustable -> error-message: */
3837 /* array still in STACK_0 */
3838 pushSTACK(TheSubr(subr_self)->name);
3839 error(error_condition,GETTEXT("~S works only on adjustable arrays, not on ~S"));
3840 }
3841 var uintB atype = Iarray_flags(array) & arrayflags_atype_mask;
3842 var uintL len = fillp[-1]; /* former length (dimension 0) */
3843 var uintV inc; /* desired increment of the length */
3844 if (boundp(extension)) {
3845 /* extension should be a fixnum >0, <arraysize_limit : */
3846 if ( !posfixnump(extension)
3847 || ((inc = posfixnum_to_V(extension)) == 0)
3848 || (inc > arraysize_limit_1)) {
3849 pushSTACK(extension); /* TYPE-ERROR slot DATUM */
3850 pushSTACK(O(type_posfixnum1)); /* TYPE-ERROR slot EXPECTED-TYPE */
3851 pushSTACK(extension); pushSTACK(TheSubr(subr_self)->name);
3852 error(type_error,
3853 GETTEXT("~S: extension ~S should be a positive fixnum"));
3854 }
3855 } else {
3856 /* default-extension: */
3857 switch (atype) {
3858 case Atype_NIL: case Atype_T:
3859 inc = 16; break; /* for general-vectors: 16 objects */
3860 case Atype_Char: inc = 64; break; /* for strings: 64 characters */
3861 case Atype_Bit: inc = 128; break; /* for bit-vectors: 128 bits */
3862 case Atype_2Bit: case Atype_4Bit: case Atype_8Bit:
3863 case Atype_16Bit: case Atype_32Bit: /* for byte-vectors: accordingly */
3864 inc = bit(floor(14-atype,2)); break;
3865 default: NOTREACHED;
3866 }
3867 /* but at least the former length: */
3868 if (inc<len)
3869 inc = len;
3870 extension = UV_to_I(inc);
3871 }
3872 var uintV newlen = len + inc; /* new length */
3873 if (newlen > arraysize_limit_1)
3874 error_extension(extension);
3875 /* fetch new data vector. Distinguish cases according to type: */
3876 var object neuer_datenvektor;
3877 switch (atype) {
3878 case Atype_T: /* array is a general-vector */
3879 neuer_datenvektor = allocate_vector(newlen);
3880 array = STACK_0; /* fetch array again */
3881 /* copy old into the new data vector: */
3882 if (len>0) {
3883 var uintL index = 0;
3884 var object datenvektor = iarray_displace_check(array,len,&index);
3885 elt_copy_T_T(datenvektor,index,neuer_datenvektor,0,len);
3886 }
3887 /* then append new_element: */
3888 TheSvector(neuer_datenvektor)->data[len] = STACK_1;
3889 break;
3890 case Atype_Char: /* array is a string */
3891 if (newlen > stringsize_limit_1)
3892 error_extension(extension);
3893 neuer_datenvektor = allocate_string(newlen);
3894 array = STACK_0; /* fetch array again */
3895 /* copy old into the new data vector: */
3896 if (len>0) {
3897 var uintL index = 0;
3898 var object datenvektor = iarray_displace_check(array,len,&index);
3899 elt_copy_Char_Char(datenvektor,index,neuer_datenvektor,0,len);
3900 }
3901 /* then append new_element: */
3902 if (!charp(STACK_1))
3903 goto error_type;
3904 TheSnstring(neuer_datenvektor)->data[len] = char_code(STACK_1);
3905 break;
3906 case Atype_Bit: /* array is a bit-vector */
3907 case Atype_2Bit: case Atype_4Bit: case Atype_8Bit:
3908 case Atype_16Bit: case Atype_32Bit: /* array is a byte-vector */
3909 neuer_datenvektor = allocate_bit_vector(atype,newlen);
3910 array = STACK_0; /* fetch array */
3911 /* copy old into the new data vector: */
3912 if (len>0) {
3913 var uintL index = 0;
3914 var object datenvektor = iarray_displace_check(array,len,&index);
3915 switch (atype) {
3916 case Atype_Bit:
3917 case Atype_2Bit:
3918 case Atype_4Bit:
3919 bit_copy(datenvektor,index<<atype,neuer_datenvektor,0<<atype,len<<atype);
3920 break;
3921 case Atype_8Bit:
3922 elt_copy_8Bit_8Bit(datenvektor,index,neuer_datenvektor,0,len);
3923 break;
3924 case Atype_16Bit:
3925 elt_copy_16Bit_16Bit(datenvektor,index,neuer_datenvektor,0,len);
3926 break;
3927 case Atype_32Bit:
3928 elt_copy_32Bit_32Bit(datenvektor,index,neuer_datenvektor,0,len);
3929 break;
3930 default: NOTREACHED;
3931 }
3932 }
3933 /* store new-element: */
3934 storagevector_store(neuer_datenvektor,len,STACK_1,false);
3935 break;
3936 case Atype_NIL: goto error_type;
3937 default: NOTREACHED;
3938 error_type: {
3939 /* stack layout: new-element, vector. */
3940 pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM */
3941 pushSTACK(array_element_type(STACK_(0+1))); /* TYPE-ERROR slot EXPECTED-TYPE */
3942 pushSTACK(STACK_(0+2)); pushSTACK(STACK_(1+3));
3943 pushSTACK(TheSubr(subr_self)->name);
3944 error(type_error,GETTEXT("~S: cannot push ~S into array ~S (bad type)"));
3945 }
3946 }
3947 set_break_sem_1(); /* forbid interrupts */
3948 TheIarray(array)->data = neuer_datenvektor; /* store new vector as data vector */
3949 iarray_flags_clr(TheIarray(array),bit(arrayflags_displaced_bit)); /* delete displaced-bit */
3950 TheIarray(array)->dims[2] += 1; /* increase fillpointer by 1 */
3951 TheIarray(array)->dims[1] = newlen; /* store new length */
3952 TheIarray(array)->totalsize = newlen; /* is also the new totalsize */
3953 clr_break_sem_1(); /* permit interrupts again */
3954 }
3955 VALUES1(fixnum(oldfillp));
3956 /* old fill-pointer as value */
3957 skipSTACK(2);
3958 }
3959
3960 /* ======================================================================== */
3961 /* Bit vectors */
3962
3963 /* Function: Allocates a new simple-bit-vector, filled with zeroes.
3964 allocate_bit_vector_0(len)
3965 > uintL len: length of the desired bit-vector (number of bits)
3966 < result: fresh simple-bit-vector, filled with zeroes
3967 can trigger GC */
allocate_bit_vector_0(uintL len)3968 modexp maygc object allocate_bit_vector_0 (uintL len) {
3969 var object newvec = allocate_bit_vector(Atype_Bit,len); /* new bit-vector */
3970 var uintL count = ceiling(len,bitpack); /* fill ceiling(len/bitpack) words with zeroes */
3971 if (count!=0) {
3972 var uint_bitpack_t* ptr = (uint_bitpack_t*)(&TheSbvector(newvec)->data[0]);
3973 dotimespL(count,count, {
3974 *ptr++ = 0;
3975 });
3976 }
3977 return newvec;
3978 }
3979
3980 #if 0 /* only as reserve, in case, that we encounter a GCC-bug again */
3981
3982 /* UP: deletes a bit in a simple-bit-vector
3983 sbvector_bclr(sbvector,index);
3984 > sbvector: a simple-bit-vector
3985 > index: index (variable, should be < (length sbvector) ) */
3986 global void sbvector_bclr (object sbvector, uintL index) {
3987 /* in byte (index div 8), delete the bit 7 - (index mod 8) : */
3988 TheSbvector(sbvector)->data[index/8] &= ~bit((~index) % 8);
3989 }
3990
3991 /* UP: sets a bit in a simple-bit-vector
3992 sbvector_bset(sbvector,index);
3993 > sbvector: a simple-bit-vector
3994 > index: index (variable, should be < (length sbvector) ) */
3995 global void sbvector_bset (object sbvector, uintL index) {
3996 /* in byte (index div 8), set the bit 7 - (index mod 8) : */
3997 TheSbvector(sbvector)->data[index/8] |= bit((~index) % 8);
3998 }
3999
4000 #endif
4001
4002 /* error: bad dimension
4003 > dim: wrong dimension */
error_dim_type(object dim)4004 local _Noreturn void error_dim_type (object dim) {
4005 pushSTACK(dim); /* TYPE-ERROR slot DATUM */
4006 pushSTACK(O(type_array_index)); /* TYPE-ERROR slot EXPECTED-TYPE */
4007 pushSTACK(dim);
4008 pushSTACK(TheSubr(subr_self)->name);
4009 error(type_error,GETTEXT("~S: dimension ~S is not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"));
4010 }
4011
4012 /* ======================================================================== */
4013 /* Semi-simple strings */
4014
4015 /* The following functions work on "semi-simple string"s.
4016 That are CHARACTER arrays with FILL-POINTER, (pro forma) not adjustable and
4017 not displaced, whose storagevector is a normal-simple-string. When their
4018 length is exceeded, the length is doubled (so that the resizing effort
4019 becomes unimportant: adding a character is still O(1) on average.) */
4020
4021 /* Function: Returns a fresh semi-simple-string of given length, with
4022 fill-pointer = 0.
4023 make_ssstring(len)
4024 > uintL len: desired length, must be >0
4025 < fresh: fresh semi-simple-string of the given length
4026 can trigger GC */
make_ssstring(uintL len)4027 global maygc object make_ssstring (uintL len) {
4028 if (len > arraysize_limit_1)
4029 error_dim_type(UL_to_I(len));
4030 if (len > stringsize_limit_1)
4031 error_stringsize(len);
4032 pushSTACK(allocate_string(len));
4033 var object new_array =
4034 allocate_iarray(bit(arrayflags_fillp_bit)|Atype_Char,1,Array_type_string);
4035 /* Flags: only FILL_POINTER_BIT, element type CHARACTER, rank=1 */
4036 TheIarray(new_array)->dims[1] = 0; /* fill-pointer := 0 */
4037 TheIarray(new_array)->totalsize =
4038 TheIarray(new_array)->dims[0] = len; /* length and total-size */
4039 TheIarray(new_array)->data = popSTACK(); /* data vector */
4040 return new_array;
4041 }
4042
4043 /* Function: extend the string to length <= arraysize_limit_1
4044 > ssstring: a semi-simple-string
4045 > size: how much to allocate
4046 < returns: the same semi-simple-string
4047 can trigger GC */
ssstring_extend_low(object ssstring,uintL size)4048 local maygc object ssstring_extend_low (object ssstring, uintL size) {
4049 if (size > arraysize_limit_1)
4050 error_dim_type(UL_to_I(size));
4051 if (size > stringsize_limit_1)
4052 error_stringsize(size);
4053 pushSTACK(ssstring);
4054 var object new_data = allocate_string(size);
4055 ssstring = popSTACK();
4056 if (TheIarray(ssstring)->dims[1] > 0) {
4057 #ifdef ENABLE_UNICODE
4058 copy_32bit_32bit
4059 #else
4060 copy_8bit_8bit
4061 #endif
4062 (TheS32string(TheIarray(ssstring)->data)->data,
4063 TheS32string(new_data)->data,TheIarray(ssstring)->dims[1]);
4064 }
4065 set_break_sem_1(); /* forbid interrupts */
4066 TheIarray(ssstring)->data = new_data;
4067 TheIarray(ssstring)->totalsize = TheIarray(ssstring)->dims[0] = size;
4068 clr_break_sem_1(); /* permit interrupts again */
4069 return ssstring;
4070 }
4071
4072 /* Function: Adds a character to a semi-simple-string, thereby possibly
4073 extending it.
4074 ssstring_push_extend(ssstring,ch)
4075 > ssstring: a semi-simple-string
4076 > ch: a character
4077 < result: the same semi-simple-string
4078 can trigger GC */
ssstring_push_extend(object ssstring,chart ch)4079 global maygc object ssstring_push_extend (object ssstring, chart ch) {
4080 var object sstring = TheIarray(ssstring)->data; /* normal-simple-string */
4081 var uintL len = Sstring_length(sstring);
4082 if (TheIarray(ssstring)->dims[1] >= len) { /* fill-pointer >= length ? */
4083 len *= 2;
4084 if (len > arraysize_limit_1) /* cannot extend beyond arraysize_limit_1 */
4085 len = arraysize_limit_1;
4086 if (TheIarray(ssstring)->dims[1] >= len) /* still no good! */
4087 error_extension(Fixnum_1);
4088 ssstring = ssstring_extend_low(ssstring,len);
4089 sstring = TheIarray(ssstring)->data;
4090 }
4091 /* now sstring is still the data vector, and we have
4092 fill-pointer < length(data vector).
4093 push the character in and increase the fill-pointer: */
4094 TheSnstring(sstring)->data[ TheIarray(ssstring)->dims[1]++ ] = ch;
4095 return ssstring;
4096 }
4097
4098 /* Function: Ensures that a semi-simple-string has at least a given length,
4099 possibly extending it.
4100 ssstring_extend(ssstring,size)
4101 > ssstring: a semi-simple-string
4102 > size: desired minimum length
4103 < result: the same semi-simple-string
4104 can trigger GC */
ssstring_extend(object ssstring,uintL needed_len)4105 global maygc object ssstring_extend (object ssstring, uintL needed_len) {
4106 var object sstring = TheIarray(ssstring)->data; /* normal simple string */
4107 var uintL now_len = Sstring_length(sstring); /* current maximal lenth */
4108 if (needed_len > arraysize_limit_1) /* cannot extend beyond arraysize_limit_1 */
4109 error_extension(UL_to_I(needed_len-TheIarray(ssstring)->dims[1]));
4110 if (needed_len > now_len) {
4111 /* yes -> lengthen the string at least by a factor of 2: */
4112 now_len *= 2;
4113 if (now_len > arraysize_limit_1) /* cannot extend beyond arraysize_limit_1 */
4114 now_len = arraysize_limit_1;
4115 else if (needed_len > now_len)
4116 now_len = needed_len; /* increase now_len */
4117 ssstring = ssstring_extend_low(ssstring,now_len);
4118 }
4119 return ssstring;
4120 }
4121
4122 /* Function: Adds a substring to a semi-simple-string, thereby possibly
4123 extending it.
4124 ssstring_append_extend(ssstring,sstring,start,len)
4125 > ssstring: a semi-simple-string
4126 > srcstring: a simple-string
4127 > start: the start index into the sstring
4128 > len: the number of characters to be pushed, starting from start; >0
4129 < result: the same semi-simple-string
4130 can trigger GC */
ssstring_append_extend(object ssstring,object srcstring,uintL start,uintL len)4131 global maygc object ssstring_append_extend (object ssstring, object srcstring,
4132 uintL start, uintL len) {
4133 var uintL old_len = TheIarray(ssstring)->dims[1]; /* length = fill-pointer */
4134 if (old_len + len > TheIarray(ssstring)->dims[0]) { /* len bytes will not fit */
4135 pushSTACK(srcstring);
4136 ssstring = ssstring_extend(ssstring,old_len+len);
4137 srcstring = popSTACK();
4138 }
4139 { /* push the characters in: */
4140 var cint32* ptr = &TheS32string(TheIarray(ssstring)->data)->data[old_len];
4141 #ifdef ENABLE_UNICODE
4142 SstringCase(srcstring,
4143 { copy_8bit_32bit(&TheS8string(srcstring)->data[start],ptr,len); },
4144 { copy_16bit_32bit(&TheS16string(srcstring)->data[start],ptr,len); },
4145 { copy_32bit_32bit(&TheS32string(srcstring)->data[start],ptr,len); },
4146 { NOTREACHED; });
4147 #else
4148 copy_8bit_8bit(&TheS8string(srcstring)->data[start],ptr,len);
4149 #endif
4150 }
4151 /* increase the fill-pointer: */
4152 TheIarray(ssstring)->dims[1] += len;
4153 return ssstring;
4154 }
4155
4156 /* ======================================================================== */
4157 /* Semi-simple byte vectors */
4158
4159 /* The following functions work on "semi-simple byte-vector"s.
4160 That are bit vectors with FILL-POINTER, (pro forma) not adjustable and
4161 not displaced, whose storagevector is a simple-bit-vector. When their
4162 length is exceeded, the length is doubled (so that the resizing effort
4163 becomes unimportant: adding a character is still O(1) on average.) */
4164
4165 /* Function: Returns a fresh semi-simple byte-vector of given length, with
4166 fill-pointer = 0.
4167 make_ssbvector(len)
4168 > uintL len: length (number of bytes!), must be >0
4169 < result: fresh semi-simple byte-vector of the given length
4170 can trigger GC */
make_ssbvector(uintL len)4171 global maygc object make_ssbvector (uintL len) {
4172 if (len > arraysize_limit_1)
4173 error_dim_type(UL_to_I(len));
4174 pushSTACK(allocate_bit_vector(Atype_8Bit,len));
4175 var object new_array =
4176 allocate_iarray(bit(arrayflags_fillp_bit)|Atype_8Bit,1,Array_type_b8vector);
4177 /* Flags: only FILL_POINTER_BIT, element type BIT, rank=1 */
4178 TheIarray(new_array)->dims[1] = 0; /* fill-pointer := 0 */
4179 TheIarray(new_array)->totalsize =
4180 TheIarray(new_array)->dims[0] = len; /* length and total-size */
4181 TheIarray(new_array)->data = popSTACK(); /* data vector */
4182 return new_array;
4183 }
4184
4185 /* Function: Adds a byte to a semi-simple byte vector, thereby possibly
4186 extending it.
4187 ssbvector_push_extend(ssbvector,b)
4188 > ssbvector: a semi-simple byte-vector
4189 > b: byte
4190 < result: the same semi-simple byte-vector
4191 can trigger GC */
ssbvector_push_extend(object ssbvector,uintB b)4192 global maygc object ssbvector_push_extend (object ssbvector, uintB b) {
4193 var object sbvector = TheIarray(ssbvector)->data; /* simple-8bit-vector */
4194 var uintL len = Sbvector_length(sbvector);
4195 if (TheIarray(ssbvector)->dims[1] >= len) { /* fill-pointer >= length ? */
4196 /* yes -> double the length of data vector */
4197 len *= 2;
4198 if (len > arraysize_limit_1) /* cannot extend beyond arraysize_limit_1 */
4199 len = arraysize_limit_1;
4200 if (TheIarray(ssbvector)->dims[1] >= len) /* still no good! */
4201 error_extension(Fixnum_1);
4202 pushSTACK(ssbvector); /* save ssbvector */
4203 pushSTACK(sbvector); /* save data vector */
4204 var object new_sbvector = allocate_bit_vector(Atype_8Bit,len);
4205 /* new simple-8bit-vector of double length */
4206 sbvector = popSTACK(); /* restore sbvector */
4207 /* copy the contents of sbvector into new_sbvector: */
4208 elt_copy_8Bit_8Bit(sbvector,0,new_sbvector,0,Sbvector_length(sbvector));
4209 ssbvector = popSTACK(); /* restore ssbvector */
4210 set_break_sem_1(); /* forbid interrupts */
4211 TheIarray(ssbvector)->data = new_sbvector; /* new bit-vector as the data */
4212 TheIarray(ssbvector)->totalsize = /* new length */
4213 TheIarray(ssbvector)->dims[0] = Sbvector_length(new_sbvector);
4214 clr_break_sem_1(); /* permit interrupts again */
4215 sbvector = new_sbvector;
4216 }
4217 /* now sbvector is still the data vector, and we have
4218 fill-pointer < length(data vector).
4219 push the byte in and increase the fill-pointer: */
4220 TheSbvector(sbvector)->data[ TheIarray(ssbvector)->dims[1]++ ] = b;
4221 return ssbvector;
4222 }
4223
4224 /* ======================================================================== */
4225 /* MAKE-ARRAY */
4226
4227 /* Stack layout of MAKE-ARRAY :
4228 dims, adjustable, element-type, initial-element, initial-contents,
4229 fill-pointer, displaced-to, displaced-index-offset.
4230 stack layout of ADJUST-ARRAY :
4231 dims, array, element-type, initial-element, initial-contents,
4232 fill-pointer, displaced-to, displaced-index-offset. */
4233
4234 /* auxiliary routine for MAKE-ARRAY and ADJUST-ARRAY:
4235 checks the dimensions and returns the rank and the total size.
4236 test_dims(&totalsize)
4237 > STACK_7: dimension or dimension list
4238 < totalsize: total size = product of the dimensions
4239 < result: Rang = number of the dimensions */
test_dims(uintL * totalsize_)4240 local uintL test_dims (uintL* totalsize_) {
4241 var object dims = STACK_7;
4242 if (listp(dims)) {
4243 var uintL rank = 0; /* number of dimensions so far */
4244 var uintL totalsize = 1; /* product of dimensions so far, */
4245 /* remains < arraysize_limit */
4246 while (consp(dims)) {
4247 var object dim = Car(dims); /* next dimension */
4248 /* if (!integerp(dim)) error_dim_type(dim); */
4249 if (!posfixnump(dim)) error_dim_type(dim); /* must be Fixnum >=0 */
4250 #if (oint_data_len>32)
4251 if (posfixnum_to_V(dim) >= vbit(32)) /* must fit in 32 bits */
4252 error_dim_type(dim);
4253 #endif
4254 /* calculate totalsize * dim: */
4255 var uintL produkt_hi;
4256 var uintL produkt_lo;
4257 #if (oint_data_len<=24)
4258 mulu24(totalsize,posfixnum_to_V(dim), produkt_hi=,produkt_lo=);
4259 #else
4260 mulu32(totalsize,posfixnum_to_V(dim), produkt_hi=,produkt_lo=);
4261 #endif
4262 if (!((produkt_hi==0) && (produkt_lo<=arraysize_limit_1))) { /* product < 2^24 ? */
4263 /* no -> (provided that there is not a dimension=0 )
4264 total-size too large */
4265 pushSTACK(STACK_7); /* dims */
4266 pushSTACK(TheSubr(subr_self)->name);
4267 error(error_condition,GETTEXT("~S: dimensions ~S produce too large total-size"));
4268 }
4269 totalsize = produkt_lo;
4270 rank++;
4271 dims = Cdr(dims);
4272 }
4273 *totalsize_ = totalsize;
4274 return rank;
4275 } else {
4276 /* dims is not a list. Should be a single dimension: */
4277 if (!posfixnump(dims)) error_dim_type(dims); /* must be Fixnum >=0 */
4278 #if (oint_data_len>32)
4279 if (posfixnum_to_V(dims) >= vbit(32)) /* must fit in 32 bits */
4280 error_dim_type(dims);
4281 #endif
4282 *totalsize_ = posfixnum_to_V(dims); /* Totalsize = single dimension */
4283 return 1; /* Rang = 1 */
4284 }
4285 }
4286
4287 /* auxiliary routine for MAKE-ARRAY and ADJUST-ARRAY:
4288 checks some of the keywords. */
test_otherkeys(void)4289 local void test_otherkeys (void) {
4290 /* fill-pointer has default value NIL: */
4291 if (!boundp(STACK_2))
4292 STACK_2 = NIL;
4293 /* displaced-to has default value NIL: */
4294 if (!boundp(STACK_1))
4295 STACK_1 = NIL;
4296 { /* test, if more than one initialization
4297 (:initial-element, :initial-contents, :displaced-to) was specified: */
4298 var uintC initcount = 0; /* counter */
4299 if (boundp(STACK_4)) /* initial-element supplied? */
4300 initcount++;
4301 if (boundp(STACK_3)) /* initial-contents supplied? */
4302 initcount++;
4303 if (!nullp(STACK_1)) /* displaced-to supplied? */
4304 initcount++;
4305 if (initcount > 1) { /* more than one initialization? */
4306 pushSTACK(TheSubr(subr_self)->name);
4307 error(error_condition,
4308 GETTEXT("~S: ambiguous, more than one initialization specified"));
4309 }
4310 }
4311 /* test, if :displaced-index-offset was used without :displaced-to: */
4312 if (boundp(STACK_0) /* displaced-index-offset supplied? */
4313 && (nullp(STACK_1))) { /* and displaced-to not supplied? */
4314 pushSTACK(S(Kdisplaced_to));
4315 pushSTACK(S(Kdisplaced_index_offset));
4316 pushSTACK(TheSubr(subr_self)->name);
4317 error(error_condition,GETTEXT("~S: ~S must not be specified without ~S"));
4318 }
4319 }
4320
4321 /* auxiliary routine for MAKE-ARRAY and ADJUST-ARRAY:
4322 fills the new data vector with initial-element, if supplied.
4323 fill_initial_element(len,vector)
4324 > len: length
4325 > vector: data vector
4326 > STACK_4: initial-element
4327 < result: vector filled, if necessary
4328 can trigger GC */
fill_initial_element(uintL len,object vector)4329 local maygc object fill_initial_element (uintL len, object vector) {
4330 if (boundp(STACK_4) /* initial-element supplied? */
4331 && (len != 0)) { /* and length > 0 ? */
4332 pushSTACK(vector);
4333 if (elt_fill(vector,0,len,STACK_(4+1))) {
4334 pushSTACK(STACK_(4+1)); /* TYPE-ERROR slot DATUM */
4335 pushSTACK(STACK_(5+2)); /* TYPE-ERROR slot EXPECTED-TYPE */
4336 pushSTACK(STACK_(5+3)); /* element-type */
4337 pushSTACK(STACK_(4+4)); /* initial-element */
4338 pushSTACK(TheSubr(subr_self)->name);
4339 error(type_error,GETTEXT("~S: the initial-element ~S is not of type ~S"));
4340 }
4341 vector = popSTACK();
4342 #ifdef HAVE_SMALL_SSTRING
4343 ASSERT(!sarray_reallocstringp(vector));
4344 #endif
4345 }
4346 return vector;
4347 }
4348
4349 /* auxiliary routine for MAKE-ARRAY and ADJUST-ARRAY:
4350 creates a data vector of given length
4351 and fills it with initial-element, if supplied.
4352 make_storagevector(len,eltype)
4353 > len: length
4354 > eltype: elementtype-code
4355 > STACK_4: initial-element
4356 < result: simple vector of given type, poss. filled.
4357 can trigger GC */
make_storagevector(uintL len,uintB eltype)4358 local maygc object make_storagevector (uintL len, uintB eltype) {
4359 var object vector;
4360 switch (eltype) {
4361 case Atype_T: { /* create simple-vector */
4362 vector = allocate_vector(len);
4363 } break;
4364 case Atype_Char: { /* create simple-string */
4365 check_stringsize(len);
4366 #ifdef HAVE_SMALL_SSTRING
4367 if (charp(STACK_4) && len>0) {
4368 var cint initial_element = char_int(STACK_4);
4369 if (initial_element < cint8_limit)
4370 vector = allocate_s8string(len);
4371 else if (initial_element < cint16_limit)
4372 vector = allocate_s16string(len);
4373 else
4374 vector = allocate_s32string(len);
4375 } else
4376 vector = allocate_s8string(len);
4377 #else
4378 vector = allocate_string(len);
4379 #endif
4380 } break;
4381 case Atype_Bit:
4382 case Atype_2Bit:
4383 case Atype_4Bit:
4384 case Atype_8Bit:
4385 case Atype_16Bit:
4386 case Atype_32Bit: { /* create simple bit/byte-vector */
4387 vector = allocate_bit_vector(eltype,len);
4388 } break;
4389 case Atype_NIL: {
4390 vector = NIL;
4391 } break;
4392 default: NOTREACHED;
4393 }
4394 return fill_initial_element(len,vector);
4395 }
4396
4397 /* auxiliary routine for MAKE-ARRAY and ADJUST-ARRAY:
4398 Fills a vector lexicographically with the content of a nested
4399 sequence-structure, which is supplied as argument for
4400 keyword :initial-contents with MAKE-ARRAY and ADJUST-ARRAY.
4401 initial_contents(datenvektor,dims,rank,contents)
4402 > datenvektor: a simple vector
4403 > dims: dimension or dimension list, all dimensions Fixnums,
4404 Length(datenvektor) = product of the dimensions
4405 > rank: number of dimensions
4406 > contents: nested sequence-structure
4407 < result: the same data vector
4408 not reentrant!
4409 can trigger GC */
4410 typedef struct {
4411 gcv_object_t* localptr; /* pointer to data vector and dimensions */
4412 uintL index; /* index into the data vector */
4413 uintL depth; /* recursion depth */
4414 } initial_contents_locals_t;
4415 local map_sequence_function_t initial_contents_aux;
initial_contents(object datenvektor,object dims,uintL rank,object contents)4416 local maygc object initial_contents (object datenvektor, object dims,
4417 uintL rank, object contents) {
4418 /* put all dimensions on the stack: */
4419 get_space_on_STACK(rank*sizeof(gcv_object_t));
4420 if (listp(dims)) {
4421 while (consp(dims)) {
4422 pushSTACK(Car(dims)); dims = Cdr(dims);
4423 }
4424 } else {
4425 pushSTACK(dims);
4426 }
4427 var initial_contents_locals_t locals;
4428 locals.localptr = &STACK_0; /* memorize current STACK-value */
4429 locals.index = 0; /* index := 0 */
4430 locals.depth = rank; /* depth := rank */
4431 pushSTACK(datenvektor); /* push data vector on Stack */
4432 initial_contents_aux(&locals,contents); /* call initial_contents_aux */
4433 datenvektor = popSTACK(); /* pop data vector */
4434 skipSTACK(rank); /* clean up STACK */
4435 return datenvektor;
4436 }
4437
4438 /* auxiliary routine for initial_contents:
4439 processes the sequence-structure recursively. */
initial_contents_aux(void * arg,object obj)4440 local maygc void initial_contents_aux (void* arg, object obj) {
4441 var initial_contents_locals_t* locals = (initial_contents_locals_t*)arg;
4442 /* the following is passed:
4443 locals->depth = recursion depth,
4444 locals->index = index into the data vector,
4445 locals->localptr = pointer to the dimensions,
4446 when Depth depth>0 :
4447 dimension (rank-depth) = *(localptr+depth-1),
4448 data vector = *(localptr-1), caller = *(localptr-2). */
4449 var gcv_object_t* localptr = locals->localptr;
4450 if (locals->depth==0) {
4451 /* depth 0 -> store element obj in the data vector: */
4452 var object datenvektor = *(localptr STACKop -1);
4453 pushSTACK(obj);
4454 pushSTACK(datenvektor);
4455 datenvektor = storagevector_store(datenvektor,locals->index,STACK_1,true);
4456 #ifdef HAVE_SMALL_SSTRING
4457 if (sarray_reallocstringp(datenvektor)) /* has it been reallocated? */
4458 *(localptr STACKop -1) = datenvektor = TheSistring(datenvektor)->data;
4459 #endif
4460 locals->index++;
4461 skipSTACK(2); /* clean up stack */
4462 } else { /* depth >0 -> call recursively: */
4463 locals->depth--;
4464 pushSTACK(obj);
4465 /* obj = STACK_0 must be a sequence of correct length: */
4466 pushSTACK(STACK_0); funcall(L(length),1); /* determine length */
4467 /* must be EQL (which means EQ) to dimension *(localptr+depth) : */
4468 if (!(eq(value1,*(localptr STACKop locals->depth)))) {
4469 /* defective sequence seq still in STACK_0. */
4470 pushSTACK(TheSubr(subr_self)->name);
4471 error(error_condition,GETTEXT("~S: ~S is of incorrect length"));
4472 }
4473 /* length is correct, now execute (MAP NIL #'INITIAL-CONTENTS-AUX seq) : */
4474 map_sequence(STACK_0,&initial_contents_aux,locals);
4475 locals->depth++;
4476 skipSTACK(1); /* clean up stack */
4477 }
4478 }
4479
4480 /* auxiliary routine for MAKE-ARRAY and ADJUST-ARRAY:
4481 check a displaced-to-argument and the belonging offset.
4482 test_displaced(eltype,totalsize)
4483 > eltype: elementtype-code of the creating array
4484 > totalsize: total size of the creating array
4485 < result: value of the displaced-index-offset */
test_displaced(uintB eltype,uintL totalsize)4486 local uintL test_displaced (uintB eltype, uintL totalsize) {
4487 /* check displaced-to, must be a array: */
4488 var object displaced_to = STACK_1;
4489 if (!arrayp(displaced_to)) {
4490 pushSTACK(displaced_to); /* TYPE-ERROR slot DATUM */
4491 pushSTACK(S(array)); /* TYPE-ERROR slot EXPECTED-TYPE */
4492 pushSTACK(displaced_to);
4493 pushSTACK(S(Kdisplaced_to));
4494 pushSTACK(TheSubr(subr_self)->name);
4495 error(type_error,GETTEXT("~S: ~S-argument ~S is not an array"));
4496 }
4497 { /* determine element type of displaced_to: */
4498 var uintB displaced_eltype = array_atype(STACK_1);
4499 /* displaced_eltype is the ATYPE of the :displaced-to argument. */
4500 /* compare given element type with it: */
4501 if (eltype != displaced_eltype) {
4502 pushSTACK(displaced_to); /* TYPE-ERROR slot DATUM */
4503 pushSTACK(S(array)); pushSTACK(STACK_(5+2));
4504 { /* TYPE-ERROR slot EXPECTED-TYPE */
4505 object exp_type = listof(2); pushSTACK(exp_type);
4506 }
4507 pushSTACK(STACK_(5+2)); /* element-type */
4508 pushSTACK(STACK_2); /* displaced_to */
4509 pushSTACK(S(Kdisplaced_to));
4510 pushSTACK(TheSubr(subr_self)->name);
4511 error(type_error,
4512 GETTEXT("~S: ~S-argument ~S does not have element type ~S"));
4513 }
4514 }
4515 /* check displaced-index-offset: */
4516 var uintV displaced_index_offset;
4517 if (!boundp(STACK_0))
4518 displaced_index_offset = 0; /* default is 0 */
4519 else if (posfixnump(STACK_0))
4520 displaced_index_offset = posfixnum_to_V(STACK_0);
4521 else {
4522 pushSTACK(STACK_0); /* TYPE-ERROR slot DATUM */
4523 pushSTACK(O(type_array_index)); /* TYPE-ERROR slot EXPECTED-TYPE */
4524 pushSTACK(STACK_(0+2));
4525 pushSTACK(S(Kdisplaced_index_offset));
4526 pushSTACK(TheSubr(subr_self)->name);
4527 error(type_error,GETTEXT("~S: ~S-argument ~S is not of type `(INTEGER 0 (,ARRAY-TOTAL-SIZE-LIMIT))"));
4528 }
4529 { /* check, if addressed sub part fits completely into displaced-to: */
4530 var uintL displaced_totalsize = array_total_size(displaced_to);
4531 if (!(displaced_index_offset+totalsize <= displaced_totalsize)) {
4532 pushSTACK(S(Kdisplaced_to));
4533 pushSTACK(fixnum(displaced_totalsize));
4534 pushSTACK(fixnum(displaced_index_offset));
4535 pushSTACK(TheSubr(subr_self)->name);
4536 error(error_condition,
4537 GETTEXT("~S: array-total-size + displaced-offset (= ~S) exceeds total size ~S of ~S-argument"));
4538 }
4539 }
4540 return displaced_index_offset;
4541 }
4542
4543 /* auxiliary routine for MAKE-ARRAY and ADJUST-ARRAY:
4544 check a fill-pointer-argument /=NIL.
4545 test_fillpointer(len)
4546 > totalsize: maximum value of fill-pointer
4547 < result: value of the fill-pointer */
test_fillpointer(uintL totalsize)4548 local uintL test_fillpointer (uintL totalsize) {
4549 /* fill-pointer was supplied and /=NIL */
4550 if (eq(STACK_2,S(t))) { /* T supplied -> */
4551 return totalsize; /* fill-pointer := length = total size */
4552 } else if (!posfixnump(STACK_2)) { /* no Fixnum >=0 -> error */
4553 pushSTACK(STACK_2); /* TYPE-ERROR slot DATUM */
4554 pushSTACK(O(type_posfixnum)); /* TYPE-ERROR slot EXPECTED-TYPE */
4555 pushSTACK(STACK_(2+2));
4556 pushSTACK(TheSubr(subr_self)->name);
4557 error(type_error,
4558 GETTEXT("~S: fill-pointer ~S should be a nonnegative fixnum"));
4559 } else {
4560 var uintV fillpointer = posfixnum_to_V(STACK_2);
4561 if (!(fillpointer <= totalsize)) { /* compare with length */
4562 pushSTACK(fixnum(totalsize));
4563 pushSTACK(STACK_(2+1));
4564 pushSTACK(TheSubr(subr_self)->name);
4565 error(error_condition,GETTEXT("~S: fill-pointer argument ~S is larger than the length ~S"));
4566 }
4567 return fillpointer;
4568 }
4569 }
4570
4571 LISPFUN(make_array,seclass_read,1,0,norest,key,7,
4572 (kw(adjustable),kw(element_type),kw(initial_element),
4573 kw(initial_contents),kw(fill_pointer),
4574 kw(displaced_to),kw(displaced_index_offset)) )
4575 /* (MAKE-ARRAY dimensions :adjustable :element-type :initial-element
4576 :initial-contents :fill-pointer :displaced-to :displaced-index-offset),
4577 CLTL p. 286
4578 stack layout:
4579 dims, adjustable, element-type, initial-element, initial-contents,
4580 fill-pointer, displaced-to, displaced-index-offset. */
4581 {
4582 /* check dimensions and calculate rank and total-size: */
4583 var uintL totalsize;
4584 var uintL rank = test_dims(&totalsize);
4585 /* adjustable has default value NIL: */
4586 if (!boundp(STACK_6))
4587 STACK_6 = NIL;
4588 /* convert element-type into a code: */
4589 var uintB eltype;
4590 if (boundp(STACK_5)) {
4591 eltype = eltype_code(STACK_5);
4592 } else { /* default value is T. */
4593 STACK_5 = S(t); eltype = Atype_T;
4594 }
4595 test_otherkeys(); /* do some other checks */
4596 var uintB flags = eltype;
4597 var uintL displaced_index_offset;
4598 var uintL fillpointer;
4599 /* if not displaced, create data vector and poss. fill: */
4600 if (nullp(STACK_1)) { /* displaced-to not supplied? */
4601 /* create data vector: */
4602 var object datenvektor = make_storagevector(totalsize,eltype);
4603 if (boundp(STACK_3)) /* and if initial-contents supplied: */
4604 datenvektor = initial_contents(datenvektor,STACK_7,rank,STACK_3); /* fill */
4605 /* if displaced-to is not supplied
4606 and fill-pointer is not supplied
4607 and adjustable is not supplied
4608 and rank=1 ,
4609 then return a (semi-)simple vector: */
4610 if ((rank==1) && nullp(STACK_6) && nullp(STACK_2) && !simple_nilarray_p(datenvektor)) {
4611 DBGREALLOC(datenvektor);
4612 VALUES1(datenvektor); /* return datenvektor */
4613 skipSTACK(8); return;
4614 }
4615 /* return a general array. */
4616 STACK_1 = datenvektor; /* store datenvektor as "displaced-to" */
4617 displaced_index_offset = 0; /* with displacement 0 */
4618 /* and without displacement-bit in the flags */
4619 } else {
4620 /* displaced-to supplied -> return a general array. */
4621 displaced_index_offset = test_displaced(eltype,totalsize);
4622 /* flags contain the displacement-bit: */
4623 flags |= bit(arrayflags_displaced_bit)|bit(arrayflags_dispoffset_bit);
4624 }
4625 /* create a general array.
4626 check rank: */
4627 if (rank > arrayrank_limit_1) {
4628 pushSTACK(fixnum(rank)); /* TYPE-ERROR slot DATUM */
4629 pushSTACK(O(type_array_rank)); /* TYPE-ERROR slot EXPECTED-TYPE */
4630 pushSTACK(fixnum(rank));
4631 pushSTACK(TheSubr(subr_self)->name);
4632 error(type_error,GETTEXT("~S: attempted rank ~S is too large"));
4633 }
4634 /* assemble flags for allocate_iarray: */
4635 /* "flags" already contains eltype and poss. displacement-bit. */
4636 if (!nullp(STACK_6)) /* adjustable supplied? */
4637 flags |= bit(arrayflags_adjustable_bit)|bit(arrayflags_dispoffset_bit);
4638 if (!nullp(STACK_2)) { /* fill-pointer supplied? */
4639 if (rank!=1) { /* rank must be 1 */
4640 pushSTACK(fixnum(rank));
4641 pushSTACK(S(Kfill_pointer));
4642 pushSTACK(TheSubr(subr_self)->name);
4643 error(error_condition,
4644 GETTEXT("~S: ~S may not be specified for an array of rank ~S"));
4645 }
4646 flags |= bit(arrayflags_fillp_bit);
4647 fillpointer = test_fillpointer(totalsize); /* fill-pointer-value */
4648 }
4649 /* determine type info for the object to create: */
4650 var tint type;
4651 if (rank==1) {
4652 /* vector: get type info from table */
4653 local const tint type_table[arrayflags_atype_mask+1] = {
4654 /* table for assignment ATYPE-byte -> vector type info */
4655 Array_type_bvector, /* Atype_Bit -> Array_type_bvector */
4656 Array_type_b2vector, /* Atype_2Bit -> Array_type_b2vector */
4657 Array_type_b4vector, /* Atype_4Bit -> Array_type_b4vector */
4658 Array_type_b8vector, /* Atype_8Bit -> Array_type_b8vector */
4659 Array_type_b16vector, /* Atype_16Bit -> Array_type_b16vector */
4660 Array_type_b32vector, /* Atype_32Bit -> Array_type_b32vector */
4661 Array_type_vector, /* Atype_T -> Array_type_vector */
4662 Array_type_string, /* Atype_Char -> Array_type_string */
4663 Array_type_string, /* Atype_NIL -> Array_type_string */
4664 Array_type_vector, /* unused yet */
4665 Array_type_vector, /* unused yet */
4666 Array_type_vector, /* unused yet */
4667 Array_type_vector, /* unused yet */
4668 Array_type_vector, /* unused yet */
4669 Array_type_vector, /* unused yet */
4670 Array_type_vector, /* unused yet */
4671 };
4672 type = type_table[eltype];
4673 } else { /* general array */
4674 type = Array_type_mdarray;
4675 }
4676 /* allocate Array: */
4677 var object array = allocate_iarray(flags,rank,type);
4678 TheIarray(array)->totalsize = totalsize; /* store total-size */
4679 {
4680 var uintL* dimptr = &TheIarray(array)->dims[0];
4681 if (flags & bit(arrayflags_dispoffset_bit))
4682 *dimptr++ = displaced_index_offset; /* store displaced-index-offset */
4683 { /* store dimensions: */
4684 var object dims = STACK_7;
4685 if (listp(dims)) {
4686 while (consp(dims)) {
4687 *dimptr++ = posfixnum_to_V(Car(dims)); dims = Cdr(dims);
4688 }
4689 } else {
4690 *dimptr++ = posfixnum_to_V(dims);
4691 }
4692 }
4693 /* poss. store fill-pointer: */
4694 if (flags & bit(arrayflags_fillp_bit))
4695 /* fill-pointer was supplied and /=NIL */
4696 *dimptr++ = fillpointer;
4697 }
4698 /* store data vector: */
4699 TheIarray(array)->data = STACK_1; /* displaced-to-Argument or new data vector */
4700 /* array as value: */
4701 VALUES1(array); skipSTACK(8);
4702 }
4703
4704 /* ======================================================================== */
4705 /* ADJUST-ARRAY */
4706
4707 /* auxiliary function for the filling task with ADJUST-ARRAY:
4708 Fills the data vector of an array partly with the content of another
4709 data vector, so that the elements for index tuples, that are valid
4710 for both arrays, match.
4711 reshape(newvec,newdims,oldvec,olddims,offset,rank,eltype);
4712 > newvec: simple vector, target for filling.
4713 > newdims: dimension(s) of the array,
4714 in which newvec is the data vector (with offset 0).
4715 > oldvec: simple vector, source for filling.
4716 > olddims: pointer to the dimensions of the array,
4717 in which oldvec is the data vector (with offset offset).
4718 > rank: dimension number of newdims = dimension number of olddims.
4719 > eltype: element type of newvec = element type of oldvec.
4720 method: pseudo-recursive, with pseudo-stack, that is placed below STACK. */
4721 typedef struct {
4722 uintL olddim; /* dimension of olddims */
4723 uintL newdim; /* dimension of newdims */
4724 uintL mindim; /* minimum dimensions of both */
4725 uintL subscript; /* subscript, runs from 0 to mindim-1 */
4726 uintL oldindex; /* row-major-index in oldvec */
4727 uintL newindex; /* row-major-index in newvec */
4728 uintL olddelta; /* increment of oldindex for subscript++ */
4729 uintL newdelta; /* increment of newindex for subscript++ */
4730 } reshape_data_t;
reshape(object newvec,object newdims,object oldvec,const uintL * olddims,uintL offset,uintL rank,uintB eltype)4731 local void reshape (object newvec, object newdims, object oldvec,
4732 const uintL* olddims, uintL offset, uintL rank,
4733 uintB eltype) {
4734 /* get space for the pseudo-stack: */
4735 get_space_on_STACK(rank*sizeof(reshape_data_t));
4736 /* starting point: */
4737 var reshape_data_t* reshape_stack = &STACKblock_(reshape_data_t,-1);
4738 /* fill pseudo-stack: */
4739 if (rank!=0) {
4740 var reshape_data_t* ptr;
4741 var uintC count;
4742 /* store newdim: */
4743 ptr = reshape_stack;
4744 if (consp(newdims)) {
4745 dotimespC(count,rank, {
4746 ptr->newdim = posfixnum_to_V(Car(newdims)); newdims = Cdr(newdims);
4747 ptr = ptr STACKop -1;
4748 });
4749 } else {
4750 ptr->newdim = posfixnum_to_V(newdims);
4751 }
4752 /* store olddim and mindim: */
4753 ptr = reshape_stack;
4754 dotimespC(count,rank, {
4755 var uintL olddim;
4756 var uintL newdim;
4757 olddim = ptr->olddim = *olddims++;
4758 newdim = ptr->newdim;
4759 ptr->mindim = (olddim<newdim ? olddim : newdim);
4760 ptr = ptr STACKop -1;
4761 });
4762 { /* store olddelta and newdelta: */
4763 var uintL olddelta = 1;
4764 var uintL newdelta = 1;
4765 dotimespC(count,rank, {
4766 ptr = ptr STACKop 1;
4767 ptr->olddelta = olddelta;
4768 olddelta = mulu32_unchecked(olddelta,ptr->olddim);
4769 ptr->newdelta = newdelta;
4770 newdelta = mulu32_unchecked(newdelta,ptr->newdim);
4771 });
4772 }
4773 }
4774 /* Start of pseudo-recursion: */
4775 var reshape_data_t* ptr = reshape_stack;
4776 var uintL oldindex = offset; /* row-major-index in oldvec */
4777 var uintL newindex = 0; /* row-major-index in newvec */
4778 var uintL depth = rank;
4779 entry: /* entry for recursion */
4780 if (depth==0) {
4781 /* copy element:
4782 (setf (aref newvec newindex) (aref oldvec oldindex))
4783 copy so that no GC can be triggered: */
4784 if (eltype == Atype_32Bit) {
4785 ((uint32*)&TheSbvector(newvec)->data[0])[newindex]
4786 = ((uint32*)&TheSbvector(oldvec)->data[0])[oldindex];
4787 } else {
4788 storagevector_store(newvec,newindex,storagevector_aref(oldvec,oldindex),false);
4789 }
4790 } else if (depth==1) {
4791 /* optimization: copy a complete row of elements
4792 (notice: ptr->olddelta = ptr->newdelta = 1). */
4793 if (ptr->mindim > 0)
4794 elt_copy(oldvec,oldindex,newvec,newindex,ptr->mindim);
4795 } else {
4796 /* loop over all shared indices: */
4797 ptr->oldindex = oldindex; ptr->newindex = newindex;
4798 if (ptr->mindim > 0) {
4799 depth--;
4800 dotimespL(ptr->subscript,ptr->mindim, {
4801 oldindex = ptr->oldindex; newindex = ptr->newindex;
4802 ptr = ptr STACKop -1;
4803 goto entry;
4804 reentry:
4805 ptr = ptr STACKop 1;
4806 ptr->oldindex += ptr->olddelta;
4807 ptr->newindex += ptr->newdelta;
4808 });
4809 depth++;
4810 }
4811 }
4812 /* exit from recursion: */
4813 if (depth<rank)
4814 goto reentry;
4815 }
4816
4817 /* (ADJUST-ARRAY array dimensions :element-type :initial-element
4818 :initial-contents :fill-pointer :displaced-to :displaced-index-offset),
4819 CLTL p. 297 */
4820 LISPFUN(adjust_array,seclass_default,2,0,norest,key,6,
4821 (kw(element_type),kw(initial_element),
4822 kw(initial_contents),kw(fill_pointer),
4823 kw(displaced_to),kw(displaced_index_offset)) )
4824 {
4825 var uintL totalsize, rank;
4826 { /* check the array : */
4827 var object array = check_array(STACK_7);
4828 STACK_7 = STACK_6; STACK_6 = array; /* for test_dims() */
4829 /* check dimensions and rank and compute total-size: */
4830 rank = test_dims(&totalsize);
4831 { /* check rank, must be == (array-rank array): */
4832 var uintL oldrank = array_simplep(STACK_6) ? 1
4833 : (uintL)Iarray_rank(STACK_6);
4834 if (rank != oldrank) {
4835 pushSTACK(STACK_7); /* dims */
4836 pushSTACK(STACK_(6+1)); /* array */
4837 pushSTACK(fixnum(oldrank));
4838 pushSTACK(TheSubr(subr_self)->name);
4839 error(error_condition,GETTEXT("~S: rank ~S of array ~S cannot be altered: ~S"));
4840 }
4841 }
4842 }
4843 /* stack layout:
4844 dims, array, element-type, initial-element, initial-contents,
4845 fill-pointer, displaced-to, displaced-index-offset. */
4846 /* check element-type and convert it into code: */
4847 var uintB eltype;
4848 if (boundp(STACK_5)) {
4849 eltype = eltype_code(STACK_5);
4850 /* compare with the element-type of the array argument */
4851 if (eltype != array_atype(STACK_6)) {
4852 pushSTACK(STACK_6); /* TYPE-ERROR slot DATUM */
4853 pushSTACK(S(array)); pushSTACK(STACK_(5+2));
4854 { /* TYPE-ERROR slot EXPECTED-TYPE */
4855 object exp_type = listof(2); pushSTACK(exp_type); }
4856 pushSTACK(STACK_(5+2)); /* element-type */
4857 pushSTACK(STACK_(6+3)); /* array */
4858 pushSTACK(TheSubr(subr_self)->name);
4859 error(type_error,GETTEXT("~S: array ~S does not have element-type ~S"));
4860 }
4861 } else { /* default is the element-type of the array-argument */
4862 eltype = array_atype(STACK_6);
4863 STACK_5 = array_element_type(STACK_6);
4864 }
4865 if (array_simplep(STACK_6)
4866 || ((Iarray_flags(STACK_6) & bit(arrayflags_adjustable_bit)) == 0)) {
4867 /* not an adjustable array ==> new array
4868 if no :initial-contents and no :displaced-to, copy contents */
4869 var bool copy_p = !boundp(STACK_3) && missingp(STACK_1);
4870 var object array = STACK_6;
4871 var bool has_fill_p = array_has_fill_pointer_p(array);
4872 if (!has_fill_p && !missingp(STACK_2))
4873 error_no_fillp(array);
4874 pushSTACK(STACK_1); pushSTACK(STACK_1);
4875 /* :FILL-POINTER NIL means keep it as it was */
4876 STACK_2 = (!missingp(STACK_4) ? (object)STACK_4 :
4877 has_fill_p ? fixnum(*get_fill_pointer(array)) : NIL);
4878 STACK_3 = STACK_5; STACK_4 = STACK_6; STACK_5 = STACK_7;
4879 STACK_6 = NIL; /* :ADJUSTABLE NIL */
4880 STACK_7 = STACK_9; /* dims */
4881 STACK_8 = array; /* save array */
4882 C_make_array(); /* MAKE-ARRAY with all the args but first */
4883 /* stack layout: dims, array */
4884 if (copy_p) {
4885 var uintL offset1 = 0;
4886 var object dv1 = /* original: may be simple! */
4887 array_displace_check(STACK_0,array_total_size(STACK_0),&offset1);
4888 var uintL offset2 = 0;
4889 var object dv2 = /* new: may be simple! */
4890 array_displace_check(value1,totalsize,&offset2);
4891 var uintL* dimptr;
4892 if (array_simplep(STACK_0)) {
4893 if (simple_string_p(STACK_0)) {
4894 sstring_un_realloc(STACK_0);
4895 offset2 = Sstring_length(STACK_0);
4896 } else
4897 offset2 = Sarray_length(STACK_0);
4898 dimptr = &offset2;
4899 } else {
4900 dimptr = &TheIarray(STACK_0)->dims[0];
4901 if (Iarray_flags(STACK_0) & bit(arrayflags_dispoffset_bit))
4902 dimptr++;
4903 /* use DIMENSION, not FILL-POINTER! */
4904 }
4905 reshape(dv2,STACK_1,dv1,dimptr,offset1,rank,eltype);
4906 }
4907 skipSTACK(2); /* drop array & new dimensions */
4908 return;
4909 }
4910 test_otherkeys(); /* do some other checks */
4911 var uintB flags = Iarray_flags(STACK_6);
4912 /* the Flags contain exactly eltype as Atype and
4913 arrayflags_adjustable_bit and thus also
4914 arrayflags_dispoffset_bit and maybe also arrayflags_fillp_bit
4915 (these will not be modified) and maybe also
4916 arrayflags_displaced_bit (this can be modified). */
4917 var uintL displaced_index_offset;
4918 var uintL fillpointer;
4919 /* if not displaced, create data vector and poss. fill: */
4920 if (nullp(STACK_1)) { /* displaced-to not supplied? */
4921 var object datenvektor;
4922 if (boundp(STACK_3)) { /* and if initial-contents supplied: */
4923 /* create data vector: */
4924 datenvektor = make_storagevector(totalsize,eltype);
4925 /* fill with the initial-contents argument: */
4926 datenvektor = initial_contents(datenvektor,STACK_7,rank,STACK_3);
4927 } else { /* create data vector: */
4928 #ifdef HAVE_SMALL_SSTRING
4929 /* a special case to preserve Sstringtype_8/16/32bit */
4930 if (eltype == Atype_Char) {
4931 check_stringsize(totalsize);
4932 var uintL oldoffset = 0;
4933 var object olddatenvektor = iarray_displace_check(STACK_6,0,&oldoffset);
4934 SstringCase(olddatenvektor,
4935 { datenvektor = allocate_s8string(totalsize); },
4936 { datenvektor = allocate_s16string(totalsize); },
4937 { datenvektor = allocate_s32string(totalsize); },
4938 { NOTREACHED; });
4939 datenvektor = fill_initial_element(totalsize,datenvektor);
4940 } else
4941 #endif
4942 datenvektor = make_storagevector(totalsize,eltype);
4943 /* fill with the original content of array: */
4944 var object oldarray = STACK_6; /* array */
4945 var uintL oldoffset = 0;
4946 var object oldvec =
4947 iarray_displace_check(oldarray,TheIarray(oldarray)->totalsize,
4948 &oldoffset);
4949 /* oldvec is the data vector, with displaced-offset oldoffset. */
4950 var uintL* olddimptr = &TheIarray(oldarray)->dims[1];
4951 /* At olddimptr are the old dimensions of array
4952 (notice: As arrayflags_adjustable_bit is set, also
4953 arrayflags_dispoffset_bit is set, thus
4954 TheIarray(array)->data[0] is reserved for the displaced-offset.) */
4955 reshape(datenvektor,STACK_7,oldvec,olddimptr,oldoffset,rank,eltype);
4956 }
4957 STACK_1 = datenvektor; /* store data vector as "displaced-to" */
4958 displaced_index_offset = 0; /* with displacement 0 */
4959 flags &= ~bit(arrayflags_displaced_bit); /* and without displacement-bit in the flags */
4960 } else {
4961 /* displaced-to supplied. */
4962 displaced_index_offset = test_displaced(eltype,totalsize);
4963 { /* test for accruing cycle: */
4964 var object array = STACK_6; /* array, that has to be displaced */
4965 var object to_array = STACK_1; /* array, to which displacement takes place */
4966 /* test, if array occurs in the data vector chain of to_array: */
4967 while (1) {
4968 /* if array = to_array, we have a cycle. */
4969 if (eq(array,to_array)) {
4970 pushSTACK(array);
4971 pushSTACK(TheSubr(subr_self)->name);
4972 error(error_condition,GETTEXT("~S: cannot displace array ~S to itself"));
4973 }
4974 /* if to_array is simple (thus not displaced), */
4975 /* there is no cycle. */
4976 if (simplep(to_array))
4977 break;
4978 /* follow displaced-chain of to_array: */
4979 to_array = TheIarray(to_array)->data;
4980 }
4981 }
4982 /* flags contain the displacement-bit: */
4983 flags |= bit(arrayflags_displaced_bit);
4984 }
4985 /* flags are now correct. */
4986 /* modify the given array. */
4987 if (!nullp(STACK_2)) { /* fill-pointer supplied? */
4988 /* array must have fill-pointer: */
4989 if (!(Iarray_flags(STACK_6) & bit(arrayflags_fillp_bit)))
4990 error_no_fillp(STACK_6);
4991 fillpointer = test_fillpointer(totalsize); /* fill-pointer-value */
4992 } else {
4993 /* If array has a fill-pointer, it must be <= the new total-size: */
4994 var object array = STACK_6;
4995 if (Iarray_flags(array) & bit(arrayflags_fillp_bit))
4996 if (!(TheIarray(array)->dims[2] <= totalsize)) {
4997 /* dims[0] = displaced-offset, dims[1] = length, dims[2] = fill-pointer */
4998 pushSTACK(fixnum(totalsize));
4999 pushSTACK(fixnum(TheIarray(array)->dims[2]));
5000 pushSTACK(array);
5001 pushSTACK(TheSubr(subr_self)->name);
5002 error(error_condition,
5003 GETTEXT("~S: the fill-pointer of array ~S is ~S, greater than ~S"));
5004 }
5005 }
5006 { /* modify array: */
5007 var object array = STACK_6;
5008 set_break_sem_1(); /* forbid interrupts */
5009 iarray_flags_replace(TheIarray(array),flags); /* store new flags */
5010 TheIarray(array)->totalsize = totalsize; /* store new total-size */
5011 {
5012 var uintL* dimptr = &TheIarray(array)->dims[0];
5013 *dimptr++ = displaced_index_offset; /* store displaced-index-offset */
5014 { /* store new dimensions: */
5015 var object dims = STACK_7;
5016 if (listp(dims)) {
5017 while (consp(dims)) {
5018 *dimptr++ = posfixnum_to_V(Car(dims)); dims = Cdr(dims);
5019 }
5020 } else {
5021 *dimptr++ = posfixnum_to_V(dims);
5022 }
5023 }
5024 /* poss. store fill-pointer resp. correct it: */
5025 if (flags & bit(arrayflags_fillp_bit)) /* array with fill-pointer? */
5026 if (!nullp(STACK_2)) /* is fill-pointer supplied? */
5027 /* fill-pointer was supplied and /=NIL */
5028 *dimptr = fillpointer;
5029 }
5030 /* store data vector: */
5031 TheIarray(array)->data = STACK_1; /* displaced-to-argument or new data vector */
5032 clr_break_sem_1(); /* permit interrupts again */
5033 /* array as value: */
5034 VALUES1(array); skipSTACK(8);
5035 }
5036 }
5037
5038 /* ======================================================================== */
5039 /* Arrays as sequences */
5040
5041 /* functions, that turn vectors into sequences: */
5042
5043 LISPFUNN(vector_init,1) /* #'(lambda (seq) 0) */
5044 {
5045 skipSTACK(1);
5046 VALUES1(Fixnum_0);
5047 }
5048
5049 LISPFUNN(vector_upd,2)
5050 { /* #'(lambda (seq pointer) (1+ pointer)) */
5051 if (posfixnump(STACK_0)) {
5052 var object newpointer = fixnum_inc(STACK_0,1); /* increase Fixnum >=0 by 1 */
5053 if (posfixnump(newpointer)) {
5054 /* remained a Fixnum >=0 */
5055 skipSTACK(2);
5056 VALUES1(newpointer);
5057 return;
5058 }
5059 }
5060 /* pointer is before or after the increment not a Fixnum >=0 */
5061 funcall(L(plus_one),1); /* (1+ pointer) as value */
5062 skipSTACK(1);
5063 }
5064
5065 LISPFUNN(vector_endtest,2)
5066 { /* #'(lambda (seq pointer) (= pointer (vector-length seq))) */
5067 var object seq = check_vector(STACK_1);
5068 VALUES_IF(eq(fixnum(vector_length(seq)),STACK_0));
5069 skipSTACK(2);
5070 }
5071
5072 LISPFUNN(vector_fe_init,1)
5073 { /* #'(lambda (seq) (1- (vector-length seq))) */
5074 var object seq = check_vector(popSTACK());
5075 var uintL len = vector_length(seq);
5076 /* len = (vector-length seq) as Fixnum, and decrease by 1: */
5077 VALUES1(len==0 ? Fixnum_minus1 : fixnum(len-1));
5078 }
5079
5080 LISPFUNN(vector_fe_upd,2)
5081 { /* #'(lambda (seq pointer) (1- pointer)) */
5082 if (posfixnump(STACK_0)) {
5083 var object pointer = popSTACK();
5084 VALUES1(eq(pointer,Fixnum_0)
5085 ? Fixnum_minus1
5086 : fixnum_inc(pointer,-1)); /* Fixnum >0 decrement by 1 */
5087 } else {
5088 /* pointer is before or after the decrement not a Fixnum >=0 */
5089 funcall(L(minus_one),1); /* (1- pointer) as value */
5090 }
5091 skipSTACK(1);
5092 }
5093
5094 LISPFUNN(vector_fe_endtest,2)
5095 { /* #'(lambda (seq pointer) (minusp pointer)) */
5096 VALUES_IF(! positivep(STACK_0)); /* return the sign of pointer */
5097 skipSTACK(2);
5098 }
5099
5100 LISPFUNN(vector_length,1)
5101 {
5102 VALUES1(fixnum(vector_length(check_vector(popSTACK()))));
5103 }
5104
5105 LISPFUNN(vector_init_start,2)
5106 { /* #'(lambda (seq index)
5107 (if (<= 0 index (vector-length seq))
5108 index
5109 (error "Illegal :START - Index : ~S" index))) */
5110 var object seq = check_vector(STACK_1);
5111 var uintL len = vector_length(seq);
5112 /* index should be a Fixnum between 0 and len (inclusive) : */
5113 if (posfixnump(STACK_0) && (posfixnum_to_V(STACK_0)<=len)) {
5114 VALUES1(STACK_0); skipSTACK(2); /* return index */
5115 } else {
5116 /* stack layout: seq, index. */
5117 pushSTACK(STACK_0); /* TYPE-ERROR slot DATUM */
5118 {
5119 var object tmp;
5120 pushSTACK(S(integer)); pushSTACK(Fixnum_0); pushSTACK(UL_to_I(len));
5121 tmp = listof(3); pushSTACK(tmp); /* TYPE-ERROR slot EXPECTED-TYPE */
5122 }
5123 pushSTACK(STACK_3); /* seq */
5124 pushSTACK(STACK_3); /* index */
5125 error(type_error,GETTEXT("Illegal START index ~S for ~S"));
5126 }
5127 }
5128
5129 LISPFUNN(vector_fe_init_end,2)
5130 { /* #'(lambda (seq index)
5131 (if (<= 0 index (vector-length seq))
5132 (1- index)
5133 (error "Illegal :END - Index : ~S" index))) */
5134 var object seq = check_vector(STACK_1);
5135 var uintL len = vector_length(seq);
5136 /* index should be a Fixnum between 0 and len (inclusive) : */
5137 if (posfixnump(STACK_0) && (posfixnum_to_V(STACK_0)<=len)) {
5138 var object index = STACK_0;
5139 skipSTACK(2);
5140 VALUES1(eq(index,Fixnum_0)
5141 ? Fixnum_minus1
5142 : fixnum_inc(index,-1)); /* Fixnum >0 decrement by 1 */
5143 } else {
5144 /* stack layout: seq, index. */
5145 pushSTACK(STACK_0); /* TYPE-ERROR slot DATUM */
5146 {
5147 var object tmp;
5148 pushSTACK(S(integer)); pushSTACK(Fixnum_0); pushSTACK(UL_to_I(len));
5149 tmp = listof(3); pushSTACK(tmp); /* TYPE-ERROR slot EXPECTED-TYPE */
5150 }
5151 pushSTACK(STACK_3); /* seq */
5152 pushSTACK(STACK_3); /* index */
5153 error(type_error,GETTEXT("Illegal END index ~S for ~S"));
5154 }
5155 }
5156
5157 LISPFUNN(make_bit_vector,1)
5158 { /* (SYS::MAKE-BIT-VECTOR size) returns a Bit-Vector with size bits. */
5159 var uintL size;
5160 if (!posfixnump(STACK_0)) {
5161 bad_size:
5162 /* STACK_0 = size, TYPE-ERROR slot DATUM */
5163 pushSTACK(O(type_array_length)); /* TYPE-ERROR slot EXPECTED-TYPE */
5164 pushSTACK(STACK_1); /* size */
5165 pushSTACK(TheSubr(subr_self)->name);
5166 error(type_error,GETTEXT("~S: invalid bit-vector length ~S"));
5167 }
5168 var uintV size = posfixnum_to_V(STACK_0); /* length */
5169 #if (intVsize>intLsize)
5170 if (size >= vbit(intLsize)) goto bad_size;
5171 #endif
5172 VALUES1(allocate_bit_vector(Atype_Bit,size)); /* return a bit-vector */
5173 skipSTACK(1);
5174 }
5175