00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023 #include "slinclud.h"
00024
00025 #include "slang.h"
00026 #include "_slang.h"
00027
00028 static int next_transposed_index (SLindex_Type *dims, SLindex_Type *max_dims, unsigned int num_dims)
00029 {
00030 int i;
00031
00032 for (i = 0; i < (int) num_dims; i++)
00033 {
00034 int dims_i;
00035
00036 dims_i = dims [i] + 1;
00037 if (dims_i != (int) max_dims [i])
00038 {
00039 dims [i] = dims_i;
00040 return 0;
00041 }
00042 dims [i] = 0;
00043 }
00044
00045 return -1;
00046 }
00047
00048 static SLang_Array_Type *allocate_transposed_array (SLang_Array_Type *at)
00049 {
00050 SLuindex_Type num_elements;
00051 SLang_Array_Type *bt;
00052 VOID_STAR b_data;
00053
00054 num_elements = at->num_elements;
00055 b_data = (VOID_STAR) SLmalloc (at->sizeof_type * num_elements);
00056 if (b_data == NULL)
00057 return NULL;
00058
00059 bt = SLang_create_array (at->data_type, 0, b_data, at->dims, 2);
00060 if (bt == NULL)
00061 {
00062 SLfree ((char *)b_data);
00063 return NULL;
00064 }
00065
00066 bt->dims[1] = at->dims[0];
00067 bt->dims[0] = at->dims[1];
00068
00069 return bt;
00070 }
00071
00072 static int check_for_empty_array (char *fun, unsigned int num)
00073 {
00074 if (num)
00075 return 0;
00076
00077 SLang_verror (SL_INVALID_PARM, "%s: array is empty", fun);
00078 return -1;
00079 }
00080
00081
00082 #if SLANG_HAS_FLOAT
00083 #define GENERIC_TYPE float
00084 #define TRANSPOSE_2D_ARRAY transpose_floats
00085 #define GENERIC_TYPE_A float
00086 #define GENERIC_TYPE_B float
00087 #define GENERIC_TYPE_C float
00088 #define INNERPROD_FUNCTION innerprod_float_float
00089 #if SLANG_HAS_COMPLEX
00090 # define INNERPROD_COMPLEX_A innerprod_complex_float
00091 # define INNERPROD_A_COMPLEX innerprod_float_complex
00092 #endif
00093 #define SUM_FUNCTION sum_floats
00094 #define SUM_RESULT_TYPE float
00095 #define CUMSUM_FUNCTION cumsum_floats
00096 #define CUMSUM_RESULT_TYPE float
00097 #define MIN_FUNCTION min_floats
00098 #define MAX_FUNCTION max_floats
00099 #define ANY_FUNCTION any_floats
00100 #define ALL_FUNCTION all_floats
00101 #define IS_NAN_FUNCTION _pSLmath_isnan
00102 #include "slarrfun.inc"
00103
00104
00105 #define GENERIC_TYPE double
00106 #define TRANSPOSE_2D_ARRAY transpose_doubles
00107 #define GENERIC_TYPE_A double
00108 #define GENERIC_TYPE_B double
00109 #define GENERIC_TYPE_C double
00110 #define INNERPROD_FUNCTION innerprod_double_double
00111 #if SLANG_HAS_COMPLEX
00112 # define INNERPROD_COMPLEX_A innerprod_complex_double
00113 # define INNERPROD_A_COMPLEX innerprod_double_complex
00114 #endif
00115 #define SUM_FUNCTION sum_doubles
00116 #define SUM_RESULT_TYPE double
00117 #define CUMSUM_FUNCTION cumsum_doubles
00118 #define CUMSUM_RESULT_TYPE double
00119 #define MIN_FUNCTION min_doubles
00120 #define MAX_FUNCTION max_doubles
00121 #define ANY_FUNCTION any_doubles
00122 #define ALL_FUNCTION all_doubles
00123 #define IS_NAN_FUNCTION _pSLmath_isnan
00124 #include "slarrfun.inc"
00125
00126 #define GENERIC_TYPE_A double
00127 #define GENERIC_TYPE_B float
00128 #define GENERIC_TYPE_C double
00129 #define INNERPROD_FUNCTION innerprod_double_float
00130 #include "slarrfun.inc"
00131
00132 #define GENERIC_TYPE_A float
00133 #define GENERIC_TYPE_B double
00134 #define GENERIC_TYPE_C double
00135 #define INNERPROD_FUNCTION innerprod_float_double
00136 #include "slarrfun.inc"
00137
00138
00139
00140
00141 #if SLANG_HAS_COMPLEX
00142 # define INNERPROD_COMPLEX_COMPLEX innerprod_complex_complex
00143 #endif
00144 #endif
00145
00146
00147 #define GENERIC_TYPE int
00148 #define TRANSPOSE_2D_ARRAY transpose_ints
00149 #define SUM_FUNCTION sum_ints
00150 #define SUM_RESULT_TYPE double
00151 #define CUMSUM_FUNCTION cumsum_ints
00152 #define CUMSUM_RESULT_TYPE double
00153 #define MIN_FUNCTION min_ints
00154 #define MAX_FUNCTION max_ints
00155 #define ANY_FUNCTION any_ints
00156 #define ALL_FUNCTION all_ints
00157 #include "slarrfun.inc"
00158
00159
00160 #define GENERIC_TYPE unsigned int
00161 #define SUM_FUNCTION sum_uints
00162 #define SUM_RESULT_TYPE double
00163 #define MIN_FUNCTION min_uints
00164 #define MAX_FUNCTION max_uints
00165 #define ANY_FUNCTION any_uints
00166 #define ALL_FUNCTION all_uints
00167 #include "slarrfun.inc"
00168
00169 #if SIZEOF_LONG != SIZEOF_INT
00170
00171 # define GENERIC_TYPE long
00172 # define TRANSPOSE_2D_ARRAY transpose_longs
00173 # define SUM_FUNCTION sum_longs
00174 # define SUM_RESULT_TYPE double
00175 # define MIN_FUNCTION min_longs
00176 # define MAX_FUNCTION max_longs
00177 #define ANY_FUNCTION any_longs
00178 #define ALL_FUNCTION all_longs
00179 # include "slarrfun.inc"
00180
00181 # define GENERIC_TYPE unsigned long
00182 # define SUM_FUNCTION sum_ulongs
00183 # define SUM_RESULT_TYPE double
00184 # define MIN_FUNCTION min_ulongs
00185 # define MAX_FUNCTION max_ulongs
00186 #define ANY_FUNCTION any_ulongs
00187 #define ALL_FUNCTION all_ulongs
00188 # include "slarrfun.inc"
00189 #else
00190 # define transpose_longs transpose_ints
00191 # define sum_longs sum_ints
00192 # define sum_ulongs sum_uints
00193 # define min_longs min_ints
00194 # define min_ulongs min_uints
00195 # define max_longs max_ints
00196 # define max_ulongs max_uints
00197 # define any_longs any_ints
00198 # define any_ulongs any_uints
00199 # define all_longs all_ints
00200 # define all_ulongs all_uints
00201 #endif
00202
00203 #if SIZEOF_SHORT != SIZEOF_INT
00204
00205 # define GENERIC_TYPE short
00206 # define TRANSPOSE_2D_ARRAY transpose_shorts
00207 # define SUM_FUNCTION sum_shorts
00208 # define SUM_RESULT_TYPE double
00209 # define MIN_FUNCTION min_shorts
00210 # define MAX_FUNCTION max_shorts
00211 # define ANY_FUNCTION any_shorts
00212 # define ALL_FUNCTION all_shorts
00213 # include "slarrfun.inc"
00214
00215 # define GENERIC_TYPE unsigned short
00216 # define SUM_FUNCTION sum_ushorts
00217 # define SUM_RESULT_TYPE double
00218 # define MIN_FUNCTION min_ushorts
00219 # define MAX_FUNCTION max_ushorts
00220 # define ANY_FUNCTION any_ushorts
00221 # define ALL_FUNCTION all_ushorts
00222 # include "slarrfun.inc"
00223 #else
00224 # define transpose_shorts transpose_ints
00225 # define sum_shorts sum_ints
00226 # define sum_ushorts sum_uints
00227 # define min_shorts min_ints
00228 # define min_ushorts min_uints
00229 # define max_shorts max_ints
00230 # define max_ushorts max_uints
00231 # define any_shorts any_ints
00232 # define any_ushorts any_uints
00233 # define all_shorts all_ints
00234 # define all_ushorts all_uints
00235 #endif
00236
00237
00238 #define GENERIC_TYPE char
00239 #define TRANSPOSE_2D_ARRAY transpose_chars
00240 #define SUM_FUNCTION sum_chars
00241 #define SUM_RESULT_TYPE double
00242 #define MIN_FUNCTION min_chars
00243 #define MAX_FUNCTION max_chars
00244 #define ANY_FUNCTION any_chars
00245 #define ALL_FUNCTION all_chars
00246 #include "slarrfun.inc"
00247
00248 #define GENERIC_TYPE unsigned char
00249 #define SUM_FUNCTION sum_uchars
00250 #define SUM_RESULT_TYPE double
00251 #define MIN_FUNCTION min_uchars
00252 #define MAX_FUNCTION max_uchars
00253 #define ANY_FUNCTION any_uchars
00254 #define ALL_FUNCTION all_uchars
00255 #include "slarrfun.inc"
00256
00257
00258 static SLang_Array_Type *transpose (SLang_Array_Type *at)
00259 {
00260 SLindex_Type dims [SLARRAY_MAX_DIMS];
00261 SLindex_Type *max_dims;
00262 unsigned int num_dims;
00263 SLang_Array_Type *bt;
00264 int i;
00265 size_t sizeof_type;
00266 int is_ptr;
00267 char *b_data;
00268
00269 max_dims = at->dims;
00270 num_dims = at->num_dims;
00271
00272 if ((at->num_elements == 0)
00273 || (num_dims == 1))
00274 {
00275 bt = SLang_duplicate_array (at);
00276 if (num_dims == 1) bt->num_dims = 2;
00277 goto transpose_dims;
00278 }
00279
00280
00281 if (num_dims == 2)
00282 {
00283 bt = allocate_transposed_array (at);
00284 if (bt == NULL) return NULL;
00285
00286 switch (at->data_type)
00287 {
00288 case SLANG_INT_TYPE:
00289 case SLANG_UINT_TYPE:
00290 return transpose_ints (at, bt);
00291 #if SLANG_HAS_FLOAT
00292 case SLANG_DOUBLE_TYPE:
00293 return transpose_doubles (at, bt);
00294 case SLANG_FLOAT_TYPE:
00295 return transpose_floats (at, bt);
00296 #endif
00297 case SLANG_CHAR_TYPE:
00298 case SLANG_UCHAR_TYPE:
00299 return transpose_chars (at, bt);
00300 case SLANG_LONG_TYPE:
00301 case SLANG_ULONG_TYPE:
00302 return transpose_longs (at, bt);
00303 case SLANG_SHORT_TYPE:
00304 case SLANG_USHORT_TYPE:
00305 return transpose_shorts (at, bt);
00306 }
00307 }
00308 else
00309 {
00310 bt = SLang_create_array (at->data_type, 0, NULL, max_dims, num_dims);
00311 if (bt == NULL) return NULL;
00312 }
00313
00314 sizeof_type = at->sizeof_type;
00315 is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
00316
00317 memset ((char *)dims, 0, sizeof(dims));
00318
00319 b_data = (char *) bt->data;
00320
00321 do
00322 {
00323 if (-1 == _pSLarray_aget_transfer_elem (at, dims, (VOID_STAR) b_data,
00324 sizeof_type, is_ptr))
00325 {
00326 SLang_free_array (bt);
00327 return NULL;
00328 }
00329 b_data += sizeof_type;
00330 }
00331 while (0 == next_transposed_index (dims, max_dims, num_dims));
00332
00333 transpose_dims:
00334
00335 num_dims = bt->num_dims;
00336 for (i = 0; i < (int) num_dims; i++)
00337 bt->dims[i] = max_dims [num_dims - i - 1];
00338
00339 return bt;
00340 }
00341
00342 static void array_transpose (SLang_Array_Type *at)
00343 {
00344 if (NULL != (at = transpose (at)))
00345 (void) SLang_push_array (at, 1);
00346 }
00347
00348 #if SLANG_HAS_FLOAT
00349 static int get_inner_product_parms (SLang_Array_Type *a, int *dp,
00350 unsigned int *loops, unsigned int *other)
00351 {
00352 int num_dims;
00353 int d;
00354
00355 d = *dp;
00356
00357 num_dims = (int)a->num_dims;
00358 if (num_dims == 0)
00359 {
00360 SLang_verror (SL_INVALID_PARM, "Inner-product operation requires an array of at least 1 dimension.");
00361 return -1;
00362 }
00363
00364
00365 if (d == -1)
00366 d += num_dims;
00367 *dp = d;
00368
00369 if (a->num_elements == 0)
00370 {
00371 *loops = *other = 0;
00372 return 0;
00373 }
00374
00375 *loops = a->num_elements / a->dims[d];
00376
00377 if (d == 0)
00378 {
00379 *other = *loops;
00380 return 0;
00381 }
00382
00383 *other = a->dims[d];
00384 return 0;
00385 }
00386
00387
00388
00389
00390
00391
00392
00393 static void do_inner_product (void)
00394 {
00395 SLang_Array_Type *a, *b, *c;
00396 void (*fun)(SLang_Array_Type *, SLang_Array_Type *, SLang_Array_Type *,
00397 unsigned int, unsigned int, unsigned int, unsigned int,
00398 unsigned int);
00399 SLtype c_type;
00400 SLindex_Type dims[SLARRAY_MAX_DIMS];
00401 int status;
00402 unsigned int a_loops, b_loops, b_inc, a_stride;
00403 int ai_dims, i, j;
00404 unsigned int num_dims, a_num_dims, b_num_dims;
00405 int ai, bi;
00406
00407
00408
00409
00410
00411
00412
00413 switch (SLang_peek_at_stack1 ())
00414 {
00415 case SLANG_DOUBLE_TYPE:
00416 if (-1 == SLang_pop_array_of_type (&b, SLANG_DOUBLE_TYPE))
00417 return;
00418 break;
00419
00420 #if SLANG_HAS_COMPLEX
00421 case SLANG_COMPLEX_TYPE:
00422 if (-1 == SLang_pop_array_of_type (&b, SLANG_COMPLEX_TYPE))
00423 return;
00424 break;
00425 #endif
00426 case SLANG_FLOAT_TYPE:
00427 default:
00428 if (-1 == SLang_pop_array_of_type (&b, SLANG_FLOAT_TYPE))
00429 return;
00430 break;
00431 }
00432
00433 switch (SLang_peek_at_stack1 ())
00434 {
00435 case SLANG_DOUBLE_TYPE:
00436 status = SLang_pop_array_of_type (&a, SLANG_DOUBLE_TYPE);
00437 break;
00438
00439 #if SLANG_HAS_COMPLEX
00440 case SLANG_COMPLEX_TYPE:
00441 status = SLang_pop_array_of_type (&a, SLANG_COMPLEX_TYPE);
00442 break;
00443 #endif
00444 case SLANG_FLOAT_TYPE:
00445 default:
00446 status = SLang_pop_array_of_type (&a, SLANG_FLOAT_TYPE);
00447 break;
00448 }
00449
00450 if (status == -1)
00451 {
00452 SLang_free_array (b);
00453 return;
00454 }
00455
00456 ai = -1;
00457 bi = 0;
00458 if ((-1 == get_inner_product_parms (a, &ai, &a_loops, &a_stride))
00459 || (-1 == get_inner_product_parms (b, &bi, &b_loops, &b_inc)))
00460 {
00461 SLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product");
00462 goto free_and_return;
00463 }
00464
00465 a_num_dims = a->num_dims;
00466 b_num_dims = b->num_dims;
00467
00468
00469 if ((a_num_dims == 1)
00470 && (b_num_dims == 2)
00471 && (a->num_elements))
00472 {
00473 a_num_dims = 2;
00474 ai = 1;
00475 a_loops = a->num_elements;
00476 a_stride = 1;
00477 }
00478
00479 if ((ai_dims = a->dims[ai]) != b->dims[bi])
00480 {
00481 SLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product");
00482 goto free_and_return;
00483 }
00484
00485 num_dims = a_num_dims + b_num_dims - 2;
00486 if (num_dims > SLARRAY_MAX_DIMS)
00487 {
00488 SLang_verror (SL_NOT_IMPLEMENTED,
00489 "Inner-product result exceeds maximum allowed dimensions");
00490 goto free_and_return;
00491 }
00492
00493 if (num_dims)
00494 {
00495 j = 0;
00496 for (i = 0; i < (int)a_num_dims; i++)
00497 if (i != ai) dims [j++] = a->dims[i];
00498 for (i = 0; i < (int)b_num_dims; i++)
00499 if (i != bi) dims [j++] = b->dims[i];
00500 }
00501 else
00502 {
00503
00504 num_dims = 1;
00505 dims[0] = 1;
00506 }
00507
00508 c_type = 0; fun = NULL;
00509 switch (a->data_type)
00510 {
00511 case SLANG_FLOAT_TYPE:
00512 switch (b->data_type)
00513 {
00514 case SLANG_FLOAT_TYPE:
00515 c_type = SLANG_FLOAT_TYPE;
00516 fun = innerprod_float_float;
00517 break;
00518 case SLANG_DOUBLE_TYPE:
00519 c_type = SLANG_DOUBLE_TYPE;
00520 fun = innerprod_float_double;
00521 break;
00522 #if SLANG_HAS_COMPLEX
00523 case SLANG_COMPLEX_TYPE:
00524 c_type = SLANG_COMPLEX_TYPE;
00525 fun = innerprod_float_complex;
00526 break;
00527 #endif
00528 }
00529 break;
00530 case SLANG_DOUBLE_TYPE:
00531 switch (b->data_type)
00532 {
00533 case SLANG_FLOAT_TYPE:
00534 c_type = SLANG_DOUBLE_TYPE;
00535 fun = innerprod_double_float;
00536 break;
00537 case SLANG_DOUBLE_TYPE:
00538 c_type = SLANG_DOUBLE_TYPE;
00539 fun = innerprod_double_double;
00540 break;
00541 #if SLANG_HAS_COMPLEX
00542 case SLANG_COMPLEX_TYPE:
00543 c_type = SLANG_COMPLEX_TYPE;
00544 fun = innerprod_double_complex;
00545 break;
00546 #endif
00547 }
00548 break;
00549 #if SLANG_HAS_COMPLEX
00550 case SLANG_COMPLEX_TYPE:
00551 c_type = SLANG_COMPLEX_TYPE;
00552 switch (b->data_type)
00553 {
00554 case SLANG_FLOAT_TYPE:
00555 fun = innerprod_complex_float;
00556 break;
00557 case SLANG_DOUBLE_TYPE:
00558 fun = innerprod_complex_double;
00559 break;
00560 case SLANG_COMPLEX_TYPE:
00561 fun = innerprod_complex_complex;
00562 break;
00563 }
00564 break;
00565 #endif
00566 default:
00567 break;
00568 }
00569
00570 if (NULL == (c = SLang_create_array (c_type, 0, NULL, dims, num_dims)))
00571 goto free_and_return;
00572
00573 (*fun)(a, b, c, a_loops, a_stride, b_loops, b_inc, ai_dims);
00574
00575 (void) SLang_push_array (c, 1);
00576
00577
00578 free_and_return:
00579 SLang_free_array (a);
00580 SLang_free_array (b);
00581 }
00582 #endif
00583
00584 static int map_or_contract_array (SLCONST SLarray_Map_Type *c, int use_contraction,
00585 int dim_specified, int *use_this_dim,
00586 VOID_STAR clientdata)
00587 {
00588 int k, use_all_dims;
00589 SLang_Array_Type *at, *new_at;
00590 SLindex_Type *old_dims;
00591 SLindex_Type old_dims_buf[SLARRAY_MAX_DIMS];
00592 SLindex_Type sub_dims[SLARRAY_MAX_DIMS];
00593 SLindex_Type tmp_dims[SLARRAY_MAX_DIMS];
00594 unsigned int i, j, old_num_dims, sub_num_dims;
00595 SLtype new_data_type, old_data_type;
00596 char *old_data, *new_data;
00597 SLindex_Type w[SLARRAY_MAX_DIMS], wk;
00598 size_t old_sizeof_type, new_sizeof_type;
00599 SLuindex_Type dims_k;
00600 int from_type;
00601 SLCONST SLarray_Map_Type *csave;
00602 SLarray_Map_Fun_Type *fmap;
00603 SLarray_Contract_Fun_Type *fcon;
00604
00605 use_all_dims = 1;
00606 k = 0;
00607 if (dim_specified)
00608 {
00609 if (use_this_dim != NULL)
00610 {
00611 k = *use_this_dim;
00612 use_all_dims = 0;
00613 }
00614 }
00615 else if (SLang_Num_Function_Args == 2)
00616 {
00617 if (-1 == SLang_pop_integer (&k))
00618 return -1;
00619
00620 use_all_dims = 0;
00621 }
00622
00623 if (-1 == (from_type = SLang_peek_at_stack1 ()))
00624 return -1;
00625
00626 csave = c;
00627 while (c->f != NULL)
00628 {
00629 if (c->from_type == (SLtype) from_type)
00630 break;
00631 c++;
00632 }
00633
00634
00635 if (c->f != NULL)
00636 {
00637 if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
00638 return -1;
00639 }
00640 else
00641 {
00642
00643 c = csave;
00644 while (c->f != NULL)
00645 {
00646 if (c->from_type == SLANG_VOID_TYPE)
00647 break;
00648 c++;
00649 }
00650 if (c->f == NULL)
00651 {
00652 SLang_verror (SL_TYPE_MISMATCH, "%s is not supported by this function", SLclass_get_datatype_name (from_type));
00653 return -1;
00654 }
00655
00656
00657 if (c->typecast_to_type == SLANG_VOID_TYPE)
00658 {
00659 if (-1 == SLang_pop_array (&at, 1))
00660 return -1;
00661 }
00662 else if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
00663 return -1;
00664 }
00665
00666 old_data_type = at->data_type;
00667 if (SLANG_VOID_TYPE == (new_data_type = c->result_type))
00668 new_data_type = old_data_type;
00669
00670 old_num_dims = at->num_dims;
00671
00672 if (use_all_dims == 0)
00673 {
00674 if (k < 0)
00675 k += old_num_dims;
00676
00677 if ((k < 0) || (k >= (int)old_num_dims))
00678 {
00679 SLang_verror (SL_INVALID_PARM, "Dimension %d is invalid for a %d-d array",
00680 k, old_num_dims);
00681 SLang_free_array (at);
00682 return -1;
00683 }
00684 old_dims = at->dims;
00685 }
00686 else
00687 {
00688 old_dims = old_dims_buf;
00689 old_dims[0] = (SLindex_Type)at->num_elements;
00690 old_num_dims = 1;
00691 }
00692
00693 fcon = (SLarray_Contract_Fun_Type *) c->f;
00694 fmap = c->f;
00695
00696 if (use_contraction
00697 && (use_all_dims || (old_num_dims == 1)))
00698 {
00699 SLang_Class_Type *cl;
00700 VOID_STAR buf;
00701 int status = 0;
00702
00703 cl = _pSLclass_get_class (new_data_type);
00704 buf = cl->cl_transfer_buf;
00705
00706 if ((-1 == (*fcon) (at->data, 1, at->num_elements, buf))
00707 || (-1 == SLang_push_value (new_data_type, buf)))
00708 status = -1;
00709
00710 SLang_free_array (at);
00711 return status;
00712 }
00713
00714
00715
00716
00717
00718
00719
00720
00721
00722
00723
00724
00725
00726
00727
00728
00729 wk = 1;
00730 i = old_num_dims;
00731 while (i != 0)
00732 {
00733 i--;
00734 w[i] = wk;
00735 wk *= old_dims[i];
00736 }
00737 wk = w[k];
00738
00739
00740 j = 0;
00741 for (i = 0; i < old_num_dims; i++)
00742 {
00743 if (i == (unsigned int) k)
00744 continue;
00745
00746 sub_dims[j] = old_dims[i];
00747 w[j] = w[i];
00748 tmp_dims[j] = 0;
00749 j++;
00750 }
00751 sub_num_dims = old_num_dims - 1;
00752
00753 if (use_contraction)
00754 new_at = SLang_create_array1 (new_data_type, 0, NULL, sub_dims, sub_num_dims, 1);
00755 else
00756 new_at = SLang_create_array1 (new_data_type, 0, NULL, old_dims, old_num_dims, 1);
00757
00758 if (new_at == NULL)
00759 {
00760 SLang_free_array (at);
00761 return -1;
00762 }
00763
00764 new_data = (char *)new_at->data;
00765 old_data = (char *)at->data;
00766 old_sizeof_type = at->sizeof_type;
00767 new_sizeof_type = new_at->sizeof_type;
00768 dims_k = old_dims[k] * wk;
00769
00770
00771
00772
00773 if (new_at->num_elements) do
00774 {
00775 size_t offset = 0;
00776 int status;
00777
00778 for (i = 0; i < sub_num_dims; i++)
00779 offset += w[i] * tmp_dims[i];
00780
00781 if (use_contraction)
00782 {
00783 status = (*fcon) ((VOID_STAR)(old_data + offset*old_sizeof_type), wk,
00784 dims_k, (VOID_STAR) new_data);
00785 new_data += new_sizeof_type;
00786 }
00787 else
00788 {
00789 status = (*fmap) (old_data_type, (VOID_STAR) (old_data + offset*old_sizeof_type),
00790 wk, dims_k,
00791 new_data_type, (VOID_STAR) (new_data + offset*new_sizeof_type),
00792 clientdata);
00793 }
00794
00795 if (status == -1)
00796 {
00797 SLang_free_array (new_at);
00798 SLang_free_array (at);
00799 return -1;
00800 }
00801 }
00802 while (-1 != _pSLarray_next_index (tmp_dims, sub_dims, sub_num_dims));
00803
00804 SLang_free_array (at);
00805 return SLang_push_array (new_at, 1);
00806 }
00807
00808
00809 int SLarray_map_array (SLCONST SLarray_Map_Type *m)
00810 {
00811 return map_or_contract_array (m, 0, 0, NULL, NULL);
00812 }
00813
00814 int SLarray_map_array_1 (SLCONST SLarray_Map_Type *m, int *use_this_dim,
00815 VOID_STAR clientdata)
00816 {
00817 return map_or_contract_array (m, 0, 1, use_this_dim, clientdata);
00818 }
00819
00820 int SLarray_contract_array (SLCONST SLarray_Contract_Type *c)
00821 {
00822 return map_or_contract_array ((SLarray_Map_Type *)c, 1, 0, NULL, NULL);
00823 }
00824
00825 #if SLANG_HAS_COMPLEX
00826 static int sum_complex (VOID_STAR zp, unsigned int inc, unsigned int num, VOID_STAR sp)
00827 {
00828 double *z, *zmax;
00829 double sr, si;
00830 double *s;
00831
00832 z = (double *)zp;
00833 zmax = z + 2*num;
00834 inc *= 2;
00835 sr = si = 0.0;
00836 while (z < zmax)
00837 {
00838 sr += z[0];
00839 si += z[1];
00840 z += inc;
00841 }
00842 s = (double *)sp;
00843 s[0] = sr;
00844 s[1] = si;
00845 return 0;
00846 }
00847
00848 static int cumsum_complex (SLtype xtype, VOID_STAR xp, unsigned int inc,
00849 unsigned int num,
00850 SLtype ytype, VOID_STAR yp, VOID_STAR clientdata)
00851 {
00852 double *z, *zmax;
00853 double cr, ci;
00854 double *s;
00855
00856 (void) xtype; (void) ytype; (void) clientdata;
00857 z = (double *)xp;
00858 zmax = z + 2*num;
00859 s = (double *)yp;
00860 inc *= 2;
00861 cr = ci = 0.0;
00862 while (z < zmax)
00863 {
00864 cr += z[0];
00865 ci += z[1];
00866 s[0] = cr;
00867 s[1] = ci;
00868 z += inc;
00869 s += inc;
00870 }
00871 return 0;
00872 }
00873 #endif
00874 #if SLANG_HAS_FLOAT
00875 static SLCONST SLarray_Contract_Type Sum_Functions [] =
00876 {
00877 {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_doubles},
00878 {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Contract_Fun_Type *) sum_floats},
00879 {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_ints},
00880 {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_chars},
00881 {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_uchars},
00882 {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_shorts},
00883 {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_ushorts},
00884 {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_uints},
00885 {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_longs},
00886 {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_ulongs},
00887 #if SLANG_HAS_COMPLEX
00888 {SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, (SLarray_Contract_Fun_Type *) sum_complex},
00889 #endif
00890 {0, 0, 0, NULL}
00891 };
00892
00893 static void array_sum (void)
00894 {
00895 (void) SLarray_contract_array (Sum_Functions);
00896 }
00897 #endif
00898
00899 static SLCONST SLarray_Contract_Type Array_Min_Funs [] =
00900 {
00901 {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) min_chars},
00902 {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, (SLarray_Contract_Fun_Type *) min_uchars},
00903 {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, (SLarray_Contract_Fun_Type *) min_shorts},
00904 {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, (SLarray_Contract_Fun_Type *) min_ushorts},
00905 {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_INT_TYPE, (SLarray_Contract_Fun_Type *) min_ints},
00906 {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_UINT_TYPE, (SLarray_Contract_Fun_Type *) min_uints},
00907 {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_LONG_TYPE, (SLarray_Contract_Fun_Type *) min_longs},
00908 {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, (SLarray_Contract_Fun_Type *) min_ulongs},
00909 #if SLANG_HAS_FLOAT
00910 {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Contract_Fun_Type *) min_floats},
00911 {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) min_doubles},
00912 #endif
00913 {0, 0, 0, NULL}
00914 };
00915
00916 static void
00917 array_min (void)
00918 {
00919 (void) SLarray_contract_array (Array_Min_Funs);
00920 }
00921
00922 static SLCONST SLarray_Contract_Type Array_Max_Funs [] =
00923 {
00924 {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) max_chars},
00925 {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, (SLarray_Contract_Fun_Type *) max_uchars},
00926 {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, (SLarray_Contract_Fun_Type *) max_shorts},
00927 {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, (SLarray_Contract_Fun_Type *) max_ushorts},
00928 {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_INT_TYPE, (SLarray_Contract_Fun_Type *) max_ints},
00929 {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_UINT_TYPE, (SLarray_Contract_Fun_Type *) max_uints},
00930 {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_LONG_TYPE, (SLarray_Contract_Fun_Type *) max_longs},
00931 {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, (SLarray_Contract_Fun_Type *) max_ulongs},
00932 #if SLANG_HAS_FLOAT
00933 {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Contract_Fun_Type *) max_floats},
00934 {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) max_doubles},
00935 #endif
00936 {0, 0, 0, NULL}
00937 };
00938
00939 static void
00940 array_max (void)
00941 {
00942 (void) SLarray_contract_array (Array_Max_Funs);
00943 }
00944
00945
00946 static SLCONST SLarray_Map_Type CumSum_Functions [] =
00947 {
00948 {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
00949 {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_ints},
00950 {SLANG_LONG_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
00951 {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
00952 {SLANG_UINT_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
00953 {SLANG_ULONG_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
00954 {SLANG_CHAR_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
00955 {SLANG_UCHAR_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
00956 {SLANG_SHORT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
00957 {SLANG_USHORT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
00958 {SLANG_VOID_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
00959 #if SLANG_HAS_COMPLEX
00960 {SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, (SLarray_Map_Fun_Type *) cumsum_complex},
00961 #endif
00962 {0, 0, 0, NULL}
00963 };
00964
00965 static void array_cumsum (void)
00966 {
00967 (void) SLarray_map_array (CumSum_Functions);
00968 }
00969
00970 static int pop_writable_array (SLang_Array_Type **atp)
00971 {
00972 SLang_Array_Type *at;
00973
00974 if (-1 == SLang_pop_array (&at, 0))
00975 return -1;
00976
00977 if (at->flags & SLARR_DATA_VALUE_IS_READ_ONLY)
00978 {
00979 SLang_set_error (SL_ReadOnly_Error);
00980 SLang_free_array (at);
00981 return -1;
00982 }
00983
00984 *atp = at;
00985 return 0;
00986 }
00987
00988 static int check_range_index (int len, int *ip)
00989 {
00990 int i = *ip;
00991 if (i < 0)
00992 i += len;
00993
00994 if ((i < 0) || (i >= len))
00995 {
00996 SLang_set_error (SL_Index_Error);
00997 return -1;
00998 }
00999 *ip = i;
01000 return 0;
01001 }
01002
01003 static int check_range_indices (int len, int *ip, int *jp)
01004 {
01005 int i = *ip, j = *jp;
01006
01007 if ((-1 == check_range_index (len, &i))
01008 || (-1 == check_range_index (len, &j)))
01009 return -1;
01010
01011 if (i > j)
01012 {
01013 int t = i; i = j; j = t;
01014 }
01015 *ip = i;
01016 *jp = j;
01017 return 0;
01018 }
01019
01020
01021
01022 static void array_swap (void)
01023 {
01024 int i, j;
01025 int len;
01026 unsigned char *src, *dst;
01027 size_t sizeof_type;
01028 unsigned int k;
01029 int dim, have_dim;
01030 SLang_Array_Type *at;
01031 #if 0
01032 SLindex_Type dims[SLARRAY_MAX_DIMS];
01033 #endif
01034 have_dim = 0;
01035 if (SLang_Num_Function_Args == 4)
01036 {
01037 if (-1 == SLang_pop_integer (&dim))
01038 return;
01039 have_dim = 1;
01040 }
01041
01042 if ((-1 == SLang_pop_integer (&j))
01043 || (-1 == SLang_pop_integer (&i)))
01044 return;
01045
01046 if (i == j)
01047 return;
01048
01049 if (-1 == pop_writable_array (&at))
01050 return;
01051
01052 if (have_dim)
01053 {
01054 if (-1 == check_range_index (at->num_dims, &dim))
01055 {
01056 SLang_free_array (at);
01057 return;
01058 }
01059 len = at->dims [dim];
01060 }
01061 else len = (int) at->num_elements;
01062
01063 if (-1 == check_range_indices (len, &i, &j))
01064 {
01065 SLang_free_array (at);
01066 return;
01067 }
01068
01069 sizeof_type = at->cl->cl_sizeof_type;
01070 if (have_dim == 0)
01071 {
01072 src = (unsigned char *)at->data + j*sizeof_type;
01073 dst = (unsigned char *)at->data + i*sizeof_type;
01074
01075 for (k = 0; k < sizeof_type; k++)
01076 {
01077 unsigned char tmp = src[k];
01078 src[k] = dst[k];
01079 dst[k] = tmp;
01080 }
01081 SLang_free_array (at);
01082 return;
01083 }
01084
01085 SLang_verror (SL_NOT_IMPLEMENTED, "dim not implemented");
01086 #if 0
01087
01088
01089
01090
01091
01092
01093
01094
01095
01096
01097
01098
01099
01100
01101
01102
01103
01104
01105
01106
01107
01108
01109
01110
01111
01112 memset ((char *) dims, 0, sizeof (dims));
01113 max_dims = at->dims;
01114 dims[dim] = i;
01115 src_ptr = (unsigned char *)at->data;
01116 ofs = 1;
01117 for (d = swap_dim + 1; d < max_dims; d++)
01118 {
01119 ofs = ofs * max_dims[d];
01120 }
01121 src_ptr = (unsigned char *)at->data + i * ofs;
01122 dst_ptr = (unsigned char *)at->data + j * ofs;
01123
01124 for (d = swap_dim; d < max_dims; d++)
01125 {
01126 stride =
01127 while (1)
01128 {
01129 int d;
01130 unsigned char *src_ptr;
01131 for (d = num_dims-1; d >= 0; d--)
01132 {
01133 SLindex_Type dims_d;
01134 if (d == swap_dim)
01135 {
01136 src_ptr += sizeof_slice;
01137 continue;
01138 }
01139 XXXXXXXXXXXX all wrong.
01140 dims_d = dims[d] + 1;
01141 if (dims_d != (int) max_dims[d])
01142 break;
01143 dims[d] = 0;
01144 src_ptr += sizeof_type;
01145 }
01146 if (d == -1)
01147 break;
01148 stride = 1;
01149 k = 0;
01150 while (k < dim)
01151 stride *= at->dims[k];
01152
01153 k = dim + 1;
01154
01155 src = (unsigned char *)at->data + j*sizeof_type;
01156 dst = (unsigned char *)at->data + i*sizeof_type;
01157 }
01158 }
01159 #endif
01160 }
01161
01162
01163 static void array_reverse (void)
01164 {
01165 int len;
01166 unsigned char *src, *dst;
01167 size_t sizeof_type;
01168 int dim = 0;
01169
01170 int from = 0;
01171 int to = -1;
01172 int nargs;
01173
01174 SLang_Array_Type *at;
01175
01176 nargs = SLang_Num_Function_Args;
01177 if ((nargs == 2) || (nargs == 4))
01178 {
01179
01180
01181 if (-1 == SLang_pop_integer (&dim))
01182 return;
01183 SLang_verror (SL_NotImplemented_Error, "dim argument not yet implemented");
01184 return;
01185 }
01186
01187 if (nargs >= 3)
01188 {
01189 if ((-1 == SLang_pop_integer (&to))
01190 || (-1 == SLang_pop_integer (&from)))
01191 return;
01192 }
01193 if (from == to)
01194 return;
01195
01196
01197 if (-1 == pop_writable_array (&at))
01198 return;
01199
01200 len = (int) at->num_elements;
01201 if (-1 == check_range_indices (len, &from, &to))
01202 {
01203 SLang_free_array (at);
01204 return;
01205 }
01206
01207 sizeof_type = at->cl->cl_sizeof_type;
01208
01209 src = (unsigned char *)at->data + from*sizeof_type;
01210 dst = (unsigned char *)at->data + to*sizeof_type;
01211 while (src < dst)
01212 {
01213 unsigned int k;
01214
01215 for (k = 0; k < sizeof_type; k++)
01216 {
01217 unsigned char tmp = src[k];
01218 src[k] = dst[k];
01219 dst[k] = tmp;
01220 }
01221
01222 src += sizeof_type;
01223 dst -= sizeof_type;
01224 }
01225 SLang_free_array (at);
01226 }
01227
01228 static SLCONST SLarray_Contract_Type Array_Any_Funs [] =
01229 {
01230 {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_chars},
01231 {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_uchars},
01232 {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_shorts},
01233 {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_ushorts},
01234 {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_ints},
01235 {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_uints},
01236 {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_longs},
01237 {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_ulongs},
01238 #if SLANG_HAS_FLOAT
01239 {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_floats},
01240 {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) any_doubles},
01241 #endif
01242 {0, 0, 0, NULL}
01243 };
01244
01245 static void
01246 array_any (void)
01247 {
01248 (void) SLarray_contract_array (Array_Any_Funs);
01249 }
01250
01251
01252 static SLCONST SLarray_Contract_Type Array_All_Funs [] =
01253 {
01254 {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) all_chars},
01255 {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) all_uchars},
01256