1 /* Array manipulation routines for S-Lang */
2 /*
3 Copyright (C) 2004-2017,2018 John E. Davis
4
5 This file is part of the S-Lang Library.
6
7 The S-Lang Library is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public License as
9 published by the Free Software Foundation; either version 2 of the
10 License, or (at your option) any later version.
11
12 The S-Lang Library is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this library; if not, write to the Free Software
19 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
20 USA.
21 */
22
23 #include "slinclud.h"
24 #include <math.h>
25
26 /* #define SL_APP_WANTS_FOREACH */
27 #include "slang.h"
28 #include "_slang.h"
29
30 typedef struct Range_Array_Type SLarray_Range_Array_Type;
31
32 struct Range_Array_Type
33 {
34 SLindex_Type first_index;
35 SLindex_Type last_index;
36 SLindex_Type delta;
37 int has_first_index;
38 int has_last_index;
39 int (*to_linear_fun) (SLang_Array_Type *, SLarray_Range_Array_Type *, VOID_STAR);
40 };
41
42 static SLang_Array_Type *inline_implicit_index_array (SLindex_Type *, SLindex_Type *, SLindex_Type *);
43
44 /* Use SLang_pop_array when a linear array is required. */
pop_array(SLang_Array_Type ** at_ptr,int convert_scalar)45 static int pop_array (SLang_Array_Type **at_ptr, int convert_scalar)
46 {
47 SLang_Array_Type *at;
48 SLindex_Type one = 1;
49 int type;
50
51 *at_ptr = NULL;
52 type = SLang_peek_at_stack ();
53
54 switch (type)
55 {
56 case -1:
57 return -1;
58
59 case SLANG_ARRAY_TYPE:
60 return SLclass_pop_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR *) at_ptr);
61
62 case SLANG_NULL_TYPE:
63 /* convert_scalar = 0; */ /* commented out for 2.0.5 to fix array_map NULL bug */
64 /* drop */
65 default:
66 if (convert_scalar == 0)
67 {
68 SLdo_pop ();
69 _pSLang_verror (SL_TYPE_MISMATCH, "Context requires an array. Scalar not converted");
70 return -1;
71 }
72 break;
73 }
74
75 if (NULL == (at = SLang_create_array ((SLtype) type, 0, NULL, &one, 1)))
76 return -1;
77
78 if (at->flags & SLARR_DATA_VALUE_IS_POINTER)
79 {
80 /* The act of creating the array could have initialized the array
81 * with pointers to an object of the type. For example, this could
82 * happen with user-defined structs.
83 */
84 if (*(VOID_STAR *)at->data != NULL)
85 {
86 at->cl->cl_destroy ((SLtype) type, at->data);
87 *(VOID_STAR *) at->data = NULL;
88 }
89 }
90
91 if (-1 == at->cl->cl_apop ((SLtype) type, at->data))
92 {
93 SLang_free_array (at);
94 return -1;
95 }
96 at->flags |= SLARR_DERIVED_FROM_SCALAR;
97 *at_ptr = at;
98
99 return 0;
100 }
101
throw_size_error(int e)102 static void throw_size_error (int e)
103 {
104 _pSLang_verror (e, "Unable to create a multi-dimensional array of the desired size");
105 }
106
linear_get_data_addr(SLang_Array_Type * at,SLindex_Type * dims)107 static VOID_STAR linear_get_data_addr (SLang_Array_Type *at, SLindex_Type *dims)
108 {
109 size_t ofs;
110
111 if (at->num_dims == 1)
112 {
113 if (*dims < 0)
114 ofs = (size_t) (*dims + at->dims[0]);
115 else
116 ofs = (size_t)*dims;
117 }
118 else
119 {
120 unsigned int i;
121 SLindex_Type *max_dims = at->dims;
122 unsigned int num_dims = at->num_dims;
123 ofs = 0;
124 for (i = 0; i < num_dims; i++)
125 {
126 size_t new_ofs;
127 SLindex_Type d = dims[i];
128 if (d < 0)
129 d = d + max_dims[i];
130
131 new_ofs = ofs * (size_t)max_dims [i] + (size_t) d;
132 if ((max_dims[i] != 0)
133 && ((new_ofs - (size_t)d)/max_dims[i] != ofs))
134 {
135 throw_size_error (SL_Index_Error);
136 return NULL;
137 }
138 ofs = new_ofs;
139 }
140 }
141 if (ofs >= at->num_elements)
142 {
143 SLang_set_error (SL_Index_Error);
144 return NULL;
145 }
146 return (VOID_STAR) ((char *)at->data + (ofs * at->sizeof_type));
147 }
148
149 _INLINE_
get_data_addr(SLang_Array_Type * at,SLindex_Type * dims)150 static VOID_STAR get_data_addr (SLang_Array_Type *at, SLindex_Type *dims)
151 {
152 VOID_STAR data;
153
154 data = at->data;
155 if (data == NULL)
156 {
157 _pSLang_verror (SL_UNKNOWN_ERROR, "Array has no data");
158 return NULL;
159 }
160
161 data = (*at->index_fun) (at, dims);
162
163 if (data == NULL)
164 {
165 _pSLang_verror (SL_UNKNOWN_ERROR, "Unable to access array element");
166 return NULL;
167 }
168
169 return data;
170 }
171
_pSLarray_free_array_elements(SLang_Class_Type * cl,VOID_STAR s,SLuindex_Type num)172 void _pSLarray_free_array_elements (SLang_Class_Type *cl, VOID_STAR s, SLuindex_Type num)
173 {
174 size_t sizeof_type;
175 void (*f) (SLtype, VOID_STAR);
176 char *p;
177 SLtype type;
178
179 if ((cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
180 || (cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR))
181 return;
182
183 f = cl->cl_destroy;
184 sizeof_type = cl->cl_sizeof_type;
185 type = cl->cl_data_type;
186
187 p = (char *) s;
188 while (num != 0)
189 {
190 if (NULL != *(VOID_STAR *)p)
191 {
192 (*f) (type, (VOID_STAR)p);
193 *(VOID_STAR *) p = NULL;
194 }
195 p += sizeof_type;
196 num--;
197 }
198 }
199
destroy_element(SLang_Array_Type * at,SLindex_Type * dims,VOID_STAR data)200 static int destroy_element (SLang_Array_Type *at,
201 SLindex_Type *dims,
202 VOID_STAR data)
203 {
204 data = get_data_addr (at, dims);
205 if (data == NULL)
206 return -1;
207
208 /* This function should only get called for arrays that have
209 * pointer elements. Do not call the destroy method if the element
210 * is NULL.
211 */
212 if (NULL != *(VOID_STAR *)data)
213 {
214 (*at->cl->cl_destroy) (at->data_type, data);
215 *(VOID_STAR *) data = NULL;
216 }
217 return 0;
218 }
219
220 /* This function only gets called when a new array is created. Thus there
221 * is no need to destroy the object first.
222 */
new_object_element(SLang_Array_Type * at,SLindex_Type * dims,VOID_STAR data)223 static int new_object_element (SLang_Array_Type *at,
224 SLindex_Type *dims,
225 VOID_STAR data)
226 {
227 data = get_data_addr (at, dims);
228 if (data == NULL)
229 return -1;
230
231 return (*at->cl->cl_init_array_object) (at->data_type, data);
232 }
233
_pSLarray_next_index(SLindex_Type * dims,SLindex_Type * max_dims,unsigned int num_dims)234 int _pSLarray_next_index (SLindex_Type *dims, SLindex_Type *max_dims, unsigned int num_dims)
235 {
236 while (num_dims)
237 {
238 SLindex_Type dims_i;
239
240 num_dims--;
241
242 dims_i = dims [num_dims] + 1;
243 if (dims_i < (int) max_dims [num_dims])
244 {
245 dims [num_dims] = dims_i;
246 return 0;
247 }
248 dims [num_dims] = 0;
249 }
250
251 return -1;
252 }
253
do_method_for_all_elements(SLang_Array_Type * at,int (* method)(SLang_Array_Type *,SLindex_Type *,VOID_STAR),VOID_STAR client_data)254 static int do_method_for_all_elements (SLang_Array_Type *at,
255 int (*method)(SLang_Array_Type *,
256 SLindex_Type *,
257 VOID_STAR),
258 VOID_STAR client_data)
259 {
260 SLindex_Type dims [SLARRAY_MAX_DIMS];
261 SLindex_Type *max_dims;
262 unsigned int num_dims;
263
264 if (at->num_elements == 0)
265 return 0;
266
267 max_dims = at->dims;
268 num_dims = at->num_dims;
269
270 SLMEMSET((char *)dims, 0, sizeof(dims));
271
272 do
273 {
274 if (-1 == (*method) (at, dims, client_data))
275 return -1;
276 }
277 while (0 == _pSLarray_next_index (dims, max_dims, num_dims));
278
279 return 0;
280 }
281
free_array(SLang_Array_Type * at)282 static void free_array (SLang_Array_Type *at)
283 {
284 unsigned int flags;
285
286 if (at == NULL) return;
287
288 if (at->num_refs > 1)
289 {
290 at->num_refs -= 1;
291 return;
292 }
293
294 flags = at->flags;
295
296 if (flags & SLARR_DATA_VALUE_IS_INTRINSIC)
297 return; /* not to be freed */
298
299 if (flags & SLARR_DATA_VALUE_IS_POINTER)
300 (void) do_method_for_all_elements (at, destroy_element, NULL);
301
302 if (at->free_fun != NULL)
303 at->free_fun (at);
304 else
305 SLfree ((char *) at->data);
306
307 SLfree ((char *) at);
308 }
309
SLang_free_array(SLang_Array_Type * at)310 void SLang_free_array (SLang_Array_Type *at)
311 {
312 free_array (at);
313 }
314
315 SLang_Array_Type *
SLang_create_array1(SLtype type,int read_only,VOID_STAR data,SLindex_Type * dims,unsigned int num_dims,int no_init)316 SLang_create_array1 (SLtype type, int read_only, VOID_STAR data,
317 SLindex_Type *dims, unsigned int num_dims, int no_init)
318 {
319 SLang_Class_Type *cl;
320 SLang_Array_Type *at;
321 unsigned int i;
322 SLindex_Type num_elements;
323 SLindex_Type size;
324 int sizeof_type;
325
326 if ((num_dims == 0) || (num_dims > SLARRAY_MAX_DIMS))
327 {
328 _pSLang_verror (SL_NOT_IMPLEMENTED, "%u dimensional arrays are not supported", num_dims);
329 return NULL;
330 }
331
332 for (i = 0; i < num_dims; i++)
333 {
334 if (dims[i] < 0)
335 {
336 _pSLang_verror (SL_INVALID_PARM, "Size of array dim %u is less than 0", i);
337 return NULL;
338 }
339 }
340
341 cl = _pSLclass_get_class (type);
342
343 at = (SLang_Array_Type *) SLmalloc (sizeof(SLang_Array_Type));
344 if (at == NULL)
345 return NULL;
346
347 memset ((char*) at, 0, sizeof(SLang_Array_Type));
348
349 at->data_type = type;
350 at->cl = cl;
351 at->num_dims = num_dims;
352 at->num_refs = 1;
353
354 if (read_only) at->flags = SLARR_DATA_VALUE_IS_READ_ONLY;
355
356 if ((cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR)
357 && (cl->cl_class_type != SLANG_CLASS_TYPE_VECTOR))
358 at->flags |= SLARR_DATA_VALUE_IS_POINTER;
359
360 /* The elements of an array must be addressable by a single index of
361 * SLindex_Type, even for multi-dimensional arrays. E.g.,
362 * a = Int_Type[m, n];
363 * i = where (a < 0);
364 * a[i] = 0;
365 */
366 num_elements = 1;
367 for (i = 0; i < num_dims; i++)
368 {
369 SLindex_Type new_num_elements;
370 at->dims[i] = dims[i];
371 new_num_elements = dims[i] * num_elements;
372 if (dims[i] && (new_num_elements/dims[i] != num_elements))
373 {
374 throw_size_error (SL_Index_Error);
375 free_array (at);
376 return NULL;
377 }
378 num_elements = new_num_elements;
379 }
380
381 /* Now set the rest of the unused dimensions to 1. This makes it easier
382 * when transposing arrays and when indexing arrays derived from scalars.
383 */
384 while (i < SLARRAY_MAX_DIMS)
385 at->dims[i++] = 1;
386
387 at->num_elements = num_elements;
388 at->index_fun = linear_get_data_addr;
389 sizeof_type = (int) cl->cl_sizeof_type;
390 at->sizeof_type = (unsigned int) sizeof_type;
391
392 if (data != NULL)
393 {
394 at->data = data;
395 return at;
396 }
397
398 size = (num_elements * sizeof_type);
399 if ((size/sizeof_type != num_elements) || (size < 0))
400 {
401 throw_size_error (SL_INVALID_PARM);
402 free_array (at);
403 return NULL;
404 }
405
406 if (size == 0) size = 1;
407
408 if (NULL == (data = (VOID_STAR) SLmalloc (size)))
409 {
410 free_array (at);
411 return NULL;
412 }
413
414 at->data = data;
415
416 if ((no_init == 0) || (at->flags & SLARR_DATA_VALUE_IS_POINTER))
417 memset ((char *) data, 0, size);
418
419 if ((no_init == 0)
420 && (cl->cl_init_array_object != NULL)
421 && (-1 == do_method_for_all_elements (at, new_object_element, NULL)))
422 {
423 free_array (at);
424 return NULL;
425 }
426
427 return at;
428 }
429
430 SLang_Array_Type *
SLang_create_array(SLtype type,int read_only,VOID_STAR data,SLindex_Type * dims,unsigned int num_dims)431 SLang_create_array (SLtype type, int read_only, VOID_STAR data,
432 SLindex_Type *dims, unsigned int num_dims)
433 {
434 return SLang_create_array1 (type, read_only, data, dims, num_dims, 0);
435 }
436
SLang_add_intrinsic_array(SLFUTURE_CONST char * name,SLtype type,int read_only,VOID_STAR data,unsigned int num_dims,...)437 int SLang_add_intrinsic_array (SLFUTURE_CONST char *name,
438 SLtype type,
439 int read_only,
440 VOID_STAR data,
441 unsigned int num_dims, ...)
442 {
443 va_list ap;
444 unsigned int i;
445 SLindex_Type dims[SLARRAY_MAX_DIMS];
446 SLang_Array_Type *at;
447
448 if ((num_dims > SLARRAY_MAX_DIMS)
449 || (name == NULL)
450 || (data == NULL))
451 {
452 _pSLang_verror (SL_INVALID_PARM, "Unable to create intrinsic array");
453 return -1;
454 }
455
456 va_start (ap, num_dims);
457 for (i = 0; i < num_dims; i++)
458 dims [i] = va_arg (ap, int);
459 va_end (ap);
460
461 at = SLang_create_array (type, read_only, data, dims, num_dims);
462 if (at == NULL)
463 return -1;
464 at->flags |= SLARR_DATA_VALUE_IS_INTRINSIC;
465
466 /* Note: The variable that refers to the intrinsic array is regarded as
467 * read-only. That way, Array_Name = another_array; will fail.
468 */
469 if (-1 == SLadd_intrinsic_variable (name, (VOID_STAR) at, SLANG_ARRAY_TYPE, 1))
470 {
471 free_array (at);
472 return -1;
473 }
474 return 0;
475 }
476
pop_array_indices(SLindex_Type * dims,unsigned int num_dims)477 static int pop_array_indices (SLindex_Type *dims, unsigned int num_dims)
478 {
479 unsigned int n;
480 int i;
481
482 if (num_dims > SLARRAY_MAX_DIMS)
483 {
484 _pSLang_verror (SL_INVALID_PARM, "Array size not supported");
485 return -1;
486 }
487
488 n = num_dims;
489 while (n != 0)
490 {
491 n--;
492 if (-1 == SLang_pop_integer (&i))
493 return -1;
494
495 dims[n] = i;
496 }
497
498 return 0;
499 }
500
501 /* This function gets called via expressions such as Double_Type[10, 20];
502 */
push_create_new_array(unsigned int num_dims)503 static int push_create_new_array (unsigned int num_dims)
504 {
505 SLang_Array_Type *at;
506 SLtype type;
507 SLindex_Type dims [SLARRAY_MAX_DIMS];
508 int (*anew) (SLtype, unsigned int);
509
510 if (-1 == SLang_pop_datatype (&type))
511 return -1;
512
513 anew = (_pSLclass_get_class (type))->cl_anew;
514 if (anew != NULL)
515 return (*anew) (type, num_dims);
516
517 if (-1 == pop_array_indices (dims, num_dims))
518 return -1;
519
520 if (NULL == (at = SLang_create_array (type, 0, NULL, dims, num_dims)))
521 return -1;
522
523 return SLang_push_array (at, 1);
524 }
525
push_element_at_addr(SLang_Array_Type * at,VOID_STAR data,int allow_null)526 static int push_element_at_addr (SLang_Array_Type *at,
527 VOID_STAR data, int allow_null)
528 {
529 SLang_Class_Type *cl;
530
531 cl = at->cl;
532 if ((at->flags & SLARR_DATA_VALUE_IS_POINTER)
533 && (*(VOID_STAR *) data == NULL))
534 {
535 if (allow_null)
536 return SLang_push_null ();
537
538 _pSLang_verror (SL_VARIABLE_UNINITIALIZED,
539 "%s array has uninitialized element", cl->cl_name);
540 return -1;
541 }
542
543 return (*cl->cl_apush)(at->data_type, data);
544 }
545
coerse_array_to_linear(SLang_Array_Type * at)546 static int coerse_array_to_linear (SLang_Array_Type *at)
547 {
548 SLarray_Range_Array_Type *range;
549 VOID_STAR vdata;
550 SLuindex_Type imax;
551
552 /* FIXME: Priority = low. This assumes that if an array is not linear, then
553 * it is a range.
554 */
555 if (0 == (at->flags & SLARR_DATA_VALUE_IS_RANGE))
556 return 0;
557
558 range = (SLarray_Range_Array_Type *) at->data;
559 if ((range->has_last_index == 0) || (range->has_first_index == 0))
560 {
561 _pSLang_verror (SL_INVALID_PARM, "Invalid context for a range array of indeterminate size");
562 return -1;
563 }
564
565 imax = at->num_elements;
566
567 vdata = (VOID_STAR) _SLcalloc (imax, at->sizeof_type);
568 if (vdata == NULL)
569 return -1;
570 (void) (*range->to_linear_fun)(at, range, vdata);
571 SLfree ((char *) range);
572 at->data = (VOID_STAR) vdata;
573 at->flags &= ~SLARR_DATA_VALUE_IS_RANGE;
574 at->index_fun = linear_get_data_addr;
575 return 0;
576 }
577
578 static void
free_index_objects(SLang_Object_Type * index_objs,unsigned int num_indices)579 free_index_objects (SLang_Object_Type *index_objs, unsigned int num_indices)
580 {
581 unsigned int i;
582
583 for (i = 0; i < num_indices; i++)
584 {
585 SLang_Object_Type *obj = index_objs + i;
586 if (obj->o_data_type != 0)
587 SLang_free_object (obj);
588 }
589 }
590
591 /* If *is_index_array!=0, then only one index object is returned, which is
592 * to index all the elements, and not just a single dimension.
593 */
594 static int
pop_indices(unsigned num_dims,SLindex_Type * dims,SLuindex_Type num_elements,SLang_Object_Type * index_objs,unsigned int num_indices,int * is_index_array)595 pop_indices (unsigned num_dims, SLindex_Type *dims, SLuindex_Type num_elements,
596 SLang_Object_Type *index_objs, unsigned int num_indices,
597 int *is_index_array)
598 {
599 unsigned int i;
600
601 memset((char *) index_objs, 0, num_indices * sizeof (SLang_Object_Type));
602
603 *is_index_array = 0;
604
605 if (num_indices != num_dims)
606 {
607 if (num_indices != 1) /* when 1, it is an index array */
608 {
609 _pSLang_verror (SL_INVALID_PARM, "wrong number of indices for array");
610 return -1;
611 }
612 }
613
614 i = num_indices;
615 while (i != 0)
616 {
617 SLang_Object_Type *obj;
618 SLtype data_type;
619 SLang_Array_Type *at;
620
621 i--;
622 obj = index_objs + i;
623 if (SLANG_ARRAY_TYPE != _pSLang_peek_at_stack2 (&data_type))
624 {
625 if (-1 == _pSLang_pop_object_of_type (SLANG_ARRAY_INDEX_TYPE, obj, 0))
626 goto return_error;
627
628 continue;
629 }
630 if (data_type != SLANG_ARRAY_INDEX_TYPE)
631 {
632 if (-1 == SLclass_typecast (SLANG_ARRAY_INDEX_TYPE, 1, 1))
633 return -1;
634 }
635 if (-1 == SLang_pop (obj))
636 goto return_error;
637
638 at = obj->v.array_val;
639 if (at->flags & SLARR_DATA_VALUE_IS_RANGE)
640 {
641 SLarray_Range_Array_Type *r = (SLarray_Range_Array_Type *) at->data;
642 if ((r->has_last_index == 0) || (r->has_first_index == 0))
643 {
644 /* Cases to consider (positive increment)
645 * [:] ==> [0:n-1] all elements
646 * [:i] ==> [0:i] for i>=0, [0:n+i] for i<0
647 * [i:] ==> [i:n-1] for i>=0, [i+n:n-1] for i<0
648 * This will allow: [:-3] to index all but last 3, etc.
649 * Also consider cases with a negative increment:
650 * [::-1] = [n-1,n-2,...0] = [n-1:0:-1]
651 * [:i:-1] = [n-1,n-2,..i] = [n-1:i:-1]
652 * [i::-1] = [i,i-1,...0] = [i:0:-1]
653 */
654 SLang_Array_Type *new_at;
655 SLindex_Type first_index, last_index;
656 SLindex_Type delta = r->delta;
657 SLindex_Type n;
658
659 if (num_indices == 1)/* could be index array */
660 n = (SLindex_Type)num_elements;
661 else
662 n = dims[i];
663
664 if (r->has_first_index)
665 {
666 /* Case 3 */
667 first_index = r->first_index;
668 if (first_index < 0) first_index += n;
669 if (delta > 0) last_index = n-1; else last_index = 0;
670 }
671 else if (r->has_last_index)
672 {
673 /* case 2 */
674 if (delta > 0) first_index = 0; else first_index = n-1;
675 last_index = r->last_index;
676 if (last_index < 0)
677 last_index += n;
678 }
679 else
680 {
681 /* case 0 */
682 if (delta > 0)
683 {
684 first_index = 0;
685 last_index = n - 1;
686 }
687 else
688 {
689 first_index = n-1;
690 last_index = 0;
691 }
692 }
693
694 if (NULL == (new_at = inline_implicit_index_array (&first_index, &last_index, &delta)))
695 goto return_error;
696
697 free_array (at);
698 obj->v.array_val = new_at;
699 }
700 }
701 if (num_indices == 1)
702 {
703 *is_index_array = 1;
704 return 0;
705 }
706 }
707 return 0;
708
709 return_error:
710 free_index_objects (index_objs, num_indices);
711 return -1;
712 }
713
do_index_error(SLuindex_Type i,SLindex_Type indx,SLindex_Type dim)714 static void do_index_error (SLuindex_Type i, SLindex_Type indx, SLindex_Type dim)
715 {
716 _pSLang_verror (SL_Index_Error, "Array index %lu (value=%ld) out of allowed range 0<=index<%ld",
717 (unsigned long)i, (long)indx, (long)dim);
718 }
719
_pSLarray_pop_index(unsigned int num_elements,SLang_Array_Type ** ind_atp,SLindex_Type * ind)720 int _pSLarray_pop_index (unsigned int num_elements, SLang_Array_Type **ind_atp, SLindex_Type *ind)
721 {
722 SLang_Object_Type index_obj;
723 SLindex_Type dims;
724 int is_index_array = 0;
725 SLang_Array_Type *ind_at;
726
727 *ind_atp = NULL;
728 dims = (SLindex_Type) num_elements;
729 if (dims < 0)
730 {
731 SLang_verror (SL_Index_Error, "Object is too large to be indexed");
732 return -1;
733 }
734
735 if (-1 == pop_indices (1, &dims, num_elements, &index_obj, 1, &is_index_array))
736 return -1;
737
738 if (index_obj.o_data_type != SLANG_ARRAY_TYPE)
739 {
740 *ind = index_obj.v.index_val;
741 return 0;
742 }
743
744 ind_at = index_obj.v.array_val;
745
746 if (-1 == coerse_array_to_linear (ind_at))
747 {
748 SLang_free_array (ind_at);
749 return -1;
750 }
751 *ind_atp = ind_at;
752 return 0;
753 }
754
755 static int
transfer_n_elements(SLang_Array_Type * at,VOID_STAR dest_data,VOID_STAR src_data,size_t sizeof_type,SLuindex_Type n,int is_ptr)756 transfer_n_elements (SLang_Array_Type *at, VOID_STAR dest_data, VOID_STAR src_data,
757 size_t sizeof_type, SLuindex_Type n, int is_ptr)
758 {
759 SLtype data_type;
760 SLang_Class_Type *cl;
761
762 if (is_ptr == 0)
763 {
764 SLMEMCPY ((char *) dest_data, (char *)src_data, n * sizeof_type);
765 return 0;
766 }
767
768 data_type = at->data_type;
769 cl = at->cl;
770
771 while (n != 0)
772 {
773 if (*(VOID_STAR *)dest_data != NULL)
774 {
775 (*cl->cl_destroy) (data_type, dest_data);
776 *(VOID_STAR *) dest_data = NULL;
777 }
778
779 if (*(VOID_STAR *) src_data == NULL)
780 *(VOID_STAR *) dest_data = NULL;
781 else
782 {
783 if (-1 == (*cl->cl_acopy) (data_type, src_data, dest_data))
784 /* No need to destroy anything */
785 return -1;
786 }
787
788 src_data = (VOID_STAR) ((char *)src_data + sizeof_type);
789 dest_data = (VOID_STAR) ((char *)dest_data + sizeof_type);
790
791 n--;
792 }
793
794 return 0;
795 }
796
797 _INLINE_
798 int
_pSLarray_aget_transfer_elem(SLang_Array_Type * at,SLindex_Type * indices,VOID_STAR new_data,size_t sizeof_type,int is_ptr)799 _pSLarray_aget_transfer_elem (SLang_Array_Type *at, SLindex_Type *indices,
800 VOID_STAR new_data, size_t sizeof_type, int is_ptr)
801 {
802 VOID_STAR at_data;
803
804 /* Since 1 element is being transferred, there is no need to coerce
805 * the array to linear.
806 */
807 if (NULL == (at_data = get_data_addr (at, indices)))
808 return -1;
809
810 if (is_ptr == 0)
811 {
812 memcpy ((char *) new_data, (char *)at_data, sizeof_type);
813 return 0;
814 }
815
816 return transfer_n_elements (at, new_data, at_data, sizeof_type, 1, is_ptr);
817 }
818
819 static int
aget_transfer_n_elems(SLang_Array_Type * at,SLuindex_Type num,SLindex_Type * start_indices,VOID_STAR new_data,size_t sizeof_type,int is_ptr)820 aget_transfer_n_elems (SLang_Array_Type *at, SLuindex_Type num, SLindex_Type *start_indices,
821 VOID_STAR new_data, size_t sizeof_type, int is_ptr)
822 {
823 SLuindex_Type i;
824 SLuindex_Type last_index = at->num_dims-1;
825 SLindex_Type indices[SLARRAY_MAX_DIMS];
826
827 if (num == 0)
828 return 0;
829
830 for (i = 0; i <= last_index; i++)
831 indices[i] = start_indices[i];
832
833 if ((at->data != NULL)
834 && (at->index_fun == linear_get_data_addr))
835 {
836 VOID_STAR addr_start;
837 if (NULL == (addr_start = linear_get_data_addr (at, indices)))
838 return -1;
839 indices[last_index] += (num-1);
840 if (NULL == linear_get_data_addr (at, indices))
841 return -1;
842
843 if (is_ptr == 0)
844 {
845 memcpy ((char *) new_data, (char *)addr_start, num * sizeof_type);
846 return 0;
847 }
848
849 return transfer_n_elements (at, new_data, (char *)addr_start, sizeof_type, num, is_ptr);
850 }
851
852 for (i = 0; i < num; i++)
853 {
854 VOID_STAR at_data;
855
856 /* Since 1 element is being transferred, there is no need to coerce
857 * the array to linear.
858 */
859 if (NULL == (at_data = get_data_addr (at, indices)))
860 return -1;
861
862 if (is_ptr == 0)
863 memcpy ((char *) new_data, (char *)at_data, sizeof_type);
864 else if (-1 == transfer_n_elements (at, new_data, at_data, sizeof_type, 1, is_ptr))
865 return -1;
866
867 new_data = (VOID_STAR) ((char *)new_data + sizeof_type);
868 indices[last_index]++;
869 }
870 return 0;
871 }
872
873 #if SLANG_OPTIMIZE_FOR_SPEED
874 # if SLANG_HAS_FLOAT
875 # define GENERIC_TYPE double
876 # define AGET_FROM_INDEX_ARRAY_FUN aget_doubles_from_index_array
877 # define APUT_FROM_INDEX_ARRAY_FUN aput_doubles_from_index_array
878 # include "slagetput.inc"
879 # define GENERIC_TYPE float
880 # define AGET_FROM_INDEX_ARRAY_FUN aget_floats_from_index_array
881 # define APUT_FROM_INDEX_ARRAY_FUN aput_floats_from_index_array
882 # include "slagetput.inc"
883 # endif
884
885 # define GENERIC_TYPE int
886 # define AGET_FROM_INDEX_ARRAY_FUN aget_ints_from_index_array
887 # define APUT_FROM_INDEX_ARRAY_FUN aput_ints_from_index_array
888 # include "slagetput.inc"
889 # if LONG_IS_INT
890 # define aget_longs_from_index_array aget_ints_from_index_array
891 # define aput_longs_from_index_array aput_ints_from_index_array
892 # else
893 # define GENERIC_TYPE long
894 # define AGET_FROM_INDEX_ARRAY_FUN aget_longs_from_index_array
895 # define APUT_FROM_INDEX_ARRAY_FUN aput_longs_from_index_array
896 # include "slagetput.inc"
897 # endif
898 # define GENERIC_TYPE char
899 # define AGET_FROM_INDEX_ARRAY_FUN aget_chars_from_index_array
900 # define APUT_FROM_INDEX_ARRAY_FUN aput_chars_from_index_array
901 # include "slagetput.inc"
902 # define GENERIC_TYPE short
903 # define AGET_FROM_INDEX_ARRAY_FUN aget_shorts_from_index_array
904 # define APUT_FROM_INDEX_ARRAY_FUN aput_shorts_from_index_array
905 # include "slagetput.inc"
906 #endif
907
aget_generic_from_index_array(SLang_Array_Type * at,SLang_Array_Type * at_ind,int is_range,unsigned char * dest_data)908 static int aget_generic_from_index_array (SLang_Array_Type *at,
909 SLang_Array_Type *at_ind, int is_range,
910 unsigned char *dest_data)
911 {
912 SLindex_Type *indices, *indices_max;
913 unsigned char *src_data = (unsigned char *) at->data;
914 SLindex_Type num_elements = (SLindex_Type) at->num_elements;
915 size_t sizeof_type = at->sizeof_type;
916 int is_ptr = at->flags & SLARR_DATA_VALUE_IS_POINTER;
917
918 if (is_range)
919 {
920 SLarray_Range_Array_Type *r = (SLarray_Range_Array_Type *)at_ind->data;
921 SLindex_Type idx = r->first_index, delta = r->delta;
922 SLuindex_Type j, jmax = at_ind->num_elements;
923
924 for (j = 0; j < jmax; j++)
925 {
926 size_t offset;
927 SLindex_Type i = idx;
928
929 if (i < 0)
930 {
931 i += num_elements;
932 if (i < 0)
933 i = num_elements;
934 }
935 if (i >= num_elements)
936 {
937 SLang_set_error (SL_Index_Error);
938 return -1;
939 }
940 offset = sizeof_type * (SLuindex_Type)i;
941 if (-1 == transfer_n_elements (at, (VOID_STAR) dest_data,
942 (VOID_STAR) (src_data + offset),
943 sizeof_type, 1, is_ptr))
944 return -1;
945
946 dest_data += sizeof_type;
947 idx += delta;
948 }
949 return 0;
950 }
951
952 /* Since the index array is linear, I can address it directly */
953 indices = (SLindex_Type *) at_ind->data;
954 indices_max = indices + at_ind->num_elements;
955 while (indices < indices_max)
956 {
957 size_t offset;
958 SLindex_Type i = *indices;
959
960 if (i < 0)
961 {
962 i += num_elements;
963 if (i < 0)
964 i = num_elements;
965 }
966 if (i >= num_elements)
967 {
968 SLang_set_error (SL_Index_Error);
969 return -1;
970 }
971
972 offset = sizeof_type * (SLuindex_Type)i;
973 if (-1 == transfer_n_elements (at, (VOID_STAR) dest_data,
974 (VOID_STAR) (src_data + offset),
975 sizeof_type, 1, is_ptr))
976 return -1;
977
978 dest_data += sizeof_type;
979 indices++;
980 }
981 return 0;
982 }
983
984 /* Here the ind_at index-array is an n-d array of indices. This function
985 * creates an n-d array of made up of values of 'at' at the locations
986 * specified by the indices. The result is pushed.
987 */
988 static int
aget_from_index_array(SLang_Array_Type * at,SLang_Array_Type * ind_at)989 aget_from_index_array (SLang_Array_Type *at, SLang_Array_Type *ind_at)
990 {
991 SLang_Array_Type *new_at;
992 SLindex_Type num_elements;
993 unsigned char *new_data, *src_data;
994 int is_ptr, is_range;
995
996 if (-1 == coerse_array_to_linear (at))
997 return -1;
998
999 is_range = ind_at->flags & SLARR_DATA_VALUE_IS_RANGE;
1000
1001 if ((is_range == 0)
1002 && (-1 == coerse_array_to_linear (ind_at)))
1003 return -1;
1004
1005 is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
1006 /* Only initialize the elements of the array if it contains pointers. If
1007 * an error occurs when filling the array, the array and its elements will
1008 * be freed. Hence, to avoid freeing garbage, the array should be initialized
1009 */
1010 if (NULL == (new_at = SLang_create_array1 (at->data_type, 0, NULL, ind_at->dims, ind_at->num_dims, !is_ptr)))
1011 return -1;
1012
1013 src_data = (unsigned char *) at->data;
1014 new_data = (unsigned char *) new_at->data;
1015 num_elements = (SLindex_Type) at->num_elements;
1016
1017 if (num_elements < 0)
1018 {
1019 _pSLang_verror (SL_Index_Error, "Array is too large to be indexed using an index-array");
1020 goto return_error;
1021 }
1022
1023 switch (at->data_type)
1024 {
1025 #if SLANG_OPTIMIZE_FOR_SPEED
1026 # if SLANG_HAS_FLOAT
1027 case SLANG_DOUBLE_TYPE:
1028 if (-1 == aget_doubles_from_index_array ((double *)src_data, num_elements,
1029 ind_at, is_range, (double *)new_data))
1030 goto return_error;
1031 break;
1032 case SLANG_FLOAT_TYPE:
1033 if (-1 == aget_floats_from_index_array ((float *)src_data, num_elements,
1034 ind_at, is_range, (float *)new_data))
1035 goto return_error;
1036 break;
1037 # endif
1038 case SLANG_CHAR_TYPE:
1039 case SLANG_UCHAR_TYPE:
1040 if (-1 == aget_chars_from_index_array ((char *)src_data, num_elements,
1041 ind_at, is_range, (char *)new_data))
1042 goto return_error;
1043 break;
1044 case SLANG_SHORT_TYPE:
1045 case SLANG_USHORT_TYPE:
1046 if (-1 == aget_shorts_from_index_array ((short *)src_data, num_elements,
1047 ind_at, is_range, (short *)new_data))
1048 goto return_error;
1049 break;
1050
1051 case SLANG_LONG_TYPE:
1052 case SLANG_ULONG_TYPE:
1053 /* drop */
1054 # if LONG_IS_NOT_INT
1055 if (-1 == aget_longs_from_index_array ((long *)src_data, num_elements,
1056 ind_at, is_range, (long *)new_data))
1057 goto return_error;
1058 break;
1059 # endif
1060 case SLANG_INT_TYPE:
1061 case SLANG_UINT_TYPE:
1062 if (-1 == aget_ints_from_index_array ((int *)src_data, num_elements,
1063 ind_at, is_range, (int *)new_data))
1064 goto return_error;
1065 break;
1066 #endif
1067 default:
1068 if (-1 == aget_generic_from_index_array (at, ind_at, is_range, new_data))
1069 goto return_error;
1070 }
1071
1072 return SLang_push_array (new_at, 1);
1073
1074 return_error:
1075 free_array (new_at);
1076 return -1;
1077 }
1078
1079 /* This is extremely ugly. It is due to the fact that the index_objects
1080 * may contain ranges. This is a utility function for the aget/aput
1081 * routines
1082 */
1083 static int
convert_nasty_index_objs(SLang_Array_Type * at,SLang_Object_Type * index_objs,unsigned int num_indices,SLindex_Type ** index_data,SLindex_Type * range_buf,SLindex_Type * range_delta_buf,SLindex_Type * max_dims,SLuindex_Type * num_elements,int * is_array,int is_dim_array[SLARRAY_MAX_DIMS])1084 convert_nasty_index_objs (SLang_Array_Type *at,
1085 SLang_Object_Type *index_objs,
1086 unsigned int num_indices,
1087 SLindex_Type **index_data,
1088 SLindex_Type *range_buf, SLindex_Type *range_delta_buf,
1089 SLindex_Type *max_dims,
1090 SLuindex_Type *num_elements,
1091 int *is_array, int is_dim_array[SLARRAY_MAX_DIMS])
1092 {
1093 SLuindex_Type i, total_num_elements;
1094 SLang_Array_Type *ind_at;
1095
1096 if (num_indices != at->num_dims)
1097 {
1098 _pSLang_verror (SL_INVALID_PARM, "Array requires %u indices", at->num_dims);
1099 return -1;
1100 }
1101
1102 *is_array = 0;
1103 total_num_elements = 1;
1104 for (i = 0; i < num_indices; i++)
1105 {
1106 SLuindex_Type new_total_num_elements;
1107 SLang_Object_Type *obj = index_objs + i;
1108 range_delta_buf [i] = 0;
1109
1110 if (obj->o_data_type == SLANG_ARRAY_INDEX_TYPE)
1111 {
1112 range_buf [i] = obj->v.index_val;
1113 max_dims [i] = 1;
1114 index_data[i] = range_buf + i;
1115 is_dim_array[i] = 0;
1116 }
1117 #if SLANG_ARRAY_INDEX_TYPE != SLANG_INT_TYPE
1118 else if (obj->o_data_type == SLANG_INT_TYPE)
1119 {
1120 range_buf [i] = obj->v.index_val;
1121 max_dims [i] = 1;
1122 index_data[i] = range_buf + i;
1123 is_dim_array[i] = 0;
1124 }
1125 #endif
1126 else
1127 {
1128 *is_array = 1;
1129 is_dim_array[i] = 1;
1130 ind_at = obj->v.array_val;
1131
1132 if (ind_at->flags & SLARR_DATA_VALUE_IS_RANGE)
1133 {
1134 SLarray_Range_Array_Type *r;
1135
1136 r = (SLarray_Range_Array_Type *) ind_at->data;
1137 range_buf[i] = r->first_index;
1138 range_delta_buf [i] = r->delta;
1139 max_dims[i] = (SLindex_Type) ind_at->num_elements;
1140 }
1141 else
1142 {
1143 index_data [i] = (SLindex_Type *) ind_at->data;
1144 max_dims[i] = (SLindex_Type) ind_at->num_elements;
1145 }
1146 }
1147
1148 new_total_num_elements = total_num_elements * max_dims[i];
1149 if (max_dims[i] && (new_total_num_elements/max_dims[i] != total_num_elements))
1150 {
1151 throw_size_error (SL_INVALID_PARM);
1152 return -1;
1153 }
1154 total_num_elements = new_total_num_elements;
1155 }
1156
1157 *num_elements = total_num_elements;
1158 return 0;
1159 }
1160
1161 /* This routine pushes a 1-d vector of values from 'at' indexed by
1162 * the objects 'index_objs'. These objects can either be integers or
1163 * 1-d integer arrays. The fact that the 1-d arrays can be ranges
1164 * makes this look ugly.
1165 */
1166 static int
aget_from_indices(SLang_Array_Type * at,SLang_Object_Type * index_objs,unsigned int num_indices)1167 aget_from_indices (SLang_Array_Type *at,
1168 SLang_Object_Type *index_objs, unsigned int num_indices)
1169 {
1170 SLindex_Type *index_data [SLARRAY_MAX_DIMS];
1171 SLindex_Type range_buf [SLARRAY_MAX_DIMS];
1172 SLindex_Type range_delta_buf [SLARRAY_MAX_DIMS];
1173 SLindex_Type max_dims [SLARRAY_MAX_DIMS];
1174 SLuindex_Type i, num_elements;
1175 SLang_Array_Type *new_at;
1176 SLindex_Type map_indices[SLARRAY_MAX_DIMS];
1177 SLindex_Type indices [SLARRAY_MAX_DIMS];
1178 SLindex_Type *at_dims;
1179 size_t sizeof_type;
1180 int is_ptr, ret, is_array;
1181 char *new_data;
1182 SLang_Class_Type *cl;
1183 int is_dim_array[SLARRAY_MAX_DIMS];
1184 SLuindex_Type last_index;
1185 SLindex_Type last_index_num;
1186
1187 if (-1 == convert_nasty_index_objs (at, index_objs, num_indices,
1188 index_data, range_buf, range_delta_buf,
1189 max_dims, &num_elements, &is_array,
1190 is_dim_array))
1191 return -1;
1192
1193 is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
1194 sizeof_type = at->sizeof_type;
1195
1196 /* cl = _pSLclass_get_class (at->data_type); */
1197 cl = at->cl;
1198
1199 if ((is_array == 0) && (num_elements == 1))
1200 {
1201 new_data = (char *)cl->cl_transfer_buf;
1202 memset (new_data, 0, sizeof_type);
1203 new_at = NULL;
1204 }
1205 else
1206 {
1207 SLindex_Type i_num_elements = (SLindex_Type)num_elements;
1208
1209 new_at = SLang_create_array (at->data_type, 0, NULL, &i_num_elements, 1);
1210 if (NULL == new_at)
1211 return -1;
1212
1213 new_data = (char *)new_at->data;
1214
1215 if (num_elements == 0)
1216 goto fixup_dims;
1217 }
1218
1219 at_dims = at->dims;
1220 memset ((char *) map_indices, 0, sizeof(map_indices));
1221
1222 last_index = num_indices - 1;
1223 /* if last_index_num is non-zero, then that many can be transferred quickly */
1224 if ((range_delta_buf[last_index] == 1) && (range_buf[last_index] >= 0))
1225 last_index_num = max_dims[last_index];
1226 else
1227 last_index_num = 0;
1228
1229 while (1)
1230 {
1231 for (i = 0; i < num_indices; i++)
1232 {
1233 SLindex_Type j = map_indices[i];
1234 SLindex_Type indx;
1235
1236 if (0 != range_delta_buf[i])
1237 indx = range_buf[i] + j * range_delta_buf[i];
1238 else
1239 indx = index_data [i][j];
1240
1241 if (indx < 0)
1242 indx += at_dims[i];
1243
1244 if ((indx < 0) || (indx >= at_dims[i]))
1245 {
1246 do_index_error (i, indx, at_dims[i]);
1247 free_array (new_at);
1248 return -1;
1249 }
1250 indices[i] = indx;
1251 }
1252
1253 if (last_index_num)
1254 {
1255 if (-1 == aget_transfer_n_elems (at, last_index_num, indices, (VOID_STAR)new_data, sizeof_type, is_ptr))
1256 {
1257 free_array (new_at);
1258 return -1;
1259 }
1260 new_data += last_index_num * sizeof_type;
1261 map_indices[last_index] = last_index_num;
1262
1263 if (0 != _pSLarray_next_index (map_indices, max_dims, num_indices))
1264 break;
1265 }
1266 else
1267 {
1268 if (-1 == _pSLarray_aget_transfer_elem (at, indices, (VOID_STAR)new_data, sizeof_type, is_ptr))
1269 {
1270 free_array (new_at);
1271 return -1;
1272 }
1273 new_data += sizeof_type;
1274
1275 if (num_indices == 1)
1276 {
1277 map_indices[0]++;
1278 if (map_indices[0] == max_dims[0])
1279 break;
1280 }
1281 else if (0 != _pSLarray_next_index (map_indices, max_dims, num_indices))
1282 break;
1283 }
1284 }
1285
1286 fixup_dims:
1287
1288 if (new_at != NULL)
1289 {
1290 int num_dims = 0;
1291 /* Fixup dimensions on array */
1292 for (i = 0; i < num_indices; i++)
1293 {
1294 if (is_dim_array[i]) /* was: (max_dims[i] > 1) */
1295 {
1296 new_at->dims[num_dims] = max_dims[i];
1297 num_dims++;
1298 }
1299 }
1300
1301 if (num_dims != 0) new_at->num_dims = num_dims;
1302 return SLang_push_array (new_at, 1);
1303 }
1304
1305 /* Here new_data is a whole new copy, so free it after the push */
1306 new_data -= sizeof_type;
1307 if (is_ptr && (*(VOID_STAR *)new_data == NULL))
1308 ret = SLang_push_null ();
1309 else
1310 {
1311 ret = (*cl->cl_apush) (at->data_type, (VOID_STAR)new_data);
1312 (*cl->cl_adestroy) (at->data_type, (VOID_STAR)new_data);
1313 }
1314
1315 return ret;
1316 }
1317
do_nothing(SLang_Array_Type * at)1318 static void do_nothing (SLang_Array_Type *at)
1319 {
1320 (void) at;
1321 }
1322
push_string_as_array(unsigned char * s,SLstrlen_Type len,int is_transient)1323 static int push_string_as_array (unsigned char *s, SLstrlen_Type len, int is_transient)
1324 {
1325 SLindex_Type ilen;
1326 SLang_Array_Type *at;
1327
1328 ilen = (SLindex_Type) len;
1329
1330 if (is_transient)
1331 {
1332 if (NULL == (at = SLang_create_array (SLANG_UCHAR_TYPE, 0, s, &ilen, 1)))
1333 return -1;
1334 at->free_fun = do_nothing;
1335 }
1336 else
1337 {
1338 if (NULL == (at = SLang_create_array (SLANG_UCHAR_TYPE, 0, NULL, &ilen, 1)))
1339 return -1;
1340
1341 memcpy ((char *)at->data, (char *)s, len);
1342 }
1343
1344 return SLang_push_array (at, 1);
1345 }
1346
pop_array_as_string(char ** sp)1347 static int pop_array_as_string (char **sp)
1348 {
1349 SLang_Array_Type *at;
1350 int ret;
1351
1352 *sp = NULL;
1353
1354 if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE))
1355 return -1;
1356
1357 ret = 0;
1358
1359 if (NULL == (*sp = SLang_create_nslstring ((char *) at->data, at->num_elements)))
1360 ret = -1;
1361
1362 free_array (at);
1363 return ret;
1364 }
1365
pop_array_as_bstring(SLang_BString_Type ** bs)1366 static int pop_array_as_bstring (SLang_BString_Type **bs)
1367 {
1368 SLang_Array_Type *at;
1369 int ret;
1370
1371 *bs = NULL;
1372
1373 if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE))
1374 return -1;
1375
1376 ret = 0;
1377
1378 if (NULL == (*bs = SLbstring_create ((unsigned char *) at->data, at->num_elements)))
1379 ret = -1;
1380
1381 free_array (at);
1382 return ret;
1383 }
1384
1385 #if SLANG_OPTIMIZE_FOR_SPEED
1386 /* This routine assumes that the array is 1d */
_pSLarray1d_push_elem(SLang_Array_Type * at,SLindex_Type idx)1387 int _pSLarray1d_push_elem (SLang_Array_Type *at, SLindex_Type idx)
1388 {
1389 VOID_STAR data;
1390 char *new_data;
1391 size_t sizeof_type;
1392 int is_ptr, ret;
1393 SLang_Class_Type *cl;
1394
1395 switch (at->data_type)
1396 {
1397 case SLANG_CHAR_TYPE:
1398 if (NULL == (data = at->index_fun(at, &idx))) return -1;
1399 return SLclass_push_char_obj (SLANG_CHAR_TYPE, *(signed char *)data);
1400
1401 case SLANG_INT_TYPE:
1402 if (NULL == (data = at->index_fun(at, &idx))) return -1;
1403 return SLclass_push_int_obj (SLANG_INT_TYPE, *(int *)data);
1404
1405 #if SLANG_HAS_FLOAT
1406 case SLANG_DOUBLE_TYPE:
1407 if (NULL == (data = at->index_fun(at, &idx))) return -1;
1408 return SLclass_push_double_obj (SLANG_DOUBLE_TYPE, *(double *)data);
1409 #endif
1410 }
1411
1412 is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
1413 sizeof_type = at->sizeof_type;
1414 cl = at->cl;
1415 new_data = (char *)cl->cl_transfer_buf;
1416 memset (new_data, 0, sizeof_type);
1417
1418 if (-1 == _pSLarray_aget_transfer_elem (at, &idx, (VOID_STAR)new_data, sizeof_type, is_ptr))
1419 return -1;
1420
1421 if (is_ptr && (*(VOID_STAR *)new_data == NULL))
1422 return SLang_push_null ();
1423
1424 ret = (*cl->cl_apush) (at->data_type, (VOID_STAR)new_data);
1425 (*cl->cl_adestroy) (at->data_type, (VOID_STAR)new_data);
1426 return ret;
1427 }
1428 #endif
1429
aget_from_array(unsigned int num_indices)1430 static int aget_from_array (unsigned int num_indices)
1431 {
1432 SLang_Array_Type *at;
1433 SLang_Object_Type index_objs [SLARRAY_MAX_DIMS];
1434 int ret;
1435 int is_index_array, free_indices;
1436
1437 /* Implementation note: The push_string_element function calls this with
1438 * num_indices==1, and assumes that the pop_array call below will happen.
1439 * No code should be added between these checks and the pop_array call.
1440 */
1441 if (num_indices == 0)
1442 {
1443 SLang_set_error (SL_Index_Error);
1444 return -1;
1445 }
1446 if (num_indices > SLARRAY_MAX_DIMS)
1447 {
1448 _pSLang_verror (SL_INVALID_PARM, "Number of dims must be less than %d", 1+SLARRAY_MAX_DIMS);
1449 return -1;
1450 }
1451 if (-1 == pop_array (&at, 1))
1452 return -1;
1453
1454 /* Allow a scalar to be indexed using any number of indices, e.g.,
1455 * x = 2; a = x[0]; b = x[0,0];
1456 */
1457 if ((at->flags & SLARR_DERIVED_FROM_SCALAR)
1458 && (at->num_refs == 1))
1459 {
1460 at->num_dims = num_indices;
1461 }
1462
1463 if (-1 == pop_indices (at->num_dims, at->dims, at->num_elements, index_objs, num_indices, &is_index_array))
1464 {
1465 free_array (at);
1466 return -1;
1467 }
1468 free_indices = 1;
1469
1470 if (is_index_array == 0)
1471 {
1472 #if SLANG_OPTIMIZE_FOR_SPEED
1473 if ((num_indices == 1)
1474 && (index_objs[0].o_data_type == SLANG_ARRAY_INDEX_TYPE)
1475 && (at->num_dims == 1))
1476 {
1477 ret = _pSLarray1d_push_elem (at, index_objs[0].v.index_val);
1478 free_indices = 0;
1479 }
1480 else
1481 #endif
1482 ret = aget_from_indices (at, index_objs, num_indices);
1483 }
1484 else
1485 ret = aget_from_index_array (at, index_objs[0].v.array_val);
1486
1487 free_array (at);
1488 if (free_indices)
1489 {
1490 unsigned int i;
1491 for (i = 0; i < num_indices; i++)
1492 SLang_free_object (index_objs + i);
1493 }
1494
1495 return ret;
1496 }
1497
push_string_element(SLtype type,unsigned char * s,SLuindex_Type len)1498 static int push_string_element (SLtype type, unsigned char *s, SLuindex_Type len)
1499 {
1500 SLindex_Type i;
1501
1502 if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE)
1503 {
1504 char *str;
1505
1506 /* The indices are array values. So, do this: */
1507 if (-1 == push_string_as_array (s, len, 1))
1508 return -1;
1509
1510 if (-1 == aget_from_array (1))
1511 return -1;
1512
1513 if (type == SLANG_BSTRING_TYPE)
1514 {
1515 SLang_BString_Type *bs;
1516 int ret;
1517
1518 if (-1 == pop_array_as_bstring (&bs))
1519 return -1;
1520
1521 ret = SLang_push_bstring (bs);
1522 SLbstring_free (bs);
1523 return ret;
1524 }
1525
1526 if (-1 == pop_array_as_string (&str))
1527 return -1;
1528 return _pSLang_push_slstring (str); /* frees s upon error */
1529 }
1530
1531 if (-1 == SLang_pop_array_index (&i))
1532 return -1;
1533
1534 if (i < 0) i = i + (SLindex_Type)len;
1535 if ((SLuindex_Type) i > len)
1536 i = len; /* get \0 character --- bstrings include it as well */
1537
1538 return SLang_push_uchar (s[(SLuindex_Type)i]);
1539 }
1540
1541 /* ARRAY[i, j, k] generates code: __args i j ...k ARRAY __aput/__aget
1542 * Here i, j, ... k may be a mixture of integers and 1-d arrays, or
1543 * a single array of indices. The index array is generated by the
1544 * 'where' function.
1545 *
1546 * If ARRAY is of type DataType, then this function will create an array of
1547 * the appropriate type. In that case, the indices i, j, ..., k must be
1548 * integers.
1549 */
_pSLarray_aget1(unsigned int num_indices)1550 int _pSLarray_aget1 (unsigned int num_indices)
1551 {
1552 int type;
1553 int (*aget_fun) (SLtype, unsigned int);
1554
1555 type = SLang_peek_at_stack ();
1556 switch (type)
1557 {
1558 case -1:
1559 return -1; /* stack underflow */
1560
1561 case SLANG_DATATYPE_TYPE:
1562 return push_create_new_array (num_indices);
1563
1564 case SLANG_BSTRING_TYPE:
1565 if (1 == num_indices)
1566 {
1567 SLang_BString_Type *bs;
1568 int ret;
1569 SLstrlen_Type len;
1570 unsigned char *s;
1571
1572 if (-1 == SLang_pop_bstring (&bs))
1573 return -1;
1574
1575 if (NULL == (s = SLbstring_get_pointer (bs, &len)))
1576 ret = -1;
1577 else
1578 ret = push_string_element (type, s, len);
1579
1580 SLbstring_free (bs);
1581 return ret;
1582 }
1583 break;
1584
1585 case SLANG_STRING_TYPE:
1586 if (1 == num_indices)
1587 {
1588 char *s;
1589 int ret;
1590
1591 if (-1 == SLang_pop_slstring (&s))
1592 return -1;
1593
1594 ret = push_string_element (type, (unsigned char *)s, _pSLstring_bytelen (s));
1595 _pSLang_free_slstring (s);
1596 return ret;
1597 }
1598 break;
1599
1600 case SLANG_ARRAY_TYPE:
1601 break;
1602
1603 case SLANG_ASSOC_TYPE:
1604 return _pSLassoc_aget (type, num_indices);
1605
1606 default:
1607 aget_fun = _pSLclass_get_class (type)->cl_aget;
1608 if (NULL != aget_fun)
1609 return (*aget_fun) (type, num_indices);
1610 }
1611
1612 return aget_from_array (num_indices);
1613 }
1614
_pSLarray_aget(void)1615 int _pSLarray_aget (void)
1616 {
1617 return _pSLarray_aget1 ((unsigned int)(SLang_Num_Function_Args-1));
1618 }
1619
1620 /* A[indices...indices+num] = data... */
1621 static int
aput_transfer_n_elems(SLang_Array_Type * at,SLindex_Type num,SLindex_Type * start_indices,char * data_to_put,SLuindex_Type data_increment,size_t sizeof_type,int is_ptr)1622 aput_transfer_n_elems (SLang_Array_Type *at, SLindex_Type num, SLindex_Type *start_indices,
1623 char *data_to_put, SLuindex_Type data_increment, size_t sizeof_type, int is_ptr)
1624 {
1625 VOID_STAR addr_start;
1626 SLindex_Type i;
1627 int last_index = (int)at->num_dims-1;
1628 SLindex_Type indices[SLARRAY_MAX_DIMS];
1629
1630 if (num == 0)
1631 return 0;
1632
1633 for (i = 0; i <= (int) last_index; i++)
1634 indices[i] = start_indices[i];
1635
1636 if ((at->data != NULL)
1637 && (at->index_fun == linear_get_data_addr))
1638 {
1639 VOID_STAR addr_end;
1640 if (NULL == (addr_start = linear_get_data_addr (at, indices)))
1641 return -1;
1642 indices[last_index] += (num-1);
1643 if (NULL == (addr_end = linear_get_data_addr (at, indices)))
1644 return -1;
1645
1646 if (is_ptr == 0)
1647 {
1648 while (addr_start <= addr_end)
1649 {
1650 memcpy ((char *) addr_start, data_to_put, sizeof_type);
1651 data_to_put += data_increment;
1652 addr_start = (VOID_STAR) ((char *)addr_start + sizeof_type);
1653 }
1654 return 0;
1655 }
1656
1657 while (addr_start <= addr_end)
1658 {
1659 if (-1 == transfer_n_elements (at, addr_start, data_to_put, sizeof_type, 1, is_ptr))
1660 return -1;
1661 data_to_put += data_increment;
1662 addr_start = (VOID_STAR) ((char *)addr_start + sizeof_type);
1663 }
1664 return 0;
1665 }
1666
1667 for (i = 0; i < num; i++)
1668 {
1669 /* Since 1 element is being transferred, there is no need to coerce
1670 * the array to linear.
1671 */
1672 if (NULL == (addr_start = get_data_addr (at, indices)))
1673 return -1;
1674
1675 if (is_ptr == 0)
1676 memcpy ((char *) addr_start, data_to_put, sizeof_type);
1677 else if (-1 == transfer_n_elements (at, addr_start, (VOID_STAR)data_to_put, sizeof_type, 1, is_ptr))
1678 return -1;
1679
1680 data_to_put += data_increment;
1681 indices[last_index]++;
1682 }
1683 return 0;
1684 }
1685
1686 _INLINE_ int
_pSLarray_aput_transfer_elem(SLang_Array_Type * at,SLindex_Type * indices,VOID_STAR data_to_put,size_t sizeof_type,int is_ptr)1687 _pSLarray_aput_transfer_elem (SLang_Array_Type *at, SLindex_Type *indices,
1688 VOID_STAR data_to_put, size_t sizeof_type, int is_ptr)
1689 {
1690 VOID_STAR at_data;
1691
1692 /*
1693 * A range array is not allowed here. I should add a check for it. At
1694 * the moment, one will not get here.
1695 */
1696 if (NULL == (at_data = get_data_addr (at, indices)))
1697 return -1;
1698
1699 if (is_ptr == 0)
1700 {
1701 memcpy ((char *) at_data, (char *)data_to_put, sizeof_type);
1702 return 0;
1703 }
1704
1705 return transfer_n_elements (at, at_data, data_to_put, sizeof_type, 1, is_ptr);
1706 }
1707
1708 static int
aput_get_data_to_put(SLang_Class_Type * cl,SLuindex_Type num_elements,int allow_array,SLang_Array_Type ** at_ptr,char ** data_to_put,SLuindex_Type * data_increment)1709 aput_get_data_to_put (SLang_Class_Type *cl, SLuindex_Type num_elements, int allow_array,
1710 SLang_Array_Type **at_ptr, char **data_to_put, SLuindex_Type *data_increment)
1711 {
1712 SLtype data_type;
1713 int type;
1714 SLang_Array_Type *at;
1715
1716 *at_ptr = NULL;
1717
1718 data_type = cl->cl_data_type;
1719 type = SLang_peek_at_stack ();
1720
1721 if ((SLtype)type != data_type)
1722 {
1723 if ((type != SLANG_NULL_TYPE)
1724 || ((cl->cl_class_type != SLANG_CLASS_TYPE_PTR)
1725 && (cl->cl_class_type != SLANG_CLASS_TYPE_MMT)))
1726 {
1727 if (-1 == SLclass_typecast (data_type, 1, allow_array))
1728 return -1;
1729 }
1730 else
1731 {
1732 /* This bit of code allows, e.g., a[10] = NULL; */
1733 *data_increment = 0;
1734 *data_to_put = (char *) cl->cl_transfer_buf;
1735 *((char **)cl->cl_transfer_buf) = NULL;
1736 return SLdo_pop ();
1737 }
1738 }
1739
1740 if (allow_array
1741 && (data_type != SLANG_ARRAY_TYPE)
1742 && (data_type != SLANG_ANY_TYPE)
1743 && (SLANG_ARRAY_TYPE == SLang_peek_at_stack ()))
1744 {
1745 if (-1 == SLang_pop_array (&at, 0))
1746 return -1;
1747
1748 if ((at->num_elements != num_elements)
1749 #if 0
1750 || (at->num_dims != 1)
1751 #endif
1752 )
1753 {
1754 _pSLang_verror (SL_Index_Error, "Array size is inappropriate for use with index-array");
1755 free_array (at);
1756 return -1;
1757 }
1758
1759 *data_to_put = (char *) at->data;
1760 *data_increment = at->sizeof_type;
1761 *at_ptr = at;
1762 return 0;
1763 }
1764
1765 *data_increment = 0;
1766 *data_to_put = (char *) cl->cl_transfer_buf;
1767
1768 if (-1 == (*cl->cl_apop)(data_type, (VOID_STAR) *data_to_put))
1769 return -1;
1770
1771 return 0;
1772 }
1773
1774 static int
aput_from_indices(SLang_Array_Type * at,SLang_Object_Type * index_objs,unsigned int num_indices)1775 aput_from_indices (SLang_Array_Type *at,
1776 SLang_Object_Type *index_objs, unsigned int num_indices)
1777 {
1778 SLindex_Type *index_data [SLARRAY_MAX_DIMS];
1779 SLindex_Type range_buf [SLARRAY_MAX_DIMS];
1780 SLindex_Type range_delta_buf [SLARRAY_MAX_DIMS];
1781 SLindex_Type max_dims [SLARRAY_MAX_DIMS];
1782 SLindex_Type *at_dims;
1783 SLuindex_Type i, num_elements;
1784 SLang_Array_Type *bt;
1785 SLindex_Type map_indices[SLARRAY_MAX_DIMS];
1786 SLindex_Type indices [SLARRAY_MAX_DIMS];
1787 size_t sizeof_type;
1788 int is_ptr, is_array, ret;
1789 char *data_to_put;
1790 SLuindex_Type data_increment;
1791 SLang_Class_Type *cl;
1792 int is_dim_array [SLARRAY_MAX_DIMS];
1793 SLindex_Type last_index_num;
1794 unsigned int last_index;
1795
1796 if (-1 == convert_nasty_index_objs (at, index_objs, num_indices,
1797 index_data, range_buf, range_delta_buf,
1798 max_dims, &num_elements, &is_array,
1799 is_dim_array))
1800 return -1;
1801
1802 cl = at->cl;
1803
1804 if (-1 == aput_get_data_to_put (cl, num_elements, is_array,
1805 &bt, &data_to_put, &data_increment))
1806 return -1;
1807
1808 sizeof_type = at->sizeof_type;
1809 is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
1810
1811 ret = -1;
1812
1813 at_dims = at->dims;
1814 SLMEMSET((char *) map_indices, 0, sizeof(map_indices));
1815
1816 last_index = num_indices - 1;
1817 /* if last_index_num is non-zero, then that many can be transferred quickly */
1818 if ((range_delta_buf[last_index] == 1) && (range_buf[last_index] >= 0))
1819 last_index_num = max_dims[last_index];
1820 else
1821 last_index_num = 0;
1822
1823 if (num_elements) while (1)
1824 {
1825 for (i = 0; i < num_indices; i++)
1826 {
1827 SLindex_Type j = map_indices[i];
1828 SLindex_Type indx;
1829
1830 if (0 != range_delta_buf[i])
1831 indx = range_buf[i] + j * range_delta_buf[i];
1832 else
1833 indx = index_data [i][j];
1834
1835 if (indx < 0)
1836 indx += at_dims[i];
1837
1838 if ((indx < 0) || (indx >= at_dims[i]))
1839 {
1840 do_index_error (i, indx, at_dims[i]);
1841 goto return_error;
1842 }
1843 indices[i] = indx;
1844 }
1845
1846 if (last_index_num)
1847 {
1848 if (-1 == aput_transfer_n_elems (at, last_index_num, indices,
1849 data_to_put, data_increment,
1850 sizeof_type, is_ptr))
1851 goto return_error;
1852
1853 data_to_put += last_index_num * data_increment;
1854 map_indices[last_index] = last_index_num;
1855
1856 if (0 != _pSLarray_next_index (map_indices, max_dims, num_indices))
1857 break;
1858 }
1859 else
1860 {
1861 if (-1 == _pSLarray_aput_transfer_elem (at, indices, (VOID_STAR)data_to_put, sizeof_type, is_ptr))
1862 goto return_error;
1863
1864 data_to_put += data_increment;
1865 if (num_indices == 1)
1866 {
1867 map_indices[0]++;
1868 if (map_indices[0] == max_dims[0])
1869 break;
1870 }
1871 else if (0 != _pSLarray_next_index (map_indices, max_dims, num_indices))
1872 break;
1873 }
1874 }
1875
1876 ret = 0;
1877
1878 /* drop */
1879
1880 return_error:
1881 if (bt == NULL)
1882 {
1883 if (is_ptr)
1884 (*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR) data_to_put);
1885 }
1886 else free_array (bt);
1887
1888 return ret;
1889 }
1890
1891 static int
aput_generic_from_index_array(char * src_data,SLuindex_Type data_increment,SLang_Array_Type * ind_at,int is_range,SLang_Array_Type * dest_at)1892 aput_generic_from_index_array (char *src_data,
1893 SLuindex_Type data_increment,
1894 SLang_Array_Type *ind_at, int is_range,
1895 SLang_Array_Type *dest_at)
1896 {
1897 SLindex_Type num_elements = (SLindex_Type) dest_at->num_elements;
1898 size_t sizeof_type = dest_at->sizeof_type;
1899 int is_ptr = dest_at->flags & SLARR_DATA_VALUE_IS_POINTER;
1900 char *dest_data = (char *)dest_at->data;
1901 SLindex_Type *indices, *indices_max;
1902
1903 if (is_range)
1904 {
1905 SLarray_Range_Array_Type *r = (SLarray_Range_Array_Type *)ind_at->data;
1906 SLindex_Type idx = r->first_index, delta = r->delta;
1907 SLuindex_Type j, jmax = ind_at->num_elements;
1908
1909 for (j = 0; j < jmax; j++)
1910 {
1911 size_t offset;
1912 SLindex_Type i = idx;
1913
1914 if (i < 0)
1915 {
1916 i += num_elements;
1917 if (i < 0)
1918 i = num_elements;
1919 }
1920 if (i >= num_elements)
1921 {
1922 SLang_set_error (SL_Index_Error);
1923 return -1;
1924 }
1925 offset = sizeof_type * (SLuindex_Type)i;
1926 if (-1 == transfer_n_elements (dest_at, (VOID_STAR) (dest_data + offset),
1927 (VOID_STAR) src_data, sizeof_type,
1928 1, is_ptr))
1929 return -1;
1930
1931 src_data += data_increment;
1932 idx += delta;
1933 }
1934 return 0;
1935 }
1936
1937 /* Since the index array is linear, I can address it directly */
1938 indices = (SLindex_Type *) ind_at->data;
1939 indices_max = indices + ind_at->num_elements;
1940
1941 while (indices < indices_max)
1942 {
1943 size_t offset;
1944 SLindex_Type i = *indices;
1945
1946 if (i < 0)
1947 {
1948 i += num_elements;
1949 if (i < 0)
1950 i = num_elements;
1951 }
1952 if (i >= num_elements)
1953 {
1954 SLang_set_error (SL_Index_Error);
1955 return -1;
1956 }
1957
1958 offset = sizeof_type * (SLuindex_Type)i;
1959
1960 if (-1 == transfer_n_elements (dest_at, (VOID_STAR) (dest_data + offset),
1961 (VOID_STAR) src_data, sizeof_type, 1,
1962 is_ptr))
1963 return -1;
1964
1965 indices++;
1966 src_data += data_increment;
1967 }
1968
1969 return 0;
1970 }
1971
1972 static int
aput_from_index_array(SLang_Array_Type * at,SLang_Array_Type * ind_at)1973 aput_from_index_array (SLang_Array_Type *at, SLang_Array_Type *ind_at)
1974 {
1975 char *data_to_put, *dest_data;
1976 SLuindex_Type data_increment;
1977 SLindex_Type num_elements;
1978 int is_ptr, is_range;
1979 SLang_Array_Type *bt;
1980 SLang_Class_Type *cl;
1981 int ret;
1982
1983 if (-1 == coerse_array_to_linear (at))
1984 return -1;
1985
1986 is_range = ind_at->flags & SLARR_DATA_VALUE_IS_RANGE;
1987
1988 if ((is_range == 0)
1989 && (-1 == coerse_array_to_linear (ind_at)))
1990 return -1;
1991
1992 cl = at->cl;
1993
1994 /* Note that if bt is returned as non NULL, then the array is a linear
1995 * one.
1996 */
1997 if (-1 == aput_get_data_to_put (cl, ind_at->num_elements, 1,
1998 &bt, &data_to_put, &data_increment))
1999 return -1;
2000
2001 is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
2002 dest_data = (char *) at->data;
2003 num_elements = (SLindex_Type) at->num_elements;
2004
2005 ret = -1;
2006 switch (at->data_type)
2007 {
2008 #if SLANG_OPTIMIZE_FOR_SPEED
2009 # if SLANG_HAS_FLOAT
2010 case SLANG_DOUBLE_TYPE:
2011 if (-1 == aput_doubles_from_index_array (data_to_put, data_increment,
2012 ind_at, is_range,
2013 (double*)dest_data, num_elements))
2014 goto return_error;
2015 break;
2016
2017 case SLANG_FLOAT_TYPE:
2018 if (-1 == aput_floats_from_index_array (data_to_put, data_increment,
2019 ind_at, is_range,
2020 (float*)dest_data, num_elements))
2021 goto return_error;
2022 break;
2023 # endif
2024
2025 case SLANG_CHAR_TYPE:
2026 case SLANG_UCHAR_TYPE:
2027 if (-1 == aput_chars_from_index_array (data_to_put, data_increment,
2028 ind_at, is_range,
2029 (char*)dest_data, num_elements))
2030 goto return_error;
2031 break;
2032 case SLANG_SHORT_TYPE:
2033 case SLANG_USHORT_TYPE:
2034 if (-1 == aput_shorts_from_index_array (data_to_put, data_increment,
2035 ind_at, is_range,
2036 (short*)dest_data, num_elements))
2037 goto return_error;
2038 break;
2039
2040 case SLANG_LONG_TYPE:
2041 case SLANG_ULONG_TYPE:
2042 /* drop */
2043 #if LONG_IS_NOT_INT
2044 if (-1 == aput_longs_from_index_array (data_to_put, data_increment,
2045 ind_at, is_range,
2046 (long*)dest_data, num_elements))
2047 goto return_error;
2048 break;
2049 #endif
2050 case SLANG_INT_TYPE:
2051 case SLANG_UINT_TYPE:
2052 if (-1 == aput_ints_from_index_array (data_to_put, data_increment,
2053 ind_at, is_range,
2054 (int*)dest_data, num_elements))
2055 goto return_error;
2056 break;
2057 #endif
2058 default:
2059 if (-1 == aput_generic_from_index_array (data_to_put, data_increment,
2060 ind_at, is_range, at))
2061 goto return_error;
2062 }
2063
2064 ret = 0;
2065 /* Drop */
2066
2067 return_error:
2068
2069 if (bt == NULL)
2070 {
2071 if (is_ptr)
2072 (*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR)data_to_put);
2073 }
2074 else free_array (bt);
2075
2076 return ret;
2077 }
2078
2079 /* ARRAY[i, j, k] = generates code: __args i j k ARRAY __aput
2080 */
_pSLarray_aput1(unsigned int num_indices)2081 int _pSLarray_aput1 (unsigned int num_indices)
2082 {
2083 SLang_Array_Type *at;
2084 SLang_Object_Type index_objs [SLARRAY_MAX_DIMS];
2085 int ret;
2086 int is_index_array;
2087 int (*aput_fun) (SLtype, unsigned int);
2088 int type;
2089
2090 ret = -1;
2091
2092 type = SLang_peek_at_stack ();
2093 switch (type)
2094 {
2095 case -1:
2096 return -1;
2097
2098 case SLANG_ARRAY_TYPE:
2099 break;
2100
2101 case SLANG_ASSOC_TYPE:
2102 return _pSLassoc_aput (type, num_indices);
2103
2104 default:
2105 if (NULL != (aput_fun = _pSLclass_get_class (type)->cl_aput))
2106 return (*aput_fun) (type, num_indices);
2107 break;
2108 }
2109
2110 if (-1 == SLang_pop_array (&at, 0))
2111 return -1;
2112
2113 if (at->flags & SLARR_DATA_VALUE_IS_READ_ONLY)
2114 {
2115 _pSLang_verror (SL_READONLY_ERROR, "%s Array is read-only",
2116 SLclass_get_datatype_name (at->data_type));
2117 free_array (at);
2118 return -1;
2119 }
2120
2121 if (-1 == pop_indices (at->num_dims, at->dims, at->num_elements, index_objs, num_indices, &is_index_array))
2122 {
2123 free_array (at);
2124 return -1;
2125 }
2126
2127 if (is_index_array == 0)
2128 {
2129 #if SLANG_OPTIMIZE_FOR_SPEED
2130 if ((num_indices == 1) && (index_objs[0].o_data_type == SLANG_ARRAY_INDEX_TYPE)
2131 && (0 == (at->flags & (SLARR_DATA_VALUE_IS_RANGE|SLARR_DATA_VALUE_IS_POINTER)))
2132 && (1 == at->num_dims)
2133 && (at->data != NULL))
2134 {
2135 SLindex_Type ofs = index_objs[0].v.index_val;
2136 if (ofs < 0) ofs += at->dims[0];
2137 if ((ofs >= at->dims[0]) || (ofs < 0))
2138 ret = aput_from_indices (at, index_objs, num_indices);
2139 else switch (at->data_type)
2140 {
2141 case SLANG_CHAR_TYPE:
2142 ret = SLang_pop_char (((char *)at->data + ofs));
2143 break;
2144 case SLANG_INT_TYPE:
2145 ret = SLang_pop_integer (((int *)at->data + ofs));
2146 break;
2147 #if SLANG_HAS_FLOAT
2148 case SLANG_DOUBLE_TYPE:
2149 ret = SLang_pop_double ((double *)at->data + ofs);
2150 break;
2151 #endif
2152 default:
2153 ret = aput_from_indices (at, index_objs, num_indices);
2154 }
2155 free_array (at);
2156 return ret;
2157 }
2158 #endif
2159 ret = aput_from_indices (at, index_objs, num_indices);
2160 }
2161 else
2162 ret = aput_from_index_array (at, index_objs[0].v.array_val);
2163
2164 free_array (at);
2165 free_index_objects (index_objs, num_indices);
2166 return ret;
2167 }
2168
_pSLarray_aput(void)2169 int _pSLarray_aput (void)
2170 {
2171 return _pSLarray_aput1 ((unsigned int)(SLang_Num_Function_Args-1));
2172 }
2173
_pSLmergesort(void * obj,SLindex_Type * sort_indices,SLindex_Type n,int (* cmp)(void *,SLindex_Type,SLindex_Type))2174 static int _pSLmergesort (void *obj,
2175 SLindex_Type *sort_indices, SLindex_Type n,
2176 int (*cmp) (void *, SLindex_Type, SLindex_Type))
2177 {
2178 SLindex_Type i, j, k, kmax, n1, m;
2179 SLindex_Type *tmp;
2180 int try_quick_merge;
2181
2182 if (n < 0)
2183 {
2184 SLang_verror (SL_INVALID_PARM, "_pSLmergesort: The number of elements must be non-negative");
2185 return -1;
2186 }
2187
2188 for (i = 0; i < n; i++)
2189 sort_indices[i] = i;
2190
2191 /* Insertion sort for 4 elements */
2192 n1 = n-1;
2193 m = 4; i = 0;
2194 while (i < n1)
2195 {
2196 kmax = i + m - 1;
2197 if (kmax >= n)
2198 kmax = n1;
2199 for (k = i+1; k <= kmax; k++)
2200 {
2201 j = k;
2202 while (j > i)
2203 {
2204 SLindex_Type t;
2205 j--;
2206 if ((*cmp)(obj, sort_indices[j], k) <= 0)
2207 break;
2208 t = sort_indices[j];
2209 sort_indices[j] = sort_indices[j+1];
2210 sort_indices[j+1] = t;
2211 }
2212 }
2213 i += m;
2214 }
2215
2216 if (m >= n)
2217 return 0;
2218
2219 /* Note that 1073741824*2 < 0 */
2220 i = (n <= 65536) ? m : 65536;
2221 while ((i*2 < n) && (i*2 > 0))
2222 i *= 2;
2223
2224 if (NULL == (tmp = (SLindex_Type *)_SLcalloc (i, sizeof(SLindex_Type))))
2225 return -1;
2226
2227 try_quick_merge = 0;
2228 /* Now do a bottom-up merge sort */
2229 while ((m < n) && (m > 0))
2230 {
2231 i = 0;
2232 while (i < n-m)
2233 {
2234 SLindex_Type imax, jmax, l, e_j, e_k;
2235 SLindex_Type *sort_indices_i;
2236
2237 sort_indices_i = sort_indices + i;
2238 k = m;
2239 e_k = sort_indices_i[k];
2240 if (try_quick_merge)
2241 {
2242 if ((*cmp)(obj, sort_indices_i[k-1], e_k) <= 0)
2243 goto next_i;
2244 }
2245
2246 j = 0; jmax = m;
2247 kmax = k+m;
2248 imax = i + kmax;
2249
2250 if (imax > n)
2251 {
2252 imax = n;
2253 kmax = imax - i;
2254 }
2255
2256 /* Only need to copy the left group */
2257 memcpy (tmp, sort_indices_i, jmax*sizeof(SLindex_Type));
2258 e_j = tmp[j];
2259
2260 l = i;
2261 while (1)
2262 {
2263 if ((*cmp)(obj, e_j, e_k) <= 0)
2264 {
2265 sort_indices[l] = e_j; l++; j++;
2266 if (j == jmax)
2267 break;
2268 e_j = tmp[j];
2269 continue;
2270 }
2271 sort_indices[l] = e_k; l++; k++;
2272 if (k == kmax)
2273 {
2274 memcpy (sort_indices+l, tmp+j, (imax-l)*sizeof(SLindex_Type));
2275 break;
2276 }
2277 e_k = sort_indices_i[k];
2278 }
2279 try_quick_merge = (k == m);
2280 next_i:
2281 i = i + 2*m;
2282 }
2283 m = m * 2;
2284 }
2285
2286 SLfree ((char *)tmp);
2287 return 0;
2288 }
2289
2290 /* Sorting Functions */
2291
2292 typedef struct
2293 {
2294 SLang_Name_Type *func;
2295 SLang_Object_Type obj;
2296 int dir; /* +1=ascend, -1=descend */
2297 }
2298 Sort_Object_Type;
2299 static void *QSort_Obj = NULL;
2300
2301 /* This is for 1-d matrices only. It is used by the sort function */
push_element_at_index(SLang_Array_Type * at,SLindex_Type indx)2302 static int push_element_at_index (SLang_Array_Type *at, SLindex_Type indx)
2303 {
2304 VOID_STAR data;
2305
2306 if (NULL == (data = get_data_addr (at, &indx)))
2307 return -1;
2308
2309 return push_element_at_addr (at, (VOID_STAR) data, 1);
2310 }
2311
2312 #if SLANG_OPTIMIZE_FOR_SPEED
2313 #define MS_SCALAR_CMP(func, type) \
2314 static int func(void *obj, SLindex_Type i, SLindex_Type j) \
2315 { \
2316 type *data = (type *)obj; \
2317 if (data[i] > data[j]) \
2318 return 1; \
2319 if (data[i] < data[j]) \
2320 return -1; \
2321 if (i > j) return 1; \
2322 if (i < j) return -1; \
2323 return 0; \
2324 }
2325
2326 #define MS_SCALAR_CMP_DOWN(func, type) \
2327 static int func(void *obj, SLindex_Type i, SLindex_Type j) \
2328 { \
2329 type *data = (type *)obj; \
2330 if (data[i] > data[j]) \
2331 return -1; \
2332 if (data[i] < data[j]) \
2333 return 1; \
2334 if (i > j) return 1; \
2335 if (i < j) return -1; \
2336 return 0; \
2337 }
2338
2339 #define QS_SCALAR_CMP(func, type) \
2340 static int func(const void *ip, const void *jp) \
2341 { \
2342 SLindex_Type i = *(SLindex_Type *)ip, j = *(SLindex_Type *)jp; \
2343 type *data = (type *)QSort_Obj; \
2344 if (data[i] > data[j]) \
2345 return 1; \
2346 if (data[i] < data[j]) \
2347 return -1; \
2348 if (i > j) return 1; \
2349 if (i < j) return -1; \
2350 return 0; \
2351 }
2352
2353 #define QS_SCALAR_CMP_DOWN(func, type) \
2354 static int func(const void *ip, const void *jp) \
2355 { \
2356 SLindex_Type i = *(SLindex_Type *)ip, j = *(SLindex_Type *)jp; \
2357 type *data = (type *)QSort_Obj; \
2358 if (data[i] > data[j]) \
2359 return -1; \
2360 if (data[i] < data[j]) \
2361 return 1; \
2362 if (i > j) return 1; \
2363 if (i < j) return -1; \
2364 return 0; \
2365 }
2366
2367 #if SLANG_HAS_FLOAT
MS_SCALAR_CMP(ms_double_sort_cmp,double)2368 MS_SCALAR_CMP(ms_double_sort_cmp, double)
2369 MS_SCALAR_CMP_DOWN(ms_double_sort_down_cmp, double)
2370 MS_SCALAR_CMP(ms_float_sort_cmp, float)
2371 MS_SCALAR_CMP_DOWN(ms_float_sort_down_cmp, float)
2372
2373 QS_SCALAR_CMP(qs_double_sort_cmp, double)
2374 QS_SCALAR_CMP_DOWN(qs_double_sort_down_cmp, double)
2375 QS_SCALAR_CMP(qs_float_sort_cmp, float)
2376 QS_SCALAR_CMP_DOWN(qs_float_sort_down_cmp, float)
2377 #endif
2378
2379 MS_SCALAR_CMP(ms_int_sort_cmp, int)
2380 MS_SCALAR_CMP_DOWN(ms_int_sort_down_cmp, int)
2381 QS_SCALAR_CMP(qs_int_sort_cmp, int)
2382 QS_SCALAR_CMP_DOWN(qs_int_sort_down_cmp, int)
2383
2384 #endif /* SLANG_OPTIMIZE_FOR_SPEED */
2385
2386 static int ms_sort_cmp_fun (void *vobj, SLindex_Type i, SLindex_Type j)
2387 {
2388 int cmp;
2389 SLang_Array_Type *at;
2390 Sort_Object_Type *sort_obj = (Sort_Object_Type *)vobj;
2391
2392 at = sort_obj->obj.v.array_val;
2393
2394 if (SLang_get_error ()
2395 || (-1 == push_element_at_index (at, i))
2396 || (-1 == push_element_at_index (at, j))
2397 || (-1 == SLexecute_function (sort_obj->func))
2398 || (-1 == SLang_pop_integer (&cmp)))
2399 {
2400 /* error: return something meaningful */
2401 if (i > j) return 1;
2402 if (i < j) return -1;
2403 return 0;
2404 }
2405 if (cmp == 0)
2406 {
2407 if (i > j) return 1;
2408 if (i < j) return -1;
2409 return 0;
2410 }
2411 return cmp*sort_obj->dir;
2412 }
2413
ms_sort_opaque_cmp_fun(void * vobj,SLindex_Type i,SLindex_Type j)2414 static int ms_sort_opaque_cmp_fun (void *vobj, SLindex_Type i, SLindex_Type j)
2415 {
2416 int cmp;
2417 Sort_Object_Type *sort_obj = (Sort_Object_Type *)vobj;
2418
2419 if (SLang_get_error ()
2420 || (-1 == _pSLpush_slang_obj (&sort_obj->obj))
2421 || (-1 == SLang_push_array_index (i))
2422 || (-1 == SLang_push_array_index (j))
2423 || (-1 == SLexecute_function (sort_obj->func))
2424 || (-1 == SLang_pop_integer (&cmp)))
2425 {
2426 /* error: return something meaninful */
2427 if (i > j) return 1;
2428 if (i < j) return -1;
2429 return 0;
2430 }
2431 if (cmp == 0)
2432 {
2433 if (i > j) return 1;
2434 if (i < j) return -1;
2435 return 0;
2436 }
2437 return sort_obj->dir*cmp;
2438 }
2439
ms_builtin_sort_cmp_fun(void * vobj,SLindex_Type i,SLindex_Type j)2440 static int ms_builtin_sort_cmp_fun (void *vobj, SLindex_Type i, SLindex_Type j)
2441 {
2442 VOID_STAR a_data;
2443 VOID_STAR b_data;
2444 Sort_Object_Type *sort_obj = (Sort_Object_Type *)vobj;
2445 SLang_Array_Type *at;
2446 SLang_Class_Type *cl;
2447
2448 at = sort_obj->obj.v.array_val;
2449 cl = at->cl;
2450
2451 if ((SLang_get_error () == 0)
2452 && (NULL != (a_data = get_data_addr (at, &i)))
2453 && (NULL != (b_data = get_data_addr (at, &j))))
2454 {
2455 int cmp;
2456
2457 if ((at->flags & SLARR_DATA_VALUE_IS_POINTER)
2458 && ((*(VOID_STAR *) a_data == NULL) || (*(VOID_STAR *) b_data == NULL)))
2459 {
2460 _pSLang_verror (SL_VARIABLE_UNINITIALIZED,
2461 "%s array has uninitialized element", cl->cl_name);
2462 }
2463 else if (0 == (*cl->cl_cmp)(at->data_type, a_data, b_data, &cmp))
2464 {
2465 if (cmp == 0)
2466 {
2467 if (i > j) return 1;
2468 if (i < j) return -1;
2469 return 0;
2470 }
2471 return cmp * sort_obj->dir;
2472 }
2473 }
2474
2475 if (i > j) return 1;
2476 if (i < j) return -1;
2477 return 0;
2478 }
2479
ms_sort_array_internal(void * vobj,SLindex_Type n,int (* sort_cmp)(void *,SLindex_Type,SLindex_Type))2480 static void ms_sort_array_internal (void *vobj, SLindex_Type n,
2481 int (*sort_cmp)(void *, SLindex_Type, SLindex_Type))
2482 {
2483 SLang_Array_Type *ind_at;
2484 SLindex_Type *indx;
2485
2486 if (NULL == (ind_at = SLang_create_array1 (SLANG_ARRAY_INDEX_TYPE, 0, NULL, &n, 1, 1)))
2487 return;
2488
2489 indx = (SLindex_Type *) ind_at->data;
2490 if (-1 == _pSLmergesort (vobj, indx, n, sort_cmp))
2491 {
2492 free_array (ind_at);
2493 return;
2494 }
2495
2496 (void) SLang_push_array (ind_at, 1);
2497 }
2498
qs_builtin_sort_cmp_fun(const void * ip,const void * jp)2499 static int qs_builtin_sort_cmp_fun (const void *ip, const void *jp)
2500 {
2501 return ms_builtin_sort_cmp_fun (QSort_Obj, *(SLindex_Type *)ip, *(SLindex_Type *)jp);
2502 }
qs_sort_opaque_cmp_fun(const void * ip,const void * jp)2503 static int qs_sort_opaque_cmp_fun (const void *ip, const void *jp)
2504 {
2505 return ms_sort_opaque_cmp_fun (QSort_Obj, *(SLindex_Type *)ip, *(SLindex_Type *)jp);
2506 }
qs_sort_cmp_fun(const void * ip,const void * jp)2507 static int qs_sort_cmp_fun (const void *ip, const void *jp)
2508 {
2509 return ms_sort_cmp_fun (QSort_Obj, *(SLindex_Type *)ip, *(SLindex_Type *)jp);
2510 }
2511
qs_sort_array_internal(void * vobj,SLindex_Type n,int (* sort_cmp)(const void *,const void *))2512 static void qs_sort_array_internal (void *vobj, SLindex_Type n,
2513 int (*sort_cmp)(const void *, const void *))
2514 {
2515 SLang_Array_Type *ind_at;
2516 SLindex_Type *indx;
2517 SLindex_Type i;
2518 void *save_vobj;
2519
2520 if (NULL == (ind_at = SLang_create_array1 (SLANG_ARRAY_INDEX_TYPE, 0, NULL, &n, 1, 1)))
2521 return;
2522
2523 indx = (SLindex_Type *) ind_at->data;
2524 for (i = 0; i < n; i++)
2525 indx[i] = i;
2526
2527 save_vobj = QSort_Obj;
2528 QSort_Obj = vobj;
2529 qsort ((void *)indx, n, sizeof (SLindex_Type), sort_cmp);
2530 QSort_Obj = save_vobj;
2531
2532 (void) SLang_push_array (ind_at, 1);
2533 }
2534
pop_1d_array(SLang_Array_Type ** atp)2535 static int pop_1d_array (SLang_Array_Type **atp)
2536 {
2537 SLang_Array_Type *at;
2538
2539 if (-1 == SLang_pop_array (&at, 1))
2540 return -1;
2541
2542 if (at->num_dims != 1)
2543 {
2544 _pSLang_verror (SL_INVALID_PARM, "sort is restricted to 1 dim arrays");
2545 free_array (at);
2546 return -1;
2547 }
2548 *atp = at;
2549 return 0;
2550 }
2551
2552 #define SORT_METHOD_MSORT 0
2553 #define SORT_METHOD_QSORT 1
2554 static int Default_Sort_Method = SORT_METHOD_MSORT;
get_default_sort_method(void)2555 static void get_default_sort_method (void)
2556 {
2557 char SLFUTURE_CONST *method = NULL;
2558 switch (Default_Sort_Method)
2559 {
2560 case SORT_METHOD_QSORT: method = "qsort"; break;
2561 case SORT_METHOD_MSORT: method = "msort"; break;
2562 }
2563 (void) SLang_push_string (method);
2564 }
set_default_sort_method(char * method)2565 static void set_default_sort_method (char *method)
2566 {
2567 if (0 == strcmp (method, "qsort"))
2568 {
2569 Default_Sort_Method = SORT_METHOD_QSORT;
2570 return;
2571 }
2572 Default_Sort_Method = SORT_METHOD_MSORT;
2573 }
2574
2575 /* Usage Forms:
2576 * i = sort (a);
2577 * i = sort (a, &fun); % sort using function fun(a[i],a[j])
2578 * i = sort (a, &fun, n); % sort using fun(a, i, j); 0 <= i,j < n
2579 */
array_sort_intrin(void)2580 static void array_sort_intrin (void)
2581 {
2582 SLang_Array_Type *at;
2583 Sort_Object_Type sort_obj;
2584 void *vobj;
2585 SLindex_Type n;
2586 int nargs = SLang_Num_Function_Args;
2587 int dir = 1;
2588 int use_qsort = 0;
2589 char *method;
2590
2591 if (-1 == SLang_get_int_qualifier ("dir", &dir, 1))
2592 return;
2593 dir = (dir >= 0) ? 1 : -1;
2594 use_qsort = (Default_Sort_Method == SORT_METHOD_QSORT);
2595 if (SLang_qualifier_exists ("qsort")) use_qsort = 1;
2596 if (-1 == SLang_get_string_qualifier ("method", &method, NULL))
2597 return;
2598 if (method != NULL)
2599 {
2600 if (0 == strcmp(method, "qsort"))
2601 use_qsort = 1;
2602 SLang_free_slstring (method);
2603 }
2604
2605 if (nargs == 1) /* i = sort (a) */
2606 {
2607 int (*msort_fun)(void *, SLindex_Type, SLindex_Type);
2608 int (*qsort_fun)(const void *, const void *);
2609
2610 if (-1 == pop_1d_array (&at))
2611 return;
2612
2613 switch (at->data_type)
2614 {
2615 #if SLANG_OPTIMIZE_FOR_SPEED
2616 # if SLANG_HAS_FLOAT
2617 case SLANG_DOUBLE_TYPE:
2618 msort_fun = (dir > 0) ? ms_double_sort_cmp : ms_double_sort_down_cmp;
2619 qsort_fun = (dir > 0) ? qs_double_sort_cmp : qs_double_sort_down_cmp;
2620 vobj = at->data;
2621 break;
2622 case SLANG_FLOAT_TYPE:
2623 msort_fun = (dir > 0) ? ms_float_sort_cmp : ms_float_sort_down_cmp;
2624 qsort_fun = (dir > 0) ? qs_float_sort_cmp : qs_float_sort_down_cmp;
2625 vobj = at->data;
2626 break;
2627 # endif
2628 case SLANG_INT_TYPE:
2629 msort_fun = (dir > 0) ? ms_int_sort_cmp : ms_int_sort_down_cmp;
2630 qsort_fun = (dir > 0) ? qs_int_sort_cmp : qs_int_sort_down_cmp;
2631 vobj = at->data;
2632 break;
2633 #endif
2634 default:
2635 if (at->cl->cl_cmp == NULL)
2636 {
2637 _pSLang_verror (SL_NOT_IMPLEMENTED,
2638 "%s does not have a predefined sorting method",
2639 at->cl->cl_name);
2640 free_array (at);
2641 return;
2642 }
2643 msort_fun = ms_builtin_sort_cmp_fun;
2644 qsort_fun = qs_builtin_sort_cmp_fun;
2645 sort_obj.obj.o_data_type = SLANG_ARRAY_TYPE;
2646 sort_obj.obj.v.array_val = at;
2647 sort_obj.dir = dir;
2648 vobj = (void *)&sort_obj;
2649 }
2650
2651 n = (SLindex_Type) at->num_elements;
2652 if (use_qsort)
2653 qs_sort_array_internal (vobj, n, qsort_fun);
2654 else
2655 ms_sort_array_internal (vobj, n, msort_fun);
2656 free_array (at);
2657 return;
2658 }
2659
2660 if (nargs == 2) /* i = sort (a, &fun) */
2661 {
2662 SLang_Name_Type *entry;
2663
2664 if (NULL == (entry = SLang_pop_function ()))
2665 return;
2666
2667 if (-1 == pop_1d_array (&at))
2668 {
2669 SLang_free_function (entry);
2670 return;
2671 }
2672
2673 sort_obj.func = entry;
2674 sort_obj.obj.o_data_type = SLANG_ARRAY_TYPE;
2675 sort_obj.obj.v.array_val = at;
2676 sort_obj.dir = dir;
2677 vobj = (void *)&sort_obj;
2678
2679 n = (SLindex_Type) at->num_elements;
2680 if (use_qsort)
2681 qs_sort_array_internal (vobj, n, qs_sort_cmp_fun);
2682 else
2683 ms_sort_array_internal (vobj, n, ms_sort_cmp_fun);
2684 free_array (at);
2685 SLang_free_function (entry);
2686 return;
2687 }
2688
2689 if (nargs == 3) /* i = sort (a, fun, n) */
2690 {
2691 SLang_Name_Type *entry;
2692
2693 if (-1 == SLang_pop_array_index (&n))
2694 return;
2695
2696 if (n < 0)
2697 {
2698 SLang_verror (SL_Index_Error, "Sort object cannot have a negative size");
2699 return;
2700 }
2701
2702 if (NULL == (entry = SLang_pop_function ()))
2703 return;
2704
2705 if (-1 == SLang_pop (&sort_obj.obj))
2706 {
2707 SLang_free_function (entry);
2708 return;
2709 }
2710 sort_obj.func = entry;
2711 sort_obj.dir = dir;
2712 vobj = (void *)&sort_obj;
2713
2714 if (use_qsort)
2715 qs_sort_array_internal (vobj, n, qs_sort_opaque_cmp_fun);
2716 else
2717 ms_sort_array_internal (vobj, n, ms_sort_opaque_cmp_fun);
2718 SLang_free_object (&sort_obj.obj);
2719 SLang_free_function (entry);
2720 return;
2721 }
2722
2723 SLang_verror (SL_Usage_Error, "\
2724 Usage: i = array_sort(a);\n\
2725 i = array_sort(a, &func); %% cmp = func(a[i], b[j]);\n\
2726 i = array_sort(obj, &func, n); %% cmp = func(obj, i, j)\n");
2727 }
2728
bstring_to_array(SLang_BString_Type * bs)2729 static void bstring_to_array (SLang_BString_Type *bs)
2730 {
2731 unsigned char *s;
2732 SLstrlen_Type len;
2733
2734 if (NULL == (s = SLbstring_get_pointer (bs, &len)))
2735 (void) SLang_push_null ();
2736 else
2737 (void) push_string_as_array (s, len, 0);
2738 }
2739
array_to_bstring(SLang_Array_Type * at)2740 static void array_to_bstring (SLang_Array_Type *at)
2741 {
2742 size_t nbytes;
2743 SLang_BString_Type *bs;
2744
2745 nbytes = at->num_elements * at->sizeof_type;
2746 bs = SLbstring_create ((unsigned char *)at->data, nbytes);
2747 (void) SLang_push_bstring (bs);
2748 SLbstring_free (bs);
2749 }
2750
init_char_array(void)2751 static void init_char_array (void)
2752 {
2753 SLang_Array_Type *at;
2754 char *s;
2755 SLstrlen_Type n, ndim;
2756
2757 if (SLang_pop_slstring (&s)) return;
2758
2759 if (-1 == SLang_pop_array (&at, 0))
2760 goto free_and_return;
2761
2762 if ((at->data_type != SLANG_CHAR_TYPE) && (at->data_type != SLANG_UCHAR_TYPE))
2763 {
2764 _pSLang_verror (SL_TYPE_MISMATCH, "Operation requires a character array");
2765 goto free_and_return;
2766 }
2767
2768 n = _pSLstring_bytelen (s);
2769 ndim = at->num_elements;
2770 if (n > ndim)
2771 {
2772 _pSLang_verror (SL_INVALID_PARM, "String too big to initialize array");
2773 goto free_and_return;
2774 }
2775
2776 strncpy((char *) at->data, s, ndim);
2777 /* drop */
2778
2779 free_and_return:
2780 free_array (at);
2781 _pSLang_free_slstring (s);
2782 }
2783
range_get_data_addr(SLang_Array_Type * at,SLindex_Type * dims)2784 static VOID_STAR range_get_data_addr (SLang_Array_Type *at, SLindex_Type *dims)
2785 {
2786 static int value;
2787 SLarray_Range_Array_Type *r;
2788 SLindex_Type d;
2789
2790 d = *dims;
2791 r = (SLarray_Range_Array_Type *)at->data;
2792
2793 if (d < 0)
2794 d += at->dims[0];
2795
2796 if ((SLuindex_Type)d >= at->num_elements)
2797 {
2798 SLang_set_error (SL_Index_Error);
2799 return NULL;
2800 }
2801 value = r->first_index + d * r->delta;
2802 return (VOID_STAR) &value;
2803 }
2804
2805 static SLang_Array_Type
create_range_array(SLarray_Range_Array_Type * range,SLindex_Type num,SLtype type,int (* to_linear_fun)(SLang_Array_Type *,SLarray_Range_Array_Type *,VOID_STAR))2806 *create_range_array (SLarray_Range_Array_Type *range, SLindex_Type num,
2807 SLtype type, int (*to_linear_fun) (SLang_Array_Type *, SLarray_Range_Array_Type *, VOID_STAR))
2808 {
2809 SLarray_Range_Array_Type *r;
2810 SLang_Array_Type *at;
2811
2812 r = (SLarray_Range_Array_Type *) SLmalloc (sizeof (SLarray_Range_Array_Type));
2813 if (r == NULL)
2814 return NULL;
2815 memset((char *) r, 0, sizeof (SLarray_Range_Array_Type));
2816
2817 if (NULL == (at = SLang_create_array (type, 0, (VOID_STAR) range, &num, 1)))
2818 {
2819 SLfree ((char *)r);
2820 return NULL;
2821 }
2822 r->first_index = range->first_index;
2823 r->last_index = range->last_index;
2824 r->delta = range->delta;
2825 r->has_first_index = range->has_first_index;
2826 r->has_last_index = range->has_last_index;
2827 r->to_linear_fun = to_linear_fun;
2828 at->data = (VOID_STAR) r;
2829 at->index_fun = range_get_data_addr;
2830 at->flags |= SLARR_DATA_VALUE_IS_RANGE;
2831 return at;
2832 }
2833
get_range_array_limits(SLindex_Type * first_indexp,SLindex_Type * last_indexp,SLindex_Type * deltap,SLarray_Range_Array_Type * r,SLindex_Type * nump)2834 static int get_range_array_limits (SLindex_Type *first_indexp, SLindex_Type *last_indexp, SLindex_Type *deltap,
2835 SLarray_Range_Array_Type *r, SLindex_Type *nump)
2836 {
2837 SLindex_Type first_index, last_index, delta;
2838 SLindex_Type num;
2839
2840 if (deltap == NULL) delta = 1;
2841 else delta = *deltap;
2842
2843 if (delta == 0)
2844 {
2845 _pSLang_verror (SL_INVALID_PARM, "range-array increment must be non-zero");
2846 return -1;
2847 }
2848
2849 r->has_first_index = (first_indexp != NULL);
2850 if (r->has_first_index)
2851 first_index = *first_indexp;
2852 else
2853 first_index = 0;
2854
2855 r->has_last_index = (last_indexp != NULL);
2856 if (r->has_last_index)
2857 last_index = *last_indexp;
2858 else
2859 last_index = -1;
2860
2861 num = 0;
2862 if (delta > 0)
2863 {
2864 /* Case: [20:10:11] --> 0 elements, [10:20:11] --> 1 element */
2865 if (last_index >= first_index)
2866 num = 1 + (last_index - first_index) / delta;
2867 }
2868 else
2869 {
2870 /* Case: [20:10:-11] -> 1 element, [20:30:-11] -> none */
2871 if (last_index <= first_index)
2872 num = 1 + (last_index - first_index) / delta;
2873 }
2874
2875 r->first_index = first_index;
2876 r->last_index = last_index;
2877 r->delta = delta;
2878 *nump = num;
2879
2880 return 0;
2881 }
2882
index_range_to_linear(SLang_Array_Type * at,SLarray_Range_Array_Type * range,VOID_STAR buf)2883 static int index_range_to_linear (SLang_Array_Type *at, SLarray_Range_Array_Type *range, VOID_STAR buf)
2884 {
2885 SLindex_Type *data = (SLindex_Type *)buf;
2886 SLuindex_Type i, imax;
2887 SLindex_Type xmin, dx;
2888
2889 imax = at->num_elements;
2890 xmin = range->first_index;
2891 dx = range->delta;
2892 for (i = 0; i < imax; i++)
2893 {
2894 data [i] = xmin;
2895 xmin += dx;
2896 }
2897 return 0;
2898 }
2899
inline_implicit_index_array(SLindex_Type * xminptr,SLindex_Type * xmaxptr,SLindex_Type * dxptr)2900 static SLang_Array_Type *inline_implicit_index_array (SLindex_Type *xminptr, SLindex_Type *xmaxptr, SLindex_Type *dxptr)
2901 {
2902 SLarray_Range_Array_Type r;
2903 SLindex_Type num;
2904
2905 if (-1 == get_range_array_limits (xminptr, xmaxptr, dxptr, &r, &num))
2906 return NULL;
2907
2908 return create_range_array (&r, num, SLANG_ARRAY_INDEX_TYPE, index_range_to_linear);
2909 }
2910
2911 #if (SLANG_ARRAY_INDEX_TYPE == SLANG_INT_TYPE)
2912 # define int_range_to_linear index_range_to_linear
2913 # define inline_implicit_int_array inline_implicit_index_array
2914 #else
int_range_to_linear(SLang_Array_Type * at,SLarray_Range_Array_Type * range,VOID_STAR buf)2915 static int int_range_to_linear (SLang_Array_Type *at, SLarray_Range_Array_Type *range, VOID_STAR buf)
2916 {
2917 int *data = (int *)buf;
2918 unsigned int i, imax;
2919 int xmin, dx;
2920
2921 imax = (unsigned int)at->num_elements;
2922 xmin = (int) range->first_index;
2923 dx = (int) range->delta;
2924 for (i = 0; i < imax; i++)
2925 {
2926 data [i] = xmin;
2927 xmin += dx;
2928 }
2929 return 0;
2930 }
2931
inline_implicit_int_array(SLindex_Type * xminptr,SLindex_Type * xmaxptr,SLindex_Type * dxptr)2932 static SLang_Array_Type *inline_implicit_int_array (SLindex_Type *xminptr, SLindex_Type *xmaxptr, SLindex_Type *dxptr)
2933 {
2934 SLarray_Range_Array_Type r;
2935 SLindex_Type num;
2936
2937 if (-1 == get_range_array_limits (xminptr, xmaxptr, dxptr, &r, &num))
2938 return NULL;
2939
2940 return create_range_array (&r, num, SLANG_INT_TYPE, int_range_to_linear);
2941 }
2942 #endif
2943
2944 #if SLANG_HAS_FLOAT
compute_range_multiplier(double xmin,double xmax,double dx)2945 static double compute_range_multiplier (double xmin, double xmax, double dx)
2946 {
2947 double multiplier = 1.0;
2948
2949 (void) xmax;
2950 while (multiplier < 1e9)
2951 {
2952 volatile double xmin1, dx1; /* avoid agressive compiler optimization */
2953
2954 xmin1 = multiplier * xmin;
2955 dx1 = multiplier * dx;
2956
2957 if ((xmin1 == (int)xmin1) && (dx1 == (int)dx1))
2958 return multiplier;
2959 multiplier *= 10.0;
2960 }
2961 return 1.0;
2962 }
2963
2964
inline_implicit_floating_array(SLtype type,double * xminptr,double * xmaxptr,double * dxptr,int ntype,SLindex_Type nels)2965 static SLang_Array_Type *inline_implicit_floating_array (SLtype type,
2966 double *xminptr, double *xmaxptr, double *dxptr,
2967 int ntype, SLindex_Type nels)
2968 {
2969 SLindex_Type n, i;
2970 SLang_Array_Type *at;
2971 SLindex_Type dims;
2972 double xmin, xmax, dx;
2973 double multiplier = 1.0;
2974
2975 if ((xminptr == NULL) || (xmaxptr == NULL))
2976 {
2977 _pSLang_verror (SL_INVALID_PARM, "range-array has unknown size");
2978 return NULL;
2979 }
2980 xmin = *xminptr;
2981 xmax = *xmaxptr;
2982
2983 if (ntype)
2984 {
2985 /* [a:b:#n] == a + [0:(n-1)]*(b-a)/(n-1)
2986 * ==> dx = (b-a)/(n-1)
2987 */
2988 n = nels;
2989 if (n <= 0)
2990 {
2991 n = 0;
2992 dx = 1.0;
2993 }
2994 else
2995 {
2996 if (n == 1)
2997 dx = 0.0;
2998 else
2999 dx = (xmax-xmin)/(n-1);
3000 }
3001 }
3002 else
3003 {
3004 if (dxptr == NULL) dx = 1.0;
3005 else dx = *dxptr;
3006
3007 if (dx == 0.0)
3008 {
3009 _pSLang_verror (SL_INVALID_PARM, "range-array increment must be non-zero");
3010 return NULL;
3011 }
3012
3013 /* I have convinced myself that it is better to use semi-open intervals
3014 * because of less ambiguities. So, [a:b:c] will represent the set of
3015 * values a, a + c, a + 2c ... a + nc
3016 * such that a + nc < b. That is, b lies outside the interval.
3017 */
3018
3019 if (((xmax <= xmin) && (dx >= 0.0))
3020 || ((xmax >= xmin) && (dx <= 0.0)))
3021 n = 0;
3022 else
3023 {
3024 double last;
3025
3026 if ((xmin + dx == (volatile double)xmin) || (xmax + dx == (volatile double)xmax))
3027 n = 0;
3028 else
3029 /* Allow for roundoff by adding 0.5 before truncation */
3030 n = (int)(1.5 + ((xmax - xmin) / dx));
3031
3032 if (n <= 0)
3033 {
3034 _pSLang_verror (SL_INVALID_PARM, "range-array increment is too small");
3035 return NULL;
3036 }
3037
3038 multiplier = compute_range_multiplier (xmin, xmax, dx);
3039 last = ((xmin*multiplier) + (n-1) * (dx*multiplier))/multiplier;
3040
3041 if (dx > 0.0)
3042 {
3043 if (last >= xmax)
3044 n -= 1;
3045 }
3046 else if (last <= xmax)
3047 n -= 1;
3048 }
3049 }
3050
3051 dims = n;
3052 if (NULL == (at = SLang_create_array1 (type, 0, NULL, &dims, 1, 1)))
3053 return NULL;
3054
3055 if (type == SLANG_DOUBLE_TYPE)
3056 {
3057 double *ptr;
3058
3059 ptr = (double *) at->data;
3060
3061 if (multiplier != 1.0)
3062 {
3063 int ixmin = (floor)(multiplier*xmin+0.5);
3064 int idx = (floor)(multiplier*dx+0.5);
3065 for (i = 0; i < n; i++)
3066 ptr[i] = (ixmin + (double)i * idx)/multiplier;
3067 }
3068 else for (i = 0; i < n; i++)
3069 ptr[i] = (xmin + i*dx);
3070
3071 /* Explicitly set the last element to xmax to avoid roundoff error */
3072 if (ntype && (n > 1))
3073 ptr[n-1] = xmax;
3074 }
3075 else
3076 {
3077 float *ptr;
3078
3079 ptr = (float *) at->data;
3080
3081 for (i = 0; i < n; i++)
3082 ptr[i] = (float) (xmin + i * dx);
3083
3084 if (ntype && (n > 0))
3085 ptr[n-1] = (float) xmax;
3086 }
3087 return at;
3088 }
3089 #endif
3090
pop_range_int(SLindex_Type * ip)3091 static int pop_range_int (SLindex_Type *ip)
3092 {
3093 return SLang_pop_array_index (ip);
3094 }
3095
3096 /* FIXME: Priority=medium
3097 * This needs to be updated to work with all integer types.
3098 * Adding support for other types is going to require a generalization
3099 * of the Range_Array_Type object.
3100 */
3101 /* If ntype is non-zero, the array was specified using [a:b:#c] */
inline_implicit_array(int ntype)3102 static int inline_implicit_array (int ntype)
3103 {
3104 SLindex_Type index_vals[3];
3105 #if SLANG_HAS_FLOAT
3106 double double_vals[3];
3107 int is_int;
3108 #endif
3109 int has_vals[3];
3110 unsigned int i, count;
3111 SLindex_Type n = 0;
3112 SLang_Array_Type *at;
3113 int precedence;
3114 SLtype type;
3115
3116 count = SLang_Num_Function_Args;
3117
3118 if ((count == 2) && (ntype == 0))
3119 has_vals [2] = 0;
3120 else if (count != 3)
3121 {
3122 _pSLang_verror (SL_NUM_ARGS_ERROR, "wrong number of arguments to __implicit_inline_array");
3123 return -1;
3124 }
3125
3126 #if SLANG_HAS_FLOAT
3127 is_int = 1;
3128 #endif
3129
3130 type = 0;
3131 precedence = 0;
3132
3133 if (ntype)
3134 {
3135 if (-1 == pop_range_int (&n))
3136 return -1;
3137 has_vals[2] = 0;
3138 count--;
3139 }
3140 i = count;
3141
3142 while (i--)
3143 {
3144 int this_type, this_precedence;
3145 SLindex_Type itmp;
3146
3147 if (-1 == (this_type = SLang_peek_at_stack ()))
3148 return -1;
3149
3150 this_precedence = _pSLarith_get_precedence ((SLtype) this_type);
3151 if (precedence < this_precedence)
3152 {
3153 type = (SLtype) this_type;
3154 precedence = this_precedence;
3155 }
3156
3157 has_vals [i] = 1;
3158
3159 switch (this_type)
3160 {
3161 case SLANG_NULL_TYPE:
3162 if (ntype)
3163 {
3164 _pSLang_verror (SL_Syntax_Error, "Arrays of the form [a:b:#c] must be fully specified");
3165 return -1;
3166 }
3167 has_vals[i] = 0;
3168 (void) SLdo_pop ();
3169 break;
3170
3171 #if SLANG_HAS_FLOAT
3172 case SLANG_DOUBLE_TYPE:
3173 case SLANG_FLOAT_TYPE:
3174 if (-1 == SLang_pop_double (double_vals + i))
3175 return -1;
3176 is_int = 0;
3177 break;
3178 #endif
3179 default:
3180 if (-1 == pop_range_int (&itmp))
3181 return -1;
3182 index_vals[i] = itmp;
3183 #if SLANG_HAS_FLOAT
3184 double_vals[i] = (double) itmp;
3185 #endif
3186 }
3187 }
3188
3189 #if SLANG_HAS_FLOAT
3190 if (ntype)
3191 {
3192 is_int = 0;
3193 if (type != SLANG_FLOAT_TYPE)
3194 type = SLANG_DOUBLE_TYPE;
3195 }
3196
3197 if (is_int == 0)
3198 at = inline_implicit_floating_array (type,
3199 (has_vals[0] ? &double_vals[0] : NULL),
3200 (has_vals[1] ? &double_vals[1] : NULL),
3201 (has_vals[2] ? &double_vals[2] : NULL),
3202 ntype, n);
3203 else
3204 #endif
3205 at = inline_implicit_int_array ((has_vals[0] ? &index_vals[0] : NULL),
3206 (has_vals[1] ? &index_vals[1] : NULL),
3207 (has_vals[2] ? &index_vals[2] : NULL));
3208
3209 if (at == NULL)
3210 return -1;
3211
3212 return SLang_push_array (at, 1);
3213 }
3214
_pSLarray_inline_implicit_array(void)3215 int _pSLarray_inline_implicit_array (void)
3216 {
3217 return inline_implicit_array (0);
3218 }
3219
_pSLarray_inline_implicit_arrayn(void)3220 int _pSLarray_inline_implicit_arrayn (void)
3221 {
3222 return inline_implicit_array (1);
3223 }
3224
try_typecast_range_array(SLang_Array_Type * at,SLtype to_type,SLang_Array_Type ** btp)3225 static int try_typecast_range_array (SLang_Array_Type *at, SLtype to_type,
3226 SLang_Array_Type **btp)
3227 {
3228 SLang_Array_Type *bt;
3229
3230 *btp = NULL;
3231 if (to_type == SLANG_ARRAY_INDEX_TYPE)
3232 {
3233 if (at->data_type == SLANG_INT_TYPE)
3234 {
3235 SLarray_Range_Array_Type *range;
3236
3237 range = (SLarray_Range_Array_Type *)at->data;
3238 bt = create_range_array (range, at->num_elements,
3239 to_type, index_range_to_linear);
3240 if (bt == NULL)
3241 return -1;
3242 *btp = bt;
3243 return 1;
3244 }
3245 }
3246 return 0;
3247 }
3248
_pSLarray_wildcard_array(void)3249 int _pSLarray_wildcard_array (void)
3250 {
3251 SLang_Array_Type *at;
3252
3253 if (NULL == (at = inline_implicit_int_array (NULL, NULL, NULL)))
3254 return -1;
3255
3256 return SLang_push_array (at, 1);
3257 }
3258
3259 /* FIXME: The type-promotion routine needs to be made more generic and
3260 * better support user-defined types.
3261 */
3262
3263 /* Test if the type cannot be promoted further */
nowhere_to_promote(SLtype type)3264 _INLINE_ static int nowhere_to_promote (SLtype type)
3265 {
3266 switch (type)
3267 {
3268 case SLANG_COMPLEX_TYPE:
3269 case SLANG_BSTRING_TYPE:
3270 case SLANG_ARRAY_TYPE:
3271 return 1;
3272 }
3273
3274 return 0;
3275 }
3276
promote_to_common_type(SLtype a,SLtype b,SLtype * c)3277 static int promote_to_common_type (SLtype a, SLtype b, SLtype *c)
3278 {
3279 if (a == b)
3280 {
3281 *c = a;
3282 return 0;
3283 }
3284 if (nowhere_to_promote (a))
3285 {
3286 /* a type can always be converted to an array: T -> [T] */
3287 if (b == SLANG_ARRAY_TYPE)
3288 *c = b;
3289 else
3290 *c = a;
3291 return 0;
3292 }
3293 if (nowhere_to_promote (b))
3294 {
3295 *c = b;
3296 return 0;
3297 }
3298
3299 if (_pSLang_is_arith_type (a) && _pSLang_is_arith_type (b))
3300 {
3301 if (_pSLarith_get_precedence (a) > _pSLarith_get_precedence (b))
3302 *c = a;
3303 else
3304 *c = b;
3305 return 0;
3306 }
3307
3308 if (a == SLANG_NULL_TYPE)
3309 {
3310 *c = b;
3311 return 0;
3312 }
3313 if (b == SLANG_NULL_TYPE)
3314 {
3315 *c = a;
3316 return 0;
3317 }
3318
3319 *c = a;
3320 return 0;
3321 }
3322
get_type_for_concat(SLang_Array_Type ** arrays,unsigned int n)3323 static SLtype get_type_for_concat (SLang_Array_Type **arrays, unsigned int n)
3324 {
3325 SLtype type;
3326 unsigned int i;
3327
3328 type = arrays[0]->data_type;
3329
3330 for (i = 1; i < n; i++)
3331 {
3332 SLtype this_type = arrays[i]->data_type;
3333
3334 if (this_type == type)
3335 continue;
3336
3337 if (-1 == promote_to_common_type (type, this_type, &type))
3338 return SLANG_UNDEFINED_TYPE;
3339 }
3340 return type;
3341 }
3342
concat_arrays(unsigned int count)3343 static SLang_Array_Type *concat_arrays (unsigned int count)
3344 {
3345 SLang_Array_Type **arrays;
3346 SLang_Array_Type *at, *bt;
3347 unsigned int i;
3348 SLindex_Type num_elements;
3349 SLtype type;
3350 char *src_data, *dest_data;
3351 int is_ptr;
3352 size_t sizeof_type;
3353 SLindex_Type max_dims, min_dims, max_rows, min_rows;
3354
3355 arrays = (SLang_Array_Type **)_SLcalloc (count, sizeof (SLang_Array_Type *));
3356 if (arrays == NULL)
3357 {
3358 SLdo_pop_n (count);
3359 return NULL;
3360 }
3361 memset ((char *) arrays, 0, count * sizeof(SLang_Array_Type *));
3362
3363 at = NULL;
3364
3365 num_elements = 0;
3366 i = count;
3367
3368 while (i != 0)
3369 {
3370 SLindex_Type last_num_elements = num_elements;
3371
3372 i--;
3373
3374 if (-1 == SLang_pop_array (&bt, 1)) /* bt is now linear */
3375 goto free_and_return;
3376
3377 arrays[i] = bt;
3378 num_elements += (SLindex_Type) bt->num_elements;
3379 if (num_elements < last_num_elements)
3380 {
3381 SLang_verror (SL_LimitExceeded_Error, "Unable to address concatenated arrays");
3382 goto free_and_return;
3383 }
3384 }
3385
3386 /* From here on, arrays[*] are linear */
3387
3388 /* type = arrays[0]->data_type; */
3389 type = get_type_for_concat (arrays, count);
3390
3391 max_dims = min_dims = arrays[0]->num_dims;
3392 min_rows = max_rows = arrays[0]->dims[0];
3393
3394 for (i = 0; i < count; i++)
3395 {
3396 SLang_Array_Type *ct;
3397 SLindex_Type num;
3398
3399 bt = arrays[i];
3400
3401 num = bt->num_dims;
3402 if (num > max_dims) max_dims = num;
3403 if (num < min_dims) min_dims = num;
3404
3405 num = bt->dims[0];
3406 if (num > max_rows) max_rows = num;
3407 if (num < min_rows) min_rows = num;
3408
3409 if (type == bt->data_type)
3410 continue;
3411
3412 if (1 != _pSLarray_typecast (bt->data_type, (VOID_STAR) &bt, 1,
3413 type, (VOID_STAR) &ct, 1))
3414 goto free_and_return;
3415
3416 free_array (bt);
3417 arrays [i] = ct;
3418 }
3419
3420 if (NULL == (at = SLang_create_array (type, 0, NULL, &num_elements, 1)))
3421 goto free_and_return;
3422
3423 is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
3424 sizeof_type = at->sizeof_type;
3425 dest_data = (char *) at->data;
3426
3427 for (i = 0; i < count; i++)
3428 {
3429 bt = arrays[i];
3430
3431 src_data = (char *) bt->data;
3432 num_elements = bt->num_elements;
3433
3434 if (-1 == transfer_n_elements (bt, (VOID_STAR)dest_data, (VOID_STAR)src_data, sizeof_type,
3435 num_elements, is_ptr))
3436 {
3437 free_array (at);
3438 at = NULL;
3439 goto free_and_return;
3440 }
3441
3442 dest_data += num_elements * sizeof_type;
3443 }
3444
3445 #if 0
3446 /* If the arrays are all 1-d, and all the same size, then reshape to a
3447 * 2-d array. This will allow us to do, e.g.
3448 * a = [[1,2], [3,4]]
3449 * to specifiy a 2-d.
3450 * Someday I will generalize this.
3451 */
3452 /* This is a bad idea. Everyone using it expects concatenation to happen.
3453 * Perhaps I will extend the syntax to allow a 2-d array to be expressed
3454 * as [[1,2];[3,4]].
3455 */
3456 if ((max_dims == min_dims) && (max_dims == 1) && (min_rows == max_rows))
3457 {
3458 at->num_dims = 2;
3459 at->dims[0] = count;
3460 at->dims[1] = min_rows;
3461 }
3462 #endif
3463 free_and_return:
3464
3465 for (i = 0; i < count; i++)
3466 free_array (arrays[i]);
3467 SLfree ((char *) arrays);
3468
3469 return at;
3470 }
3471
_pSLarray_inline_array(void)3472 int _pSLarray_inline_array (void)
3473 {
3474 SLang_Object_Type *obj, *objmin;
3475 SLtype type;
3476 unsigned int count;
3477 SLang_Array_Type *at;
3478
3479 obj = _pSLang_get_run_stack_pointer ();
3480 objmin = _pSLang_get_run_stack_base ();
3481
3482 count = SLang_Num_Function_Args;
3483 type = 0;
3484
3485 while ((count > 0) && (--obj >= objmin))
3486 {
3487 SLtype this_type = obj->o_data_type;
3488
3489 if (type == 0)
3490 type = this_type;
3491 else if (type != this_type)
3492 {
3493 if (-1 == promote_to_common_type (type, this_type, &type))
3494 {
3495 _pSLclass_type_mismatch_error (type, this_type);
3496 return -1;
3497 }
3498 }
3499 count--;
3500 }
3501
3502 if (count != 0)
3503 {
3504 SLang_set_error (SL_STACK_UNDERFLOW);
3505 return -1;
3506 }
3507
3508 count = SLang_Num_Function_Args;
3509
3510 if (count == 0)
3511 {
3512 _pSLang_verror (SL_NOT_IMPLEMENTED, "Empty inline-arrays not supported");
3513 return -1;
3514 }
3515
3516 if (type == SLANG_ARRAY_TYPE)
3517 {
3518 if (count == 1)
3519 return 0; /* no point in going on */
3520
3521 if (NULL == (at = concat_arrays (count)))
3522 return -1;
3523 }
3524 else
3525 {
3526 SLang_Object_Type index_obj;
3527 SLindex_Type icount = (SLindex_Type) count;
3528
3529 if (NULL == (at = SLang_create_array (type, 0, NULL, &icount, 1)))
3530 return -1;
3531
3532 index_obj.o_data_type = SLANG_ARRAY_INDEX_TYPE;
3533 while (count != 0)
3534 {
3535 count--;
3536 index_obj.v.index_val = count;
3537 if (-1 == aput_from_indices (at, &index_obj, 1))
3538 {
3539 free_array (at);
3540 SLdo_pop_n (count);
3541 return -1;
3542 }
3543 }
3544 }
3545
3546 return SLang_push_array (at, 1);
3547 }
3548
_pSLarray_convert_to_array(VOID_STAR cd,int (* get_type)(VOID_STAR,SLuindex_Type,SLtype *),int (* push)(VOID_STAR,SLuindex_Type),SLuindex_Type num_objects,SLtype type)3549 int _pSLarray_convert_to_array (VOID_STAR cd,
3550 int (*get_type)(VOID_STAR, SLuindex_Type, SLtype *),
3551 int (*push)(VOID_STAR, SLuindex_Type),
3552 SLuindex_Type num_objects, SLtype type)
3553 {
3554 SLtype this_type;
3555 SLang_Array_Type *at;
3556 SLuindex_Type i;
3557 SLindex_Type dims;
3558 SLang_Object_Type index_obj;
3559
3560 at = NULL;
3561
3562 if (type == 0) for (i = 0; i < num_objects; i++)
3563 {
3564 if (-1 == (*get_type)(cd, i, &this_type))
3565 goto unknown_error;
3566
3567 if (type == 0)
3568 type = this_type;
3569 else if (type != this_type)
3570 {
3571 if (-1 == promote_to_common_type (type, this_type, &type))
3572 {
3573 _pSLclass_type_mismatch_error (type, this_type);
3574 return -1;
3575 }
3576 }
3577 }
3578
3579 if (type == 0)
3580 {
3581 SLang_verror (SL_TypeMismatch_Error, "Cannot convert an empty container object to an untyped array");
3582 return -1;
3583 }
3584
3585 dims = (SLindex_Type) num_objects;
3586
3587 if (NULL == (at = SLang_create_array (type, 0, NULL, &dims, 1)))
3588 return -1;
3589
3590 index_obj.o_data_type = SLANG_ARRAY_INDEX_TYPE;
3591 for (i = 0; i < num_objects; i++)
3592 {
3593 if (-1 == (*push)(cd, i))
3594 goto unknown_error;
3595
3596 index_obj.v.index_val = i;
3597 if (-1 == aput_from_indices (at, &index_obj, 1))
3598 goto return_error;
3599 }
3600
3601 return SLang_push_array (at, 1);
3602
3603 unknown_error:
3604 SLang_verror (SL_Unknown_Error, "Unknown array conversion error");
3605 return_error:
3606 if (at != NULL)
3607 free_array (at);
3608
3609 return -1;
3610 }
3611
array_binary_op_result(int op,SLtype a,SLtype b,SLtype * c)3612 static int array_binary_op_result (int op, SLtype a, SLtype b,
3613 SLtype *c)
3614 {
3615 (void) op;
3616 (void) a;
3617 (void) b;
3618 *c = SLANG_ARRAY_TYPE;
3619 return 1;
3620 }
3621
try_range_int_binary(SLang_Array_Type * at,int op,int x,int swap,VOID_STAR cp)3622 static int try_range_int_binary (SLang_Array_Type *at, int op, int x, int swap, VOID_STAR cp)
3623 {
3624 SLarray_Range_Array_Type *at_r;
3625 SLarray_Range_Array_Type rbuf;
3626 SLindex_Type first_index, last_index, delta;
3627 SLindex_Type num;
3628
3629 at_r = (SLarray_Range_Array_Type *)at->data;
3630 if ((at_r->has_first_index == 0)
3631 || (at_r->has_last_index == 0))
3632 return 0;
3633
3634 switch (op)
3635 {
3636 case SLANG_MINUS:
3637 if (swap)
3638 {
3639 first_index = x - at_r->first_index;
3640 last_index = x - at_r->last_index;
3641 delta = -at_r->delta;
3642 break;
3643 }
3644 x = -x;
3645 /* drop */
3646 case SLANG_PLUS:
3647 first_index = at_r->first_index + x;
3648 last_index = at_r->last_index + x;
3649 delta = at_r->delta;
3650 break;
3651
3652 case SLANG_TIMES:
3653 if (x == 0)
3654 return 0;
3655 first_index = at_r->first_index*x;
3656 last_index = at_r->last_index*x;
3657 delta = at_r->delta*x;
3658 break;
3659
3660 default:
3661 return 0;
3662 }
3663
3664 if (-1 == get_range_array_limits (&first_index, &last_index, &delta, &rbuf, &num))
3665 return -1;
3666 if ((SLuindex_Type)num != at->num_elements)
3667 return 0; /* This can happen if the integer arithmetic wrapped */
3668
3669 if (NULL == (at = create_range_array (&rbuf, num, SLANG_INT_TYPE, int_range_to_linear)))
3670 return -1;
3671
3672 *(SLang_Array_Type **)cp = at;
3673 return 1;
3674 }
3675
array_binary_op(int op,SLtype a_type,VOID_STAR ap,SLuindex_Type na,SLtype b_type,VOID_STAR bp,SLuindex_Type nb,VOID_STAR cp)3676 static int array_binary_op (int op,
3677 SLtype a_type, VOID_STAR ap, SLuindex_Type na,
3678 SLtype b_type, VOID_STAR bp, SLuindex_Type nb,
3679 VOID_STAR cp)
3680 {
3681 SLang_Array_Type *at, *bt, *ct;
3682 int (*binary_fun) (int,
3683 SLtype, VOID_STAR, SLuindex_Type,
3684 SLtype, VOID_STAR, SLuindex_Type,
3685 VOID_STAR);
3686 SLang_Class_Type *a_cl, *b_cl, *c_cl;
3687 int ret;
3688
3689 if (a_type == SLANG_ARRAY_TYPE)
3690 {
3691 if (na != 1)
3692 {
3693 _pSLang_verror (SL_NOT_IMPLEMENTED, "Binary operation on multiple arrays not implemented");
3694 return -1;
3695 }
3696
3697 at = *(SLang_Array_Type **) ap;
3698 if ((b_type == SLANG_INT_TYPE)
3699 && (nb == 1)
3700 && (at->flags & SLARR_DATA_VALUE_IS_RANGE)
3701 && (at->data_type == b_type))
3702 {
3703 int status = try_range_int_binary (at, op, *(int *)bp, 0, cp);
3704 if (status)
3705 return status;
3706 /* drop */
3707 }
3708
3709 if (-1 == coerse_array_to_linear (at))
3710 return -1;
3711 ap = at->data;
3712 a_type = at->data_type;
3713 na = at->num_elements;
3714 }
3715 else
3716 {
3717 at = NULL;
3718 }
3719
3720 if (b_type == SLANG_ARRAY_TYPE)
3721 {
3722 if (nb != 1)
3723 {
3724 _pSLang_verror (SL_NOT_IMPLEMENTED, "Binary operation on multiple arrays not implemented");
3725 return -1;
3726 }
3727
3728 bt = *(SLang_Array_Type **) bp;
3729
3730 if ((a_type == SLANG_INT_TYPE)
3731 && (na == 1)
3732 && (bt->flags & SLARR_DATA_VALUE_IS_RANGE)
3733 && (bt->data_type == a_type))
3734 {
3735 int status = try_range_int_binary (bt, op, *(int *)ap, 1, cp);
3736 if (status)
3737 return status;
3738 /* drop */
3739 }
3740
3741 if (-1 == coerse_array_to_linear (bt))
3742 return -1;
3743 bp = bt->data;
3744 b_type = bt->data_type;
3745 nb = bt->num_elements;
3746 }
3747 else
3748 {
3749 bt = NULL;
3750 }
3751
3752 if ((at != NULL) && (bt != NULL))
3753 {
3754 SLuindex_Type i, num_dims;
3755
3756 num_dims = at->num_dims;
3757
3758 if (num_dims != bt->num_dims)
3759 {
3760 _pSLang_verror (SL_TYPE_MISMATCH, "Arrays must have same dimensions for binary operation");
3761 return -1;
3762 }
3763
3764 for (i = 0; i < num_dims; i++)
3765 {
3766 if (at->dims[i] != bt->dims[i])
3767 {
3768 _pSLang_verror (SL_TYPE_MISMATCH, "Arrays must be the same for binary operation");
3769 return -1;
3770 }
3771 }
3772 }
3773
3774 a_cl = _pSLclass_get_class (a_type);
3775 if (a_type == b_type)
3776 b_cl = a_cl;
3777 else
3778 b_cl = _pSLclass_get_class (b_type);
3779
3780 if (NULL == (binary_fun = _pSLclass_get_binary_fun (op, a_cl, b_cl, &c_cl, 1)))
3781 return -1;
3782
3783 ct = NULL;
3784
3785 #if SLANG_USE_TMP_OPTIMIZATION
3786 /* If we are dealing with scalar (or vector) objects, and if the object
3787 * appears to be owned by the stack, then use it instead of creating a
3788 * new version. This can happen with code such as:
3789 * @ x = [1,2,3,4];
3790 * @ x = __tmp(x) + 1;
3791 */
3792 if ((c_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
3793 || (c_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR))
3794 {
3795 if ((at != NULL)
3796 && (at->num_refs == 1)
3797 && (at->data_type == c_cl->cl_data_type)
3798 && (0 == (at->flags & SLARR_DATA_VALUE_IS_READ_ONLY)))
3799 {
3800 ct = at;
3801 ct->num_refs = 2;
3802 }
3803 else if ((bt != NULL)
3804 && (bt->num_refs == 1)
3805 && (bt->data_type == c_cl->cl_data_type)
3806 && (0 == (bt->flags & SLARR_DATA_VALUE_IS_READ_ONLY)))
3807 {
3808 ct = bt;
3809 ct->num_refs = 2;
3810 }
3811 }
3812 #endif /* SLANG_USE_TMP_OPTIMIZATION */
3813
3814 if (ct == NULL)
3815 {
3816 if (at != NULL) ct = at; else ct = bt;
3817 ct = SLang_create_array1 (c_cl->cl_data_type, 0, NULL, ct->dims, ct->num_dims, 1);
3818 if (ct == NULL)
3819 return -1;
3820 }
3821
3822 if ((na == 0) || (nb == 0)) /* allow empty arrays */
3823 {
3824 *(SLang_Array_Type **) cp = ct;
3825 return 1;
3826 }
3827
3828 if (a_cl->cl_inc_ref != NULL)(*a_cl->cl_inc_ref)(a_type, ap, 1);
3829 if (b_cl->cl_inc_ref != NULL)(*b_cl->cl_inc_ref)(b_type, bp, 1);
3830 ret = (*binary_fun) (op, a_type, ap, na, b_type, bp, nb, ct->data);
3831 if (a_cl->cl_inc_ref != NULL)(*a_cl->cl_inc_ref)(a_type, ap, -1);
3832 if (b_cl->cl_inc_ref != NULL)(*b_cl->cl_inc_ref)(b_type, bp, -1);
3833
3834 if (ret == 1)
3835 {
3836 *(SLang_Array_Type **) cp = ct;
3837 return 1;
3838 }
3839
3840 free_array (ct);
3841 return -1;
3842 }
3843
3844 #if SLANG_OPTIMIZE_FOR_SPEED
_pSLarray_bin_op(SLang_Object_Type * a,SLang_Object_Type * b,int op)3845 int _pSLarray_bin_op (SLang_Object_Type *a, SLang_Object_Type *b, int op)
3846 {
3847 SLang_Array_Type *c;
3848
3849 if (-1 == array_binary_op (op, SLANG_ARRAY_TYPE, (VOID_STAR) &a->v, 1,
3850 SLANG_ARRAY_TYPE, (VOID_STAR) &b->v, 1,
3851 (VOID_STAR) &c))
3852 return -1;
3853
3854 return _pSLang_push_array (c, 1);
3855 }
3856 #endif
3857
array_eqs_method(SLtype a_type,VOID_STAR ap,SLtype b_type,VOID_STAR bp)3858 static int array_eqs_method (SLtype a_type, VOID_STAR ap, SLtype b_type, VOID_STAR bp)
3859 {
3860 SLang_Array_Type *at, *bt, *ct;
3861 SLuindex_Type i, num_dims, num_elements;
3862 SLang_Class_Type *a_cl, *b_cl, *c_cl;
3863 int is_eqs;
3864 int *ip, *ipmax;
3865
3866 if ((a_type != SLANG_ARRAY_TYPE) || (b_type != SLANG_ARRAY_TYPE))
3867 return 0;
3868
3869 at = *(SLang_Array_Type **) ap;
3870 bt = *(SLang_Array_Type **) bp;
3871
3872 if (at == bt)
3873 return 1;
3874
3875 if ((at->num_elements != (num_elements = bt->num_elements))
3876 || (at->num_dims != (num_dims = bt->num_dims)))
3877 return 0;
3878
3879 for (i = 0; i < num_dims; i++)
3880 {
3881 if (at->dims[i] != bt->dims[i])
3882 return 0;
3883 }
3884
3885 a_type = at->data_type;
3886 b_type = bt->data_type;
3887
3888 /* Check for an array of arrays. If so, the arrays must reference the same set arrays */
3889 if ((a_type == SLANG_ARRAY_TYPE) || (b_type == SLANG_ARRAY_TYPE))
3890 {
3891 if (a_type != b_type)
3892 return 0;
3893
3894 return !memcmp ((char *)at->data, (char *)bt->data, num_elements*sizeof(SLang_Array_Type*));
3895 }
3896
3897 a_cl = _pSLclass_get_class (a_type);
3898 if (a_type == b_type)
3899 b_cl = a_cl;
3900 else
3901 b_cl = _pSLclass_get_class (b_type);
3902
3903 if ((a_cl == b_cl)
3904 && ((a_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
3905 || (a_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR)))
3906 {
3907 if ((-1 == coerse_array_to_linear (at))
3908 || (-1 == coerse_array_to_linear (bt)))
3909 return -1;
3910
3911 return !memcmp ((char *)at->data, (char *)bt->data, num_elements*at->sizeof_type);
3912 }
3913
3914 /* Do it the hard way */
3915
3916 if (NULL == _pSLclass_get_binary_fun (SLANG_EQ, a_cl, b_cl, &c_cl, 0))
3917 return 0;
3918
3919 if (num_elements == 0)
3920 return 1;
3921
3922 if (-1 == array_binary_op (SLANG_EQ, SLANG_ARRAY_TYPE, ap, 1, SLANG_ARRAY_TYPE, bp, 1,
3923 (VOID_STAR) &ct))
3924 return -1;
3925
3926 /* ct is linear */
3927 num_elements = ct->num_elements;
3928 is_eqs = 1;
3929 if ((ct->data_type == SLANG_CHAR_TYPE) || (ct->data_type == SLANG_UCHAR_TYPE))
3930 {
3931 unsigned char *p, *pmax;
3932
3933 p = (unsigned char *)ct->data;
3934 pmax = p + num_elements;
3935
3936 while (p < pmax)
3937 {
3938 if (*p == 0)
3939 {
3940 is_eqs = 0;
3941 break;
3942 }
3943 p++;
3944 }
3945 free_array (ct);
3946 return is_eqs;
3947 }
3948
3949 if (ct->data_type != SLANG_INT_TYPE)
3950 {
3951 SLang_Array_Type *tmp;
3952 if (1 != _pSLarray_typecast (ct->data_type, (VOID_STAR) &ct, 1,
3953 SLANG_INT_TYPE, (VOID_STAR) &tmp, 1))
3954 {
3955 free_array (ct);
3956 return -1;
3957 }
3958 free_array (ct);
3959 ct = tmp;
3960 }
3961
3962 ip = (int *)ct->data;
3963 ipmax = ip + num_elements;
3964
3965 while (ip < ipmax)
3966 {
3967 if (*ip == 0)
3968 {
3969 is_eqs = 0;
3970 break;
3971 }
3972 ip++;
3973 }
3974 free_array (ct);
3975 return is_eqs;
3976 }
3977
is_null_intrinsic_intern(SLang_Array_Type * at)3978 static void is_null_intrinsic_intern (SLang_Array_Type *at)
3979 {
3980 SLang_Array_Type *bt;
3981
3982 bt = SLang_create_array (SLANG_CHAR_TYPE, 0, NULL, at->dims, at->num_dims);
3983 if (bt == NULL)
3984 return;
3985
3986 if (at->data_type == SLANG_NULL_TYPE)
3987 memset ((char *)bt->data, 1, bt->num_elements);
3988 else if (at->flags & SLARR_DATA_VALUE_IS_POINTER)
3989 {
3990 char *cdata, *cdata_max;
3991 char **data;
3992
3993 if (-1 == coerse_array_to_linear (at))
3994 {
3995 free_array (bt);
3996 return;
3997 }
3998
3999 cdata = (char *)bt->data;
4000 cdata_max = cdata + bt->num_elements;
4001 data = (char **)at->data;
4002
4003 while (cdata < cdata_max)
4004 {
4005 if (*data == NULL)
4006 *cdata = 1;
4007
4008 data++;
4009 cdata++;
4010 }
4011 }
4012
4013 SLang_push_array (bt, 1);
4014 }
4015
is_null_intrinsic(void)4016 static void is_null_intrinsic (void)
4017 {
4018 char ret = 0;
4019 SLang_Array_Type *at;
4020
4021 switch (SLang_peek_at_stack ())
4022 {
4023 case SLANG_ARRAY_TYPE:
4024 if (-1 == SLang_pop_array (&at, 0))
4025 return;
4026 is_null_intrinsic_intern (at);
4027 free_array (at);
4028 break;
4029
4030 case SLANG_NULL_TYPE:
4031 ret = 1;
4032 /* drop */
4033 default:
4034 (void) SLdo_pop();
4035 (void) SLang_push_char (ret);
4036 }
4037 }
4038
pop_bool_array(void)4039 static SLang_Array_Type *pop_bool_array (void)
4040 {
4041 SLang_Array_Type *at;
4042 SLang_Array_Type *tmp_at;
4043 int zero;
4044
4045 if (-1 == SLang_pop_array (&at, 1))
4046 return NULL;
4047
4048 if (at->data_type == SLANG_CHAR_TYPE)
4049 return at;
4050
4051 tmp_at = at;
4052 zero = 0;
4053 if (1 != array_binary_op (SLANG_NE,
4054 SLANG_ARRAY_TYPE, (VOID_STAR) &at, 1,
4055 SLANG_CHAR_TYPE, (VOID_STAR) &zero, 1,
4056 (VOID_STAR) &tmp_at))
4057 {
4058 free_array (at);
4059 return NULL;
4060 }
4061
4062 free_array (at);
4063 at = tmp_at;
4064 if (at->data_type != SLANG_CHAR_TYPE)
4065 {
4066 free_array (at);
4067 SLang_set_error (SL_TYPE_MISMATCH);
4068 return NULL;
4069 }
4070 return at;
4071 }
4072
pop_bool_array_and_start(int nargs,SLang_Array_Type ** atp,SLindex_Type * sp)4073 static int pop_bool_array_and_start (int nargs, SLang_Array_Type **atp, SLindex_Type *sp)
4074 {
4075 SLang_Array_Type *at;
4076 SLindex_Type istart = *sp;
4077 SLindex_Type num_elements;
4078
4079 if (nargs == 2)
4080 {
4081 if (-1 == SLang_pop_array_index (&istart))
4082 return -1;
4083 }
4084
4085 if (NULL == (at = pop_bool_array ()))
4086 return -1;
4087
4088 num_elements = (SLindex_Type) at->num_elements;
4089
4090 if (istart < 0)
4091 istart += num_elements;
4092
4093 if (istart < 0)
4094 {
4095 if (num_elements == 0)
4096 istart = 0;
4097 else
4098 {
4099 SLang_set_error (SL_Index_Error);
4100 free_array (at);
4101 return -1;
4102 }
4103 }
4104
4105 *atp = at;
4106 *sp = istart;
4107 return 0;
4108 }
4109
4110 /* Usage: i = wherefirst (at [,startpos]); */
array_where_first(void)4111 static void array_where_first (void)
4112 {
4113 SLang_Array_Type *at;
4114 char *a_data;
4115 SLindex_Type i, num_elements;
4116 SLindex_Type istart = 0;
4117
4118 istart = 0;
4119 if (-1 == pop_bool_array_and_start (SLang_Num_Function_Args, &at, &istart))
4120 return;
4121
4122 a_data = (char *) at->data;
4123 num_elements = (SLindex_Type) at->num_elements;
4124
4125 for (i = istart; i < num_elements; i++)
4126 {
4127 if (a_data[i] == 0)
4128 continue;
4129
4130 (void) SLang_push_array_index (i);
4131 free_array (at);
4132 return;
4133 }
4134 free_array (at);
4135 SLang_push_null ();
4136 }
4137
4138 /* Usage: i = wherelast (at [,startpos]); */
array_where_last(void)4139 static void array_where_last (void)
4140 {
4141 SLang_Array_Type *at;
4142 char *a_data;
4143 SLindex_Type i;
4144 SLindex_Type istart = 0;
4145
4146 istart = -1;
4147 if (-1 == pop_bool_array_and_start (SLang_Num_Function_Args, &at, &istart))
4148 return;
4149
4150 a_data = (char *) at->data;
4151
4152 i = istart + 1;
4153 if (i > (SLindex_Type)at->num_elements)
4154 i = (SLindex_Type) at->num_elements;
4155 while (i > 0)
4156 {
4157 i--;
4158 if (a_data[i] == 0)
4159 continue;
4160
4161 (void) SLang_push_array_index (i);
4162 free_array (at);
4163 return;
4164 }
4165 free_array (at);
4166 SLang_push_null ();
4167 }
4168
array_where_intern(int cmp)4169 static void array_where_intern (int cmp)
4170 {
4171 SLang_Array_Type *at, *bt;
4172 char *a_data;
4173 SLindex_Type *b_data;
4174 SLuindex_Type i, num_elements;
4175 SLindex_Type b_num;
4176 SLang_Ref_Type *ref = NULL;
4177
4178 if (SLang_Num_Function_Args == 2)
4179 {
4180 if (-1 == SLang_pop_ref (&ref))
4181 return;
4182 }
4183
4184 if (NULL == (at = pop_bool_array ()))
4185 return;
4186
4187 a_data = (char *) at->data;
4188 num_elements = at->num_elements;
4189
4190 b_num = 0;
4191 for (i = 0; i < num_elements; i++)
4192 if (cmp == (a_data[i] != 0)) b_num++;
4193
4194 if (NULL == (bt = SLang_create_array1 (SLANG_ARRAY_INDEX_TYPE, 0, NULL, &b_num, 1, 1)))
4195 goto return_error;
4196
4197 b_data = (SLindex_Type *) bt->data;
4198
4199 if (ref != NULL)
4200 {
4201 SLindex_Type *c_data;
4202 SLindex_Type c_num;
4203 SLang_Array_Type *ct;
4204
4205 c_num = num_elements - b_num;
4206 if (NULL == (ct = SLang_create_array1 (SLANG_ARRAY_INDEX_TYPE, 0, NULL, &c_num, 1, 1)))
4207 goto return_error;
4208 c_data = (SLindex_Type *) ct->data;
4209
4210 for (i = 0; i < num_elements; i++)
4211 {
4212 if (cmp == (a_data[i] != 0))
4213 *b_data++ = i;
4214 else
4215 *c_data++ = i;
4216 }
4217 (void) SLang_assign_to_ref (ref, SLANG_ARRAY_TYPE, &ct);
4218 /* Let any error propagate */
4219 free_array (ct);
4220 /* drop */
4221 }
4222 else
4223 {
4224 i = 0;
4225 while (b_num)
4226 {
4227 if (cmp == (a_data[i] != 0))
4228 {
4229 *b_data++ = i;
4230 b_num--;
4231 }
4232 i++;
4233 }
4234 }
4235
4236 (void) SLang_push_array (bt, 0);
4237 /* drop */
4238
4239 return_error:
4240 free_array (at);
4241 free_array (bt);
4242 if (ref != NULL)
4243 SLang_free_ref (ref);
4244 }
4245
array_where(void)4246 static void array_where (void)
4247 {
4248 array_where_intern (1);
4249 }
array_wherenot(void)4250 static void array_wherenot (void)
4251 {
4252 array_where_intern (0);
4253 }
4254
array_wherediff(void)4255 static void array_wherediff (void)
4256 {
4257 char *data, *isdiff;
4258 size_t sizeof_type;
4259 SLang_Class_Type *cl;
4260 SLuindex_Type i, num;
4261 SLindex_Type numdiff, *idx_ptr;
4262 SLang_Array_Type *at;
4263 SLang_Ref_Type *ref = NULL;
4264
4265 if (SLang_Num_Function_Args == 2)
4266 {
4267 if (-1 == SLang_pop_ref (&ref))
4268 return;
4269 }
4270
4271 if (-1 == SLang_pop_array (&at, 1))
4272 {
4273 SLang_free_ref (ref);
4274 return;
4275 }
4276 num = at->num_elements;
4277 if (NULL == (isdiff = (char *) SLmalloc (num+1)))
4278 goto free_and_return;
4279
4280 sizeof_type = at->sizeof_type;
4281 data = (char *) at->data;
4282
4283 if (num == 0)
4284 numdiff = 0;
4285 else
4286 {
4287 isdiff[0] = 1;
4288 numdiff = 1;
4289 }
4290
4291 cl = at->cl;
4292
4293 if (0 == (at->flags & SLARR_DATA_VALUE_IS_POINTER))
4294 {
4295 for (i = 1; i < num; i++)
4296 {
4297 char *lastdata = data;
4298 data += sizeof_type;
4299 isdiff[i] = (0 != memcmp (data, lastdata, sizeof_type));
4300 numdiff += isdiff[i];
4301 }
4302 }
4303 else
4304 {
4305 VOID_STAR *ptr;
4306
4307 if (NULL == cl->cl_cmp)
4308 {
4309 _pSLang_verror (SL_NOT_IMPLEMENTED,
4310 "%s does not have a comparision function defined",
4311 cl->cl_name);
4312 goto free_and_return;
4313 }
4314 ptr = (VOID_STAR *)at->data;
4315 for (i = 1; i < num; i++)
4316 {
4317 VOID_STAR *last_ptr = ptr;
4318 ptr++;
4319 if ((*ptr == NULL) || (*last_ptr == NULL))
4320 isdiff[i] = (*ptr != *last_ptr);
4321 else
4322 {
4323 int cmp;
4324 if (-1 == cl->cl_cmp (at->data_type, ptr, last_ptr, &cmp))
4325 goto free_and_return;
4326
4327 isdiff[i] = (cmp != 0);
4328 }
4329 numdiff += isdiff[i];
4330 }
4331 }
4332
4333 SLang_free_array (at);
4334 at = SLang_create_array1 (SLANG_ARRAY_INDEX_TYPE, 0, NULL, &numdiff, 1, 1);
4335 if (at == NULL)
4336 goto free_and_return;
4337
4338 idx_ptr = (SLindex_Type *) at->data;
4339 for (i = 0; i < num; i++)
4340 {
4341 if (isdiff[i]) *idx_ptr++ = i;
4342 }
4343 if (-1 == SLang_push_array (at, 0))
4344 goto free_and_return;
4345
4346 if (ref != NULL)
4347 {
4348 SLindex_Type numsame;
4349 numsame = (SLindex_Type)num - numdiff;
4350
4351 SLang_free_array (at); /* already pushed, reuse variable */
4352 at = SLang_create_array1 (SLANG_ARRAY_INDEX_TYPE, 0, NULL, &numsame, 1, 1);
4353 if (at == NULL)
4354 goto free_and_return;
4355 idx_ptr = (SLindex_Type *) at->data;
4356 for (i = 0; i < num; i++)
4357 {
4358 if (isdiff[i] == 0) *idx_ptr++ = i;
4359 }
4360 (void) SLang_assign_to_ref (ref, SLANG_ARRAY_TYPE, &at);
4361 /* drop */
4362 }
4363
4364 free_and_return:
4365
4366 SLfree (isdiff); /* NULL ok */
4367 SLang_free_array (at);
4368 if (ref != NULL)
4369 SLang_free_ref (ref);
4370 }
4371
4372 /* Up to the caller to ensure that ind_at is an index array */
do_array_reshape(SLang_Array_Type * at,SLang_Array_Type * ind_at)4373 static int do_array_reshape (SLang_Array_Type *at, SLang_Array_Type *ind_at)
4374 {
4375 SLindex_Type *dims;
4376 SLuindex_Type i, num_dims;
4377 SLuindex_Type num_elements;
4378
4379 num_dims = ind_at->num_elements;
4380 dims = (SLindex_Type *) ind_at->data;
4381
4382 num_elements = 1;
4383 for (i = 0; i < num_dims; i++)
4384 {
4385 SLindex_Type d = dims[i];
4386 if (d < 0)
4387 {
4388 _pSLang_verror (SL_INVALID_PARM, "reshape: dimension is less then 0");
4389 return -1;
4390 }
4391
4392 num_elements = (SLuindex_Type) (d * num_elements);
4393 }
4394
4395 if ((num_elements != at->num_elements)
4396 || (num_dims > SLARRAY_MAX_DIMS))
4397 {
4398 _pSLang_verror (SL_INVALID_PARM, "Unable to reshape array to specified size");
4399 return -1;
4400 }
4401
4402 for (i = 0; i < num_dims; i++)
4403 at->dims [i] = dims[i];
4404
4405 while (i < SLARRAY_MAX_DIMS)
4406 {
4407 at->dims [i] = 1;
4408 i++;
4409 }
4410
4411 at->num_dims = num_dims;
4412 return 0;
4413 }
4414
pop_1d_index_array(SLang_Array_Type ** ind_atp)4415 static int pop_1d_index_array (SLang_Array_Type **ind_atp)
4416 {
4417 SLang_Array_Type *ind_at;
4418
4419 *ind_atp = NULL;
4420 if (-1 == SLang_pop_array_of_type (&ind_at, SLANG_ARRAY_INDEX_TYPE))
4421 return -1;
4422 if (ind_at->num_dims != 1)
4423 {
4424 _pSLang_verror (SL_TYPE_MISMATCH, "Expecting 1-d array of indices");
4425 return -1;
4426 }
4427 *ind_atp = ind_at;
4428 return 0;
4429 }
4430
pop_reshape_args(SLang_Array_Type ** atp,SLang_Array_Type ** ind_atp)4431 static int pop_reshape_args (SLang_Array_Type **atp, SLang_Array_Type **ind_atp)
4432 {
4433 SLang_Array_Type *at, *ind_at;
4434
4435 *ind_atp = *atp = NULL;
4436
4437 if (-1 == pop_1d_index_array (&ind_at))
4438 return -1;
4439
4440 if (-1 == SLang_pop_array (&at, 1))
4441 {
4442 free_array (ind_at);
4443 return -1;
4444 }
4445
4446 *atp = at;
4447 *ind_atp = ind_at;
4448 return 0;
4449 }
4450
array_reshape(void)4451 static void array_reshape (void)
4452 {
4453 SLang_Array_Type *at, *ind_at;
4454
4455 if (-1 == pop_reshape_args (&at, &ind_at))
4456 return;
4457 (void) do_array_reshape (at, ind_at);
4458 free_array (at);
4459 free_array (ind_at);
4460 }
4461
_array_reshape(void)4462 static void _array_reshape (void)
4463 {
4464 SLang_Array_Type *at;
4465 SLang_Array_Type *new_at;
4466 SLang_Array_Type *ind_at;
4467
4468 if (-1 == pop_reshape_args (&at, &ind_at))
4469 return;
4470
4471 /* FIXME: Priority=low: duplicate_array could me modified to look at num_refs */
4472
4473 /* Now try to avoid the overhead of creating a new array if possible */
4474 if (at->num_refs == 1)
4475 {
4476 /* Great, we are the sole owner of this array. */
4477 if ((-1 == do_array_reshape (at, ind_at))
4478 || (-1 == SLclass_push_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR)at)))
4479 free_array (at);
4480 free_array (ind_at);
4481 return;
4482 }
4483
4484 new_at = SLang_duplicate_array (at);
4485 if (new_at != NULL)
4486 {
4487 if (0 == do_array_reshape (new_at, ind_at))
4488 (void) SLang_push_array (new_at, 0);
4489
4490 free_array (new_at);
4491 }
4492 free_array (at);
4493 free_array (ind_at);
4494 }
4495
4496 typedef struct
4497 {
4498 SLang_Array_Type *at;
4499 int is_array;
4500 size_t increment;
4501 char *addr;
4502 }
4503 Map_Arg_Type;
4504
4505 typedef struct
4506 {
4507 SLtype type;
4508 SLang_Array_Type *at;
4509 char *addr;
4510 }
4511 Map_Return_Type;
4512
free_arraymap_retvals(Map_Return_Type * r,SLuindex_Type n)4513 static void free_arraymap_retvals (Map_Return_Type *r, SLuindex_Type n)
4514 {
4515 SLuindex_Type i;
4516
4517 if (r == NULL)
4518 return;
4519
4520 for (i = 0; i < n; i++)
4521 {
4522 if (r[i].at != NULL)
4523 free_array (r[i].at);
4524 }
4525 SLfree ((char *)r);
4526 }
4527
free_arraymap_argvals(Map_Arg_Type * a,SLuindex_Type n)4528 static void free_arraymap_argvals (Map_Arg_Type *a, SLuindex_Type n)
4529 {
4530 SLuindex_Type i;
4531
4532 if (a == NULL)
4533 return;
4534
4535 for (i = 0; i < n; i++)
4536 {
4537 if (a[i].at != NULL)
4538 free_array (a[i].at);
4539 }
4540 SLfree ((char *)a);
4541 }
4542
pop_array_map_args(int num_arraymap_parms,Map_Return_Type ** retvalsp,SLuindex_Type * nretp,SLang_Name_Type ** funcp,Map_Arg_Type ** argvalsp,SLuindex_Type * nargsp,SLang_Array_Type ** at_controlp)4543 static int pop_array_map_args (int num_arraymap_parms,
4544 Map_Return_Type **retvalsp, SLuindex_Type *nretp,
4545 SLang_Name_Type **funcp,
4546 Map_Arg_Type **argvalsp, SLuindex_Type *nargsp,
4547 SLang_Array_Type **at_controlp)
4548 {
4549 Map_Return_Type *retvals = NULL;
4550 Map_Arg_Type *argvals = NULL;
4551 unsigned int i, nret, nargs=0;
4552 SLang_Array_Type *at_control;
4553 SLang_Name_Type *func = NULL;
4554
4555 if (-1 == SLreverse_stack (num_arraymap_parms))
4556 return -1;
4557
4558 nret = 0;
4559 while (nret < (unsigned int)num_arraymap_parms)
4560 {
4561 int type;
4562
4563 if (-1 == (type = SLang_peek_at_stack_n (nret)))
4564 goto return_error;
4565
4566 if (type != SLANG_DATATYPE_TYPE)
4567 break;
4568
4569 nret++;
4570 }
4571 if (nret == 0)
4572 retvals = NULL;
4573 else
4574 {
4575 if (NULL == (retvals = (Map_Return_Type *)SLcalloc(nret,sizeof(Map_Return_Type))))
4576 goto return_error;
4577
4578 for (i = 0; i < nret; i++)
4579 {
4580 num_arraymap_parms--;
4581 if (-1 == SLang_pop_datatype (&retvals[i].type))
4582 goto return_error;
4583 }
4584 }
4585
4586 if (num_arraymap_parms != 0)
4587 {
4588 num_arraymap_parms--;
4589 func = SLang_pop_function ();
4590 }
4591 if (func == NULL)
4592 {
4593 SLang_verror (SL_INVALID_PARM, "Expecting a reference to a function");
4594 goto return_error;
4595 }
4596
4597 if (num_arraymap_parms == 0)
4598 {
4599 SLang_verror (SL_NUM_ARGS_ERROR, "array_map requires at least one function argument");
4600 goto return_error;
4601 }
4602
4603 nargs = num_arraymap_parms;
4604 if (NULL == (argvals = (Map_Arg_Type *)SLcalloc (nargs, sizeof(Map_Arg_Type))))
4605 goto return_error;
4606
4607 at_control = NULL;
4608 for (i = 0; i < nargs; i++)
4609 {
4610 SLang_Array_Type *at;
4611
4612 argvals[i].is_array = (SLANG_ARRAY_TYPE == SLang_peek_at_stack ());
4613
4614 num_arraymap_parms--;
4615 if (-1 == SLang_pop_array (&at, 1))
4616 goto return_error;
4617
4618 if ((at_control == NULL) && (argvals[i].is_array))
4619 at_control = at;
4620 argvals[i].at = at;
4621 argvals[i].addr = (char *)at->data;
4622 }
4623
4624 if (at_control == NULL)
4625 at_control = argvals[0].at;
4626
4627 for (i = 0; i < nret; i++)
4628 {
4629 SLtype t = retvals[i].type;
4630
4631 if (t == SLANG_UNDEFINED_TYPE) /* Void_Type */
4632 {
4633 retvals[i].at = NULL;
4634 retvals[i].addr = NULL;
4635 }
4636 else
4637 {
4638 SLang_Array_Type *at;
4639 if (NULL == (at = SLang_create_array (t, 0, NULL, at_control->dims, at_control->num_dims)))
4640 goto return_error;
4641 retvals[i].at = at;
4642 retvals[i].addr = (char *)at->data;
4643 }
4644 }
4645
4646 *nretp = nret;
4647 *retvalsp = retvals;
4648 *funcp = func;
4649 *nargsp = nargs;
4650 *argvalsp = argvals;
4651 *at_controlp = at_control;
4652 return 0;
4653
4654 return_error:
4655 (void) SLdo_pop_n (num_arraymap_parms);
4656 free_arraymap_retvals (retvals, nret);
4657 SLang_free_function (func); /* NULL ok */
4658 free_arraymap_argvals (argvals, nargs);
4659 return -1;
4660 }
4661
4662 /* Usage: array_map ([Return-Type...,] &func, args...); */
array_map(void)4663 static void array_map (void)
4664 {
4665 Map_Arg_Type *argvals;
4666 Map_Return_Type *retvals;
4667 SLuindex_Type i, nrets, nargs;
4668 SLang_Array_Type *at_control;
4669 SLang_Name_Type *func;
4670 SLuindex_Type num_elements;
4671 int num_arraymap_parms;
4672
4673 num_arraymap_parms = SLang_Num_Function_Args;
4674 if (num_arraymap_parms < 2)
4675 {
4676 _pSLang_verror (SL_INVALID_PARM,
4677 "Usage: array_map ([Return-Types...,] &func, args...)");
4678 SLdo_pop_n (num_arraymap_parms);
4679 return;
4680 }
4681
4682 if (-1 == pop_array_map_args (num_arraymap_parms, &retvals, &nrets, &func,
4683 &argvals, &nargs, &at_control))
4684 return;
4685
4686 num_elements = at_control->num_elements;
4687
4688 for (i = 0; i < nargs; i++)
4689 {
4690 SLang_Array_Type *ati = argvals[i].at;
4691 /* FIXME: Priority = low: The actual dimensions should be compared. */
4692 if (ati->num_elements == num_elements)
4693 argvals[i].increment = ati->sizeof_type;
4694 else
4695 argvals[i].increment = 0;
4696
4697 if ((num_elements != 0)
4698 && (ati->num_elements == 0))
4699 {
4700 _pSLang_verror (SL_TypeMismatch_Error, "array_map: function argument %lu of %lu is an empty array",
4701 (unsigned long) (i+1), (unsigned long)nargs);
4702 goto return_error;
4703 }
4704 }
4705
4706 for (i = 0; i < num_elements; i++)
4707 {
4708 unsigned int j;
4709 Map_Return_Type *ret;
4710
4711 if (-1 == SLang_start_arg_list ())
4712 goto return_error;
4713
4714 for (j = 0; j < nargs; j++)
4715 {
4716 if (-1 == push_element_at_addr (argvals[j].at,
4717 (VOID_STAR) argvals[j].addr,
4718 1))
4719 {
4720 SLdo_pop_n (j);
4721 goto return_error;
4722 }
4723
4724 argvals[j].addr += argvals[j].increment;
4725 }
4726
4727 if (-1 == SLang_end_arg_list ())
4728 {
4729 SLdo_pop_n (nargs);
4730 goto return_error;
4731 }
4732
4733 if (-1 == SLexecute_function (func))
4734 goto return_error;
4735
4736 ret = retvals + nrets;
4737 while (ret > retvals)
4738 {
4739 SLang_Array_Type *at;
4740 SLang_Class_Type *cl;
4741
4742 ret--;
4743 if (NULL == (at = ret->at))
4744 continue;
4745
4746 cl = at->cl;
4747
4748 if (0 == (at->flags & SLARR_DATA_VALUE_IS_POINTER))
4749 {
4750 if (-1 == cl->cl_apop (at->data_type, (VOID_STAR) ret->addr))
4751 goto return_error;
4752 }
4753 else
4754 {
4755 /* Use aput_get_data_to_put to allow NULLs */
4756 SLuindex_Type nelements = 1;
4757 int allow_array = 0;
4758 SLang_Array_Type *unused_array;
4759 char *data_to_put;
4760 SLuindex_Type unused_data_increment;
4761
4762 if (-1 == aput_get_data_to_put (cl, nelements, allow_array, &unused_array, &data_to_put, &unused_data_increment))
4763 goto return_error;
4764
4765 if (-1 == transfer_n_elements(at, ret->addr, data_to_put, at->sizeof_type, 1, 1))
4766 {
4767 (*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR) data_to_put);
4768 goto return_error;
4769 }
4770 (*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR) data_to_put);
4771 }
4772 ret->addr += at->sizeof_type;
4773 }
4774 }
4775
4776 for (i = 0; i < nrets; i++)
4777 {
4778 if (retvals[i].at != NULL)
4779 (void) SLang_push_array (retvals[i].at, 0);
4780 }
4781
4782 /* drop */
4783
4784 return_error:
4785 free_arraymap_argvals (argvals, nargs);
4786 SLang_free_function (func);
4787 free_arraymap_retvals (retvals, nrets);
4788 }
4789
push_array_shape(SLang_Array_Type * at)4790 static int push_array_shape (SLang_Array_Type *at)
4791 {
4792 SLang_Array_Type *bt;
4793 SLindex_Type num_dims;
4794 SLindex_Type *bdata, *a_dims;
4795 int i;
4796
4797 num_dims = (SLindex_Type)at->num_dims;
4798 if (NULL == (bt = SLang_create_array (SLANG_ARRAY_INDEX_TYPE, 0, NULL, &num_dims, 1)))
4799 return -1;
4800
4801 a_dims = at->dims;
4802 bdata = (SLindex_Type *) bt->data;
4803 for (i = 0; i < num_dims; i++) bdata [i] = a_dims [i];
4804
4805 return SLang_push_array (bt, 1);
4806 }
4807
array_info(void)4808 static void array_info (void)
4809 {
4810 SLang_Array_Type *at;
4811
4812 if (-1 == pop_array (&at, 1))
4813 return;
4814
4815 if (0 == push_array_shape (at))
4816 {
4817 (void) SLang_push_integer ((int) at->num_dims);
4818 (void) SLang_push_datatype (at->data_type);
4819 }
4820 free_array (at);
4821 }
4822
array_shape(void)4823 static void array_shape (void)
4824 {
4825 SLang_Array_Type *at;
4826
4827 if (-1 == pop_array (&at, 1))
4828 return;
4829
4830 (void) push_array_shape (at);
4831 free_array (at);
4832 }
4833
4834 #if 0
4835 static int pop_int_indices (SLindex_Type *dims, unsigned int ndims)
4836 {
4837 int i;
4838
4839 if (ndims > SLARRAY_MAX_DIMS)
4840 {
4841 _pSLang_verror (SL_INVALID_PARM, "Too many dimensions specified");
4842 return -1;
4843 }
4844 for (i = (int)ndims-1; i >= 0; i--)
4845 {
4846 if (-1 == SLang_pop_integer (dims+i))
4847 return -1;
4848 }
4849 return 0;
4850 }
4851 /* Usage: aput(v, x, i,..,k) */
4852 static void aput_intrin (void)
4853 {
4854 char *data_to_put;
4855 SLuindex_Type data_increment;
4856 SLindex_Type indices[SLARRAY_MAX_DIMS];
4857 int is_ptr;
4858 unsigned int ndims = SLang_Num_Function_Args-2;
4859 SLang_Array_Type *at, *bt_unused;
4860
4861 if (-1 == pop_int_indices (indices, ndims))
4862 return;
4863
4864 if (-1 == SLang_pop_array (&at, 1))
4865 return;
4866
4867 if (at->num_dims != ndims)
4868 {
4869 SLang_set_error (SL_Index_Error);
4870 free_array (at);
4871 return;
4872 }
4873
4874 is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
4875
4876 if (-1 == aput_get_data_to_put (at->cl, 1, 0, &bt_unused, &data_to_put, &data_increment))
4877 {
4878 free_array (at);
4879 return;
4880 }
4881
4882 (void) _pSLarray_aput_transfer_elem (at, indices, (VOID_STAR)data_to_put,
4883 at->sizeof_type, is_ptr);
4884 if (is_ptr)
4885 (*at->cl->cl_destroy) (at->cl->cl_data_type, (VOID_STAR) data_to_put);
4886
4887 free_array (at);
4888 }
4889
4890 /* Usage: x_i..k = aget(x, i,..,k) */
4891 static void aget_intrin (void)
4892 {
4893 SLindex_Type dims[SLARRAY_MAX_DIMS];
4894 unsigned int ndims = (unsigned int) (SLang_Num_Function_Args-1);
4895 SLang_Array_Type *at;
4896 VOID_STAR data;
4897
4898 if (-1 == pop_int_indices (dims, ndims))
4899 return;
4900
4901 if (-1 == pop_array (&at, 1))
4902 return;
4903
4904 if (at->num_dims != ndims)
4905 {
4906 SLang_set_error (SL_Index_Error);
4907 free_array (at);
4908 return;
4909 }
4910
4911 if ((ndims == 1)
4912 && (at->index_fun == linear_get_data_addr))
4913 {
4914 SLindex_Type i = dims[0];
4915 if (i < 0)
4916 {
4917 i += at->dims[0];
4918 if (i < 0)
4919 i = at->dims[0];
4920 }
4921 if (i >= at->dims[0])
4922 {
4923 SLang_set_error (SL_Index_Error);
4924 free_array (at);
4925 return;
4926 }
4927 if (at->data_type == SLANG_INT_TYPE)
4928 {
4929 (void) SLclass_push_int_obj (SLANG_INT_TYPE, *((int *)at->data + i));
4930 goto free_and_return;
4931 }
4932 #if SLANG_HAS_FLOAT
4933 if (at->data_type == SLANG_DOUBLE_TYPE)
4934 {
4935 (void) SLclass_push_double_obj (SLANG_DOUBLE_TYPE, *((double *)at->data + i));
4936 goto free_and_return;
4937 }
4938 #endif
4939 if (at->data_type == SLANG_CHAR_TYPE)
4940 {
4941 (void) SLclass_push_int_obj (SLANG_UCHAR_TYPE, *((unsigned char *)at->data + i));
4942 goto free_and_return;
4943 }
4944 data = (VOID_STAR) ((char *)at->data + (SLuindex_Type)i * at->sizeof_type);
4945 }
4946 else data = get_data_addr (at, dims);
4947
4948 if (data != NULL)
4949 (void) push_element_at_addr (at, (VOID_STAR) data, ndims);
4950
4951 free_and_return:
4952 free_array (at);
4953 }
4954 #endif
4955
pop_byte_order(int * bop)4956 static int pop_byte_order (int *bop)
4957 {
4958 int bo;
4959
4960 if (-1 == SLang_pop_integer (&bo))
4961 return -1;
4962
4963 switch (bo)
4964 {
4965 case 'n': case 'N': case '=': bo = _pSLANG_BYTEORDER_NATIVE; break;
4966 case 'b': case 'B': case '>': bo = _pSLANG_BYTEORDER_BIGE; break;
4967 case 'l': case 'L': case '<': bo = _pSLANG_BYTEORDER_LILE; break;
4968 default:
4969 SLang_verror (SL_InvalidParm_Error, "Invalid byte-order specifier, expecting one of 'B', 'L', or 'N'");
4970 return -1;
4971 }
4972
4973 *bop = bo;
4974 return 0;
4975 }
4976
4977 /* Usage b = _array_byteswap (a, from, to);
4978 */
byteswap_intrin(void)4979 static void byteswap_intrin (void)
4980 {
4981 SLang_Array_Type *at, *bt;
4982 int from, to;
4983 int converted_scalar;
4984
4985 if (SLang_Num_Function_Args != 3)
4986 {
4987 SLang_verror (SL_Usage_Error, "\
4988 Usage: b = _array_byteswap (a, from, to);\
4989 from/to is one of: 'B' (big), 'L' (little), or 'N'(native) endian order");
4990 return;
4991 }
4992 if ((-1 == pop_byte_order (&to)) || (-1 == pop_byte_order (&from)))
4993 return;
4994
4995 if (-1 == SLang_pop_array (&at, 1))
4996 return;
4997
4998 converted_scalar = at->flags & SLARR_DERIVED_FROM_SCALAR;
4999
5000 bt = _pSLpack_byteswap_array (at, from, to);
5001 SLang_free_array (at);
5002 if (bt == NULL)
5003 return;
5004
5005 if (converted_scalar)
5006 (void) push_element_at_index (bt, 0);
5007 else
5008 (void) SLang_push_array (bt, 0);
5009
5010 SLang_free_array (bt);
5011 }
5012
5013
5014 static SLang_Intrin_Fun_Type Array_Table [] =
5015 {
5016 MAKE_INTRINSIC_0("array_map", array_map, SLANG_VOID_TYPE),
5017 MAKE_INTRINSIC_0("array_sort", array_sort_intrin, SLANG_VOID_TYPE),
5018 MAKE_INTRINSIC_0("get_default_sort_method", get_default_sort_method, SLANG_VOID_TYPE),
5019 MAKE_INTRINSIC_S("set_default_sort_method", set_default_sort_method, SLANG_VOID_TYPE),
5020 MAKE_INTRINSIC_1("array_to_bstring", array_to_bstring, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE),
5021 MAKE_INTRINSIC_1("bstring_to_array", bstring_to_array, SLANG_VOID_TYPE, SLANG_BSTRING_TYPE),
5022 MAKE_INTRINSIC("init_char_array", init_char_array, SLANG_VOID_TYPE, 0),
5023 MAKE_INTRINSIC_0("_isnull", is_null_intrinsic, SLANG_VOID_TYPE),
5024 MAKE_INTRINSIC_0("array_info", array_info, SLANG_VOID_TYPE),
5025 MAKE_INTRINSIC_0("array_shape", array_shape, SLANG_VOID_TYPE),
5026 MAKE_INTRINSIC_0("where", array_where, SLANG_VOID_TYPE),
5027 MAKE_INTRINSIC_0("wherenot", array_wherenot, SLANG_VOID_TYPE),
5028 MAKE_INTRINSIC_0("wherefirst", array_where_first, SLANG_VOID_TYPE),
5029 MAKE_INTRINSIC_0("wherelast", array_where_last, SLANG_VOID_TYPE),
5030 MAKE_INTRINSIC_0("wherediff", array_wherediff, SLANG_VOID_TYPE),
5031 MAKE_INTRINSIC_0("reshape", array_reshape, SLANG_VOID_TYPE),
5032 MAKE_INTRINSIC_0("_reshape", _array_reshape, SLANG_VOID_TYPE),
5033 MAKE_INTRINSIC_0("_array_byteswap", byteswap_intrin, SLANG_VOID_TYPE),
5034 #if 0
5035 MAKE_INTRINSIC_0("__aget", aget_intrin, SLANG_VOID_TYPE),
5036 MAKE_INTRINSIC_0("__aput", aput_intrin, SLANG_VOID_TYPE),
5037 #endif
5038 SLANG_END_INTRIN_FUN_TABLE
5039 };
5040
array_string(SLtype type,VOID_STAR v)5041 static char *array_string (SLtype type, VOID_STAR v)
5042 {
5043 SLang_Array_Type *at;
5044 char buf[512];
5045 unsigned int i, num_dims;
5046 SLindex_Type *dims;
5047
5048 at = *(SLang_Array_Type **) v;
5049 type = at->data_type;
5050 num_dims = at->num_dims;
5051 dims = at->dims;
5052
5053 sprintf (buf, "%s[%ld", SLclass_get_datatype_name (type), (long)at->dims[0]);
5054
5055 for (i = 1; i < num_dims; i++)
5056 sprintf (buf + strlen(buf), ",%ld", (long)dims[i]);
5057 strcat (buf, "]");
5058
5059 return SLmake_string (buf);
5060 }
5061
array_destroy(SLtype type,VOID_STAR v)5062 static void array_destroy (SLtype type, VOID_STAR v)
5063 {
5064 SLang_Array_Type *at = *(SLang_Array_Type **) v;
5065
5066 (void) type;
5067 if ((at != NULL)
5068 && (at->num_refs > 1))
5069 {
5070 at->num_refs -= 1;
5071 return;
5072 }
5073 free_array (*(SLang_Array_Type **) v);
5074 }
5075
array_push(SLtype type,VOID_STAR v)5076 static int array_push (SLtype type, VOID_STAR v)
5077 {
5078 SLang_Array_Type *at;
5079
5080 (void) type;
5081
5082 at = *(SLang_Array_Type **) v;
5083 if (at == NULL)
5084 return SLang_push_null ();
5085
5086 at->num_refs += 1;
5087
5088 if (0 == SLclass_push_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR) at))
5089 return 0;
5090
5091 at->num_refs -= 1;
5092 return -1;
5093 }
5094
SLang_push_array(SLang_Array_Type * at,int free_flag)5095 int SLang_push_array (SLang_Array_Type *at, int free_flag)
5096 {
5097 if (at == NULL)
5098 return SLang_push_null ();
5099
5100 return _pSLang_push_array (at, free_flag);
5101 }
5102
5103 /* Intrinsic arrays are not stored in a variable. So, the address that
5104 * would contain the variable holds the array address.
5105 */
array_push_intrinsic(SLtype type,VOID_STAR v)5106 static int array_push_intrinsic (SLtype type, VOID_STAR v)
5107 {
5108 (void) type;
5109 return SLang_push_array ((SLang_Array_Type *) v, 0);
5110 }
5111
_pSLarray_add_bin_op(SLtype type)5112 int _pSLarray_add_bin_op (SLtype type)
5113 {
5114 SL_OOBinary_Type *ab;
5115 SLang_Class_Type *cl;
5116
5117 if (type == SLANG_VOID_TYPE)
5118 {
5119 cl = _pSLclass_get_class (SLANG_ARRAY_TYPE);
5120 if ((cl->cl_this_binary_void != NULL)
5121 || (cl->cl_void_binary_this != NULL))
5122 return 0;
5123 }
5124 else
5125 {
5126 cl = _pSLclass_get_class (type);
5127 ab = cl->cl_binary_ops;
5128
5129 while (ab != NULL)
5130 {
5131 if (ab->data_type == SLANG_ARRAY_TYPE)
5132 return 0;
5133 ab = ab->next;
5134 }
5135 }
5136
5137 if ((-1 == SLclass_add_binary_op (SLANG_ARRAY_TYPE, type, array_binary_op, array_binary_op_result))
5138 || (-1 == SLclass_add_binary_op (type, SLANG_ARRAY_TYPE, array_binary_op, array_binary_op_result)))
5139 return -1;
5140
5141 return 0;
5142 }
5143
5144 static SLang_Array_Type *
do_array_math_op(int op,int unary_type,SLang_Array_Type * at,SLuindex_Type na)5145 do_array_math_op (int op, int unary_type,
5146 SLang_Array_Type *at, SLuindex_Type na)
5147 {
5148 SLtype a_type, b_type;
5149 int (*f) (int, SLtype, VOID_STAR, SLuindex_Type, VOID_STAR);
5150 SLang_Array_Type *bt;
5151 SLang_Class_Type *b_cl;
5152
5153 if (na != 1)
5154 {
5155 _pSLang_verror (SL_NOT_IMPLEMENTED, "Operation restricted to 1 array");
5156 return NULL;
5157 }
5158
5159 a_type = at->data_type;
5160 if (NULL == (f = _pSLclass_get_unary_fun (op, at->cl, &b_cl, unary_type)))
5161 return NULL;
5162 b_type = b_cl->cl_data_type;
5163
5164 if (-1 == coerse_array_to_linear (at))
5165 return NULL;
5166
5167 #if SLANG_USE_TMP_OPTIMIZATION
5168 /* If we are dealing with scalar (or vector) objects, and if the object
5169 * appears to be owned by the stack, then use it instead of creating a
5170 * new version. This can happen with code such as:
5171 * @ x = [1,2,3,4];
5172 * @ x = UNARY_OP(__tmp(x));
5173 */
5174 if (((b_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
5175 || (b_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR))
5176 && (at->num_refs == 1)
5177 && (at->data_type == b_cl->cl_data_type)
5178 && (0 == (at->flags & SLARR_DATA_VALUE_IS_READ_ONLY)))
5179 {
5180 bt = at;
5181 bt->num_refs = 2;
5182 }
5183 else
5184 #endif /* SLANG_USE_TMP_OPTIMIZATION */
5185 if (NULL == (bt = SLang_create_array1 (b_type, 0, NULL, at->dims, at->num_dims, 1)))
5186 return NULL;
5187
5188 if (1 != (*f)(op, a_type, at->data, at->num_elements, bt->data))
5189 {
5190 free_array (bt);
5191 return NULL;
5192 }
5193 return bt;
5194 }
5195
5196 static int
array_unary_op_result(int op,SLtype a,SLtype * b)5197 array_unary_op_result (int op, SLtype a, SLtype *b)
5198 {
5199 (void) op;
5200 (void) a;
5201 *b = SLANG_ARRAY_TYPE;
5202 return 1;
5203 }
5204
5205 static int
array_unary_op(int op,SLtype a,VOID_STAR ap,SLuindex_Type na,VOID_STAR bp)5206 array_unary_op (int op,
5207 SLtype a, VOID_STAR ap, SLuindex_Type na,
5208 VOID_STAR bp)
5209 {
5210 SLang_Array_Type *at;
5211
5212 (void) a;
5213 at = *(SLang_Array_Type **) ap;
5214 if (NULL == (at = do_array_math_op (op, SLANG_BC_UNARY, at, na)))
5215 {
5216 if (SLang_get_error ()) return -1;
5217 return 0;
5218 }
5219 *(SLang_Array_Type **) bp = at;
5220 return 1;
5221 }
5222
5223 static int
array_math_op(int op,SLtype a,VOID_STAR ap,SLuindex_Type na,VOID_STAR bp)5224 array_math_op (int op,
5225 SLtype a, VOID_STAR ap, SLuindex_Type na,
5226 VOID_STAR bp)
5227 {
5228 SLang_Array_Type *at;
5229
5230 (void) a;
5231 at = *(SLang_Array_Type **) ap;
5232 if (NULL == (at = do_array_math_op (op, SLANG_BC_MATH_UNARY, at, na)))
5233 {
5234 if (SLang_get_error ()) return -1;
5235 return 0;
5236 }
5237 *(SLang_Array_Type **) bp = at;
5238 return 1;
5239 }
5240
5241 static int
array_app_op(int op,SLtype a,VOID_STAR ap,SLuindex_Type na,VOID_STAR bp)5242 array_app_op (int op,
5243 SLtype a, VOID_STAR ap, SLuindex_Type na,
5244 VOID_STAR bp)
5245 {
5246 SLang_Array_Type *at;
5247
5248 (void) a;
5249 at = *(SLang_Array_Type **) ap;
5250 if (NULL == (at = do_array_math_op (op, SLANG_BC_APP_UNARY, at, na)))
5251 {
5252 if (SLang_get_error ()) return -1;
5253 return 0;
5254 }
5255 *(SLang_Array_Type **) bp = at;
5256 return 1;
5257 }
5258
5259 /* Typecast array from a_type to b_type */
5260 int
_pSLarray_typecast(SLtype a_type,VOID_STAR ap,SLuindex_Type na,SLtype b_type,VOID_STAR bp,int is_implicit)5261 _pSLarray_typecast (SLtype a_type, VOID_STAR ap, SLuindex_Type na,
5262 SLtype b_type, VOID_STAR bp,
5263 int is_implicit)
5264 {
5265 SLang_Array_Type *at, *bt;
5266 SLang_Class_Type *b_cl;
5267 int no_init;
5268 int (*t) (SLtype, VOID_STAR, SLuindex_Type, SLtype, VOID_STAR);
5269
5270 if (na != 1)
5271 {
5272 _pSLang_verror (SL_NOT_IMPLEMENTED, "typecast of multiple arrays not implemented");
5273 return -1;
5274 }
5275
5276 at = *(SLang_Array_Type **) ap;
5277 a_type = at->data_type;
5278
5279 if (a_type == b_type)
5280 {
5281 at->num_refs += 1;
5282 *(SLang_Array_Type **) bp = at;
5283 return 1;
5284 }
5285
5286 /* check for alias */
5287 if (at->cl == (b_cl = _pSLclass_get_class (b_type)))
5288 {
5289 at->num_refs += 1;
5290
5291 /* Force to the desired type. Hopefully there will be no consequences
5292 * from this.
5293 */
5294 at->data_type = b_cl->cl_data_type;
5295 *(SLang_Array_Type **) bp = at;
5296 return 1;
5297 }
5298
5299 if (at->flags & SLARR_DATA_VALUE_IS_RANGE)
5300 {
5301 if (-1 == try_typecast_range_array (at, b_type, &bt))
5302 return -1;
5303 if (bt != NULL)
5304 {
5305 *(SLang_Array_Type **) bp = bt;
5306 return 1;
5307 }
5308 /* Couldn't do it, so drop */
5309 }
5310
5311 /* Typecast NULL array to the desired type with elements set to NULL */
5312 if ((a_type == SLANG_NULL_TYPE)
5313 && ((b_cl->cl_class_type == SLANG_CLASS_TYPE_MMT)
5314 || (b_cl->cl_class_type == SLANG_CLASS_TYPE_PTR)))
5315 {
5316 if (NULL == (bt = SLang_create_array1 (b_type, 0, NULL, at->dims, at->num_dims, 0)))
5317 return -1;
5318
5319 *(SLang_Array_Type **) bp = bt;
5320 return 1;
5321 }
5322
5323 if (NULL == (t = _pSLclass_get_typecast (a_type, b_type, is_implicit)))
5324 return -1;
5325
5326 if (-1 == coerse_array_to_linear (at))
5327 return -1;
5328
5329 no_init = ((b_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
5330 || (b_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR));
5331
5332 if (NULL == (bt = SLang_create_array1 (b_type, 0, NULL, at->dims, at->num_dims, no_init)))
5333 return -1;
5334
5335 if (1 == (*t) (a_type, at->data, at->num_elements, b_type, bt->data))
5336 {
5337 *(SLang_Array_Type **) bp = bt;
5338 return 1;
5339 }
5340
5341 free_array (bt);
5342 return 0;
5343 }
5344
duplicate_range_array(SLang_Array_Type * at)5345 static SLang_Array_Type *duplicate_range_array (SLang_Array_Type *at)
5346 {
5347 SLarray_Range_Array_Type *r = (SLarray_Range_Array_Type *)at->data;
5348 return create_range_array (r, (SLindex_Type)at->num_elements, at->data_type, r->to_linear_fun);
5349 }
5350
SLang_duplicate_array(SLang_Array_Type * at)5351 SLang_Array_Type *SLang_duplicate_array (SLang_Array_Type *at)
5352 {
5353 SLang_Array_Type *bt;
5354 char *data, *a_data;
5355 SLuindex_Type i, num_elements;
5356 size_t sizeof_type, size;
5357 int (*cl_acopy) (SLtype, VOID_STAR, VOID_STAR);
5358 SLtype type;
5359
5360 if (at->flags & SLARR_DATA_VALUE_IS_RANGE)
5361 return duplicate_range_array (at);
5362
5363 if (-1 == coerse_array_to_linear (at))
5364 return NULL;
5365
5366 type = at->data_type;
5367 num_elements = at->num_elements;
5368 sizeof_type = at->sizeof_type;
5369
5370 if (NULL == (data = (char *)_SLcalloc (num_elements, sizeof_type)))
5371 return NULL;
5372
5373 size = num_elements * sizeof_type;
5374
5375 if (NULL == (bt = SLang_create_array (type, 0, (VOID_STAR)data, at->dims, at->num_dims)))
5376 {
5377 SLfree (data);
5378 return NULL;
5379 }
5380
5381 a_data = (char *) at->data;
5382 if (0 == (at->flags & SLARR_DATA_VALUE_IS_POINTER))
5383 {
5384 SLMEMCPY (data, a_data, size);
5385 return bt;
5386 }
5387
5388 SLMEMSET (data, 0, size);
5389
5390 cl_acopy = at->cl->cl_acopy;
5391 for (i = 0; i < num_elements; i++)
5392 {
5393 if (NULL != *(VOID_STAR *) a_data)
5394 {
5395 if (-1 == (*cl_acopy) (type, (VOID_STAR) a_data, (VOID_STAR) data))
5396 {
5397 free_array (bt);
5398 return NULL;
5399 }
5400 }
5401
5402 data += sizeof_type;
5403 a_data += sizeof_type;
5404 }
5405
5406 return bt;
5407 }
5408
array_dereference(SLtype type,VOID_STAR addr)5409 static int array_dereference (SLtype type, VOID_STAR addr)
5410 {
5411 SLang_Array_Type *at;
5412
5413 (void) type;
5414 at = SLang_duplicate_array (*(SLang_Array_Type **) addr);
5415 if (at == NULL) return -1;
5416 return SLang_push_array (at, 1);
5417 }
5418
5419 /* This function gets called via, e.g., @Array_Type (Double_Type, [10,20]);
5420 */
5421 static int
array_datatype_deref(SLtype type)5422 array_datatype_deref (SLtype type)
5423 {
5424 SLang_Array_Type *ind_at;
5425 SLang_Array_Type *at;
5426
5427 #if 0
5428 /* The parser generated code for this as if a function call were to be
5429 * made. However, the interpreter simply called the deref object routine
5430 * instead of the function call. So, I must simulate the function call.
5431 * This needs to be formalized to hide this detail from applications
5432 * who wish to do the same. So...
5433 * FIXME: Priority=medium
5434 */
5435 if (0 == _pSL_increment_frame_pointer ())
5436 (void) _pSL_decrement_frame_pointer ();
5437 #endif
5438
5439 if (-1 == pop_1d_index_array (&ind_at))
5440 goto return_error;
5441
5442 if (-1 == SLang_pop_datatype (&type))
5443 goto return_error;
5444
5445 if (NULL == (at = SLang_create_array (type, 0, NULL,
5446 (SLindex_Type *) ind_at->data,
5447 ind_at->num_elements)))
5448 goto return_error;
5449
5450 free_array (ind_at);
5451 return SLang_push_array (at, 1);
5452
5453 return_error:
5454 free_array (ind_at);
5455 return -1;
5456 }
5457
array_length(SLtype type,VOID_STAR v,SLuindex_Type * len)5458 static int array_length (SLtype type, VOID_STAR v, SLuindex_Type *len)
5459 {
5460 SLang_Array_Type *at;
5461
5462 (void) type;
5463 at = *(SLang_Array_Type **) v;
5464 *len = at->num_elements;
5465 return 0;
5466 }
5467
array_inc_ref(SLtype type,VOID_STAR v,int dr)5468 static void array_inc_ref (SLtype type, VOID_STAR v, int dr)
5469 {
5470 SLang_Array_Type *at = *(SLang_Array_Type **) v;
5471 (void) type;
5472 if (at != NULL)
5473 at->num_refs += dr;
5474 }
5475
5476 int
_pSLarray_init_slarray(void)5477 _pSLarray_init_slarray (void)
5478 {
5479 SLang_Class_Type *cl;
5480
5481 if (-1 == SLadd_intrin_fun_table (Array_Table, NULL))
5482 return -1;
5483
5484 if (NULL == (cl = SLclass_allocate_class ("Array_Type")))
5485 return -1;
5486
5487 (void) SLclass_set_string_function (cl, array_string);
5488 (void) SLclass_set_destroy_function (cl, array_destroy);
5489 (void) SLclass_set_push_function (cl, array_push);
5490 (void) SLclass_set_length_function (cl, array_length);
5491 (void) SLclass_set_deref_function (cl, array_dereference);
5492 (void) SLclass_set_is_container (cl, 1);
5493
5494 cl->cl_push_intrinsic = array_push_intrinsic;
5495 cl->cl_datatype_deref = array_datatype_deref;
5496 cl->cl_inc_ref = array_inc_ref;
5497
5498 (void) SLclass_set_eqs_function (cl, array_eqs_method);
5499
5500 if (-1 == SLclass_register_class (cl, SLANG_ARRAY_TYPE, sizeof (VOID_STAR),
5501 SLANG_CLASS_TYPE_PTR))
5502 return -1;
5503
5504 if ((-1 == SLclass_add_binary_op (SLANG_ARRAY_TYPE, SLANG_ARRAY_TYPE, array_binary_op, array_binary_op_result))
5505 || (-1 == SLclass_add_unary_op (SLANG_ARRAY_TYPE, array_unary_op, array_unary_op_result))
5506 || (-1 == SLclass_add_app_unary_op (SLANG_ARRAY_TYPE, array_app_op, array_unary_op_result))
5507 || (-1 == SLclass_add_math_op (SLANG_ARRAY_TYPE, array_math_op, array_unary_op_result)))
5508 return -1;
5509
5510 return 0;
5511 }
5512
SLang_pop_array(SLang_Array_Type ** at_ptr,int convert_scalar)5513 int SLang_pop_array (SLang_Array_Type **at_ptr, int convert_scalar)
5514 {
5515 SLang_Array_Type *at;
5516
5517 if (-1 == pop_array (&at, convert_scalar))
5518 {
5519 *at_ptr = NULL;
5520 return -1;
5521 }
5522
5523 if (-1 == coerse_array_to_linear (at))
5524 {
5525 free_array (at);
5526 *at_ptr = NULL;
5527 return -1;
5528 }
5529 *at_ptr = at;
5530 return 0;
5531 }
5532
SLang_pop_array_of_type(SLang_Array_Type ** at,SLtype type)5533 int SLang_pop_array_of_type (SLang_Array_Type **at, SLtype type)
5534 {
5535 if (-1 == SLclass_typecast (type, 1, 1))
5536 return -1;
5537
5538 return SLang_pop_array (at, 1);
5539 }
5540
5541 void (*_pSLang_Matrix_Multiply)(void);
5542
_pSLarray_matrix_multiply(void)5543 int _pSLarray_matrix_multiply (void)
5544 {
5545 if (_pSLang_Matrix_Multiply != NULL)
5546 {
5547 (*_pSLang_Matrix_Multiply)();
5548 return 0;
5549 }
5550 _pSLang_verror (SL_NOT_IMPLEMENTED, "Matrix multiplication not available");
5551 return -1;
5552 }
5553
5554 struct _pSLang_Foreach_Context_Type
5555 {
5556 SLang_Array_Type *at;
5557 SLindex_Type next_element_index;
5558 };
5559
5560 SLang_Foreach_Context_Type *
_pSLarray_cl_foreach_open(SLtype type,unsigned int num)5561 _pSLarray_cl_foreach_open (SLtype type, unsigned int num)
5562 {
5563 SLang_Foreach_Context_Type *c;
5564
5565 if (num != 0)
5566 {
5567 SLdo_pop_n (num + 1);
5568 _pSLang_verror (SL_NOT_IMPLEMENTED,
5569 "%s does not support 'foreach using' form",
5570 SLclass_get_datatype_name (type));
5571 return NULL;
5572 }
5573
5574 if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type))))
5575 return NULL;
5576
5577 memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type));
5578
5579 if (-1 == pop_array (&c->at, 1))
5580 {
5581 SLfree ((char *) c);
5582 return NULL;
5583 }
5584
5585 return c;
5586 }
5587
_pSLarray_cl_foreach_close(SLtype type,SLang_Foreach_Context_Type * c)5588 void _pSLarray_cl_foreach_close (SLtype type, SLang_Foreach_Context_Type *c)
5589 {
5590 (void) type;
5591 if (c == NULL) return;
5592 free_array (c->at);
5593 SLfree ((char *) c);
5594 }
5595
_pSLarray_cl_foreach(SLtype type,SLang_Foreach_Context_Type * c)5596 int _pSLarray_cl_foreach (SLtype type, SLang_Foreach_Context_Type *c)
5597 {
5598 SLang_Array_Type *at;
5599 VOID_STAR data;
5600
5601 (void) type;
5602
5603 if (c == NULL)
5604 return -1;
5605
5606 at = c->at;
5607 /* Use <= here to prepare for the time when arrays are permitted to change size */
5608 if ((SLindex_Type)at->num_elements <= c->next_element_index)
5609 return 0;
5610
5611 /* FIXME: Priority = low. The following assumes linear arrays
5612 * or Integer range arrays. Fixing it right requires a method to get the
5613 * nth element of a multidimensional array.
5614 */
5615
5616 if (at->flags & SLARR_DATA_VALUE_IS_RANGE)
5617 {
5618 SLindex_Type d = (SLindex_Type) c->next_element_index;
5619 data = range_get_data_addr (at, &d);
5620 }
5621 else
5622 data = (VOID_STAR) ((char *)at->data + (c->next_element_index * at->sizeof_type));
5623
5624 c->next_element_index += 1;
5625
5626 if ((at->flags & SLARR_DATA_VALUE_IS_POINTER)
5627 && (*(VOID_STAR *) data == NULL))
5628 {
5629 if (-1 == SLang_push_null ())
5630 return -1;
5631 }
5632 else if (-1 == (*at->cl->cl_apush)(at->data_type, data))
5633 return -1;
5634
5635 /* keep going */
5636 return 1;
5637 }
5638
5639 /* References to array elements */
5640 typedef struct
5641 {
5642 SLang_Object_Type at;
5643 SLang_Object_Type index_objs [SLARRAY_MAX_DIMS];
5644 unsigned int num_indices;
5645 }
5646 Array_Elem_Ref_Type;
5647
elem_ref_push_index_objs(Array_Elem_Ref_Type * ert)5648 static int elem_ref_push_index_objs (Array_Elem_Ref_Type *ert)
5649 {
5650 SLang_Object_Type *o, *omax;
5651
5652 o = ert->index_objs;
5653 omax = o + ert->num_indices;
5654
5655 while (o < omax)
5656 {
5657 if (-1 == _pSLpush_slang_obj (o))
5658 return -1;
5659 o++;
5660 }
5661 if (-1 == _pSLpush_slang_obj (&ert->at))
5662 return -1;
5663
5664 return 0;
5665 }
5666
elem_ref_deref_assign(VOID_STAR vdata)5667 static int elem_ref_deref_assign (VOID_STAR vdata)
5668 {
5669 Array_Elem_Ref_Type *ert = (Array_Elem_Ref_Type *)vdata;
5670
5671 if (-1 == elem_ref_push_index_objs (ert))
5672 return -1;
5673
5674 return _pSLarray_aput1 (ert->num_indices);
5675 }
5676
elem_ref_deref(VOID_STAR vdata)5677 static int elem_ref_deref (VOID_STAR vdata)
5678 {
5679 Array_Elem_Ref_Type *ert = (Array_Elem_Ref_Type *)vdata;
5680
5681 if (-1 == elem_ref_push_index_objs (ert))
5682 return -1;
5683
5684 return _pSLarray_aget1 (ert->num_indices);
5685 }
5686
elem_ref_destroy(VOID_STAR vdata)5687 static void elem_ref_destroy (VOID_STAR vdata)
5688 {
5689 Array_Elem_Ref_Type *ert = (Array_Elem_Ref_Type *)vdata;
5690 SLang_Object_Type *o, *omax;
5691
5692 if (ert->at.o_data_type != 0)
5693 SLang_free_object (&ert->at);
5694 o = ert->index_objs;
5695 omax = o + ert->num_indices;
5696 while (o < omax)
5697 {
5698 if (o->o_data_type != 0)
5699 SLang_free_object (o);
5700 o++;
5701 }
5702 }
5703
5704 /* &A[i,...j] ==> __args i..j A ARRAY_REF */
_pSLarray_push_elem_ref(void)5705 int _pSLarray_push_elem_ref (void)
5706 {
5707 unsigned int num_indices = (unsigned int) (SLang_Num_Function_Args-1);
5708 Array_Elem_Ref_Type *ert;
5709 SLang_Ref_Type *ref;
5710 unsigned int i;
5711 int ret;
5712
5713 if (num_indices > SLARRAY_MAX_DIMS)
5714 {
5715 _pSLang_verror (SL_INVALID_PARM, "Number of dims must be less than %d", 1+SLARRAY_MAX_DIMS);
5716 return -1;
5717 }
5718
5719 if (NULL == (ref = _pSLang_new_ref (sizeof (Array_Elem_Ref_Type))))
5720 return -1;
5721
5722 ref->deref = elem_ref_deref;
5723 ref->deref_assign = elem_ref_deref_assign;
5724 ref->destroy = elem_ref_destroy;
5725
5726 ert = (Array_Elem_Ref_Type *) ref->data;
5727 ert->num_indices = num_indices;
5728 if (-1 == SLang_pop (&ert->at))
5729 {
5730 SLang_free_ref (ref);
5731 return -1;
5732 }
5733
5734 i = num_indices;
5735 while (i)
5736 {
5737 i--;
5738 if (-1 == SLang_pop (ert->index_objs + i))
5739 {
5740 SLang_free_ref (ref);
5741 return -1;
5742 }
5743 }
5744 ret = SLang_push_ref (ref);
5745 SLang_free_ref (ref);
5746 return ret;
5747 }
5748