diff options
Diffstat (limited to 'mdk-stage1/slang/slarrfun.c')
| -rw-r--r-- | mdk-stage1/slang/slarrfun.c | 464 |
1 files changed, 0 insertions, 464 deletions
diff --git a/mdk-stage1/slang/slarrfun.c b/mdk-stage1/slang/slarrfun.c deleted file mode 100644 index bfa6ec5e5..000000000 --- a/mdk-stage1/slang/slarrfun.c +++ /dev/null @@ -1,464 +0,0 @@ -/* Advanced array manipulation routines for S-Lang */ -/* Copyright (c) 1998, 1999, 2001 John E. Davis - * This file is part of the S-Lang library. - * - * You may distribute under the terms of either the GNU General Public - * License or the Perl Artistic License. - */ - -#include "slinclud.h" - -#include "slang.h" -#include "_slang.h" - -static int next_transposed_index (int *dims, int *max_dims, unsigned int num_dims) -{ - int i; - - for (i = 0; i < (int) num_dims; i++) - { - int dims_i; - - dims_i = dims [i] + 1; - if (dims_i != (int) max_dims [i]) - { - dims [i] = dims_i; - return 0; - } - dims [i] = 0; - } - - return -1; -} - -static SLang_Array_Type *allocate_transposed_array (SLang_Array_Type *at) -{ - unsigned int num_elements; - SLang_Array_Type *bt; - VOID_STAR b_data; - - num_elements = at->num_elements; - b_data = (VOID_STAR) SLmalloc (at->sizeof_type * num_elements); - if (b_data == NULL) - return NULL; - - bt = SLang_create_array (at->data_type, 0, b_data, at->dims, 2); - if (bt == NULL) - { - SLfree ((char *)b_data); - return NULL; - } - - bt->dims[1] = at->dims[0]; - bt->dims[0] = at->dims[1]; - - return bt; -} - -#define GENERIC_TYPE float -#define TRANSPOSE_2D_ARRAY transpose_floats -#define GENERIC_TYPE_A float -#define GENERIC_TYPE_B float -#define GENERIC_TYPE_C float -#define INNERPROD_FUNCTION innerprod_float_float -#if SLANG_HAS_COMPLEX -# define INNERPROD_COMPLEX_A innerprod_complex_float -# define INNERPROD_A_COMPLEX innerprod_float_complex -#endif -#include "slarrfun.inc" - -#define GENERIC_TYPE double -#define TRANSPOSE_2D_ARRAY transpose_doubles -#define GENERIC_TYPE_A double -#define GENERIC_TYPE_B double -#define GENERIC_TYPE_C double -#define INNERPROD_FUNCTION innerprod_double_double -#if SLANG_HAS_COMPLEX -# define INNERPROD_COMPLEX_A innerprod_complex_double -# define INNERPROD_A_COMPLEX innerprod_double_complex -#endif -#include "slarrfun.inc" - -#define GENERIC_TYPE_A double -#define GENERIC_TYPE_B float -#define GENERIC_TYPE_C double -#define INNERPROD_FUNCTION innerprod_double_float -#include "slarrfun.inc" - -#define GENERIC_TYPE_A float -#define GENERIC_TYPE_B double -#define GENERIC_TYPE_C double -#define INNERPROD_FUNCTION innerprod_float_double -#include "slarrfun.inc" - -/* Finally pick up the complex_complex multiplication - * and do the integers - */ -#if SLANG_HAS_COMPLEX -# define INNERPROD_COMPLEX_COMPLEX innerprod_complex_complex -#endif -#define GENERIC_TYPE int -#define TRANSPOSE_2D_ARRAY transpose_ints -#include "slarrfun.inc" - -#if SIZEOF_LONG != SIZEOF_INT -# define GENERIC_TYPE long -# define TRANSPOSE_2D_ARRAY transpose_longs -# include "slarrfun.inc" -#else -# define transpose_longs transpose_ints -#endif - -#if SIZEOF_SHORT != SIZEOF_INT -# define GENERIC_TYPE short -# define TRANSPOSE_2D_ARRAY transpose_shorts -# include "slarrfun.inc" -#else -# define transpose_shorts transpose_ints -#endif - -#define GENERIC_TYPE char -#define TRANSPOSE_2D_ARRAY transpose_chars -#include "slarrfun.inc" - -/* This routine works only with linear arrays */ -static SLang_Array_Type *transpose (SLang_Array_Type *at) -{ - int dims [SLARRAY_MAX_DIMS]; - int *max_dims; - unsigned int num_dims; - SLang_Array_Type *bt; - int i; - unsigned int sizeof_type; - int is_ptr; - char *b_data; - - max_dims = at->dims; - num_dims = at->num_dims; - - if ((at->num_elements == 0) - || (num_dims == 1)) - { - bt = SLang_duplicate_array (at); - if (num_dims == 1) bt->num_dims = 2; - goto transpose_dims; - } - - /* For numeric arrays skip the overhead below */ - if (num_dims == 2) - { - bt = allocate_transposed_array (at); - if (bt == NULL) return NULL; - - switch (at->data_type) - { - case SLANG_INT_TYPE: - case SLANG_UINT_TYPE: - return transpose_ints (at, bt); - case SLANG_DOUBLE_TYPE: - return transpose_doubles (at, bt); - case SLANG_FLOAT_TYPE: - return transpose_floats (at, bt); - case SLANG_CHAR_TYPE: - case SLANG_UCHAR_TYPE: - return transpose_chars (at, bt); - case SLANG_LONG_TYPE: - case SLANG_ULONG_TYPE: - return transpose_longs (at, bt); - case SLANG_SHORT_TYPE: - case SLANG_USHORT_TYPE: - return transpose_shorts (at, bt); - } - } - else - { - bt = SLang_create_array (at->data_type, 0, NULL, max_dims, num_dims); - if (bt == NULL) return NULL; - } - - sizeof_type = at->sizeof_type; - is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER); - - memset ((char *)dims, 0, sizeof(dims)); - - b_data = (char *) bt->data; - - do - { - if (-1 == _SLarray_aget_transfer_elem (at, dims, (VOID_STAR) b_data, - sizeof_type, is_ptr)) - { - SLang_free_array (bt); - return NULL; - } - b_data += sizeof_type; - } - while (0 == next_transposed_index (dims, max_dims, num_dims)); - - transpose_dims: - - num_dims = bt->num_dims; - for (i = 0; i < (int) num_dims; i++) - bt->dims[i] = max_dims [num_dims - i - 1]; - - return bt; -} - -static void array_transpose (SLang_Array_Type *at) -{ - if (NULL != (at = transpose (at))) - (void) SLang_push_array (at, 1); -} - -static int get_inner_product_parms (SLang_Array_Type *a, int *dp, - unsigned int *loops, unsigned int *other) -{ - int num_dims; - int d; - - d = *dp; - - num_dims = (int)a->num_dims; - if (num_dims == 0) - { - SLang_verror (SL_INVALID_PARM, "Inner-product operation requires an array of at least 1 dimension."); - return -1; - } - - /* An index of -1 refers to last dimension */ - if (d == -1) - d += num_dims; - *dp = d; - - if (a->num_elements == 0) - { /* [] # [] ==> [] */ - *loops = *other = 0; - return 0; - } - - *loops = a->num_elements / a->dims[d]; - - if (d == 0) - { - *other = *loops; /* a->num_elements / a->dims[0]; */ - return 0; - } - - *other = a->dims[d]; - return 0; -} - -/* This routines takes two arrays A_i..j and B_j..k and produces a third - * via C_i..k = A_i..j B_j..k. - * - * If A is a vector, and B is a 2-d matrix, then regard A as a 2-d matrix - * with 1-column. - */ -static void do_inner_product (void) -{ - SLang_Array_Type *a, *b, *c; - void (*fun)(SLang_Array_Type *, SLang_Array_Type *, SLang_Array_Type *, - unsigned int, unsigned int, unsigned int, unsigned int, - unsigned int); - unsigned char c_type; - int dims[SLARRAY_MAX_DIMS]; - int status; - unsigned int a_loops, b_loops, b_inc, a_stride; - int ai_dims, i, j; - unsigned int num_dims, a_num_dims, b_num_dims; - int ai, bi; - - /* The result of a inner_product will be either a float, double, or - * a complex number. - * - * If an integer array is used, it will be promoted to a float. - */ - - switch (SLang_peek_at_stack1 ()) - { - case SLANG_DOUBLE_TYPE: - if (-1 == SLang_pop_array_of_type (&b, SLANG_DOUBLE_TYPE)) - return; - break; - -#if SLANG_HAS_COMPLEX - case SLANG_COMPLEX_TYPE: - if (-1 == SLang_pop_array_of_type (&b, SLANG_COMPLEX_TYPE)) - return; - break; -#endif - case SLANG_FLOAT_TYPE: - default: - if (-1 == SLang_pop_array_of_type (&b, SLANG_FLOAT_TYPE)) - return; - break; - } - - switch (SLang_peek_at_stack1 ()) - { - case SLANG_DOUBLE_TYPE: - status = SLang_pop_array_of_type (&a, SLANG_DOUBLE_TYPE); - break; - -#if SLANG_HAS_COMPLEX - case SLANG_COMPLEX_TYPE: - status = SLang_pop_array_of_type (&a, SLANG_COMPLEX_TYPE); - break; -#endif - case SLANG_FLOAT_TYPE: - default: - status = SLang_pop_array_of_type (&a, SLANG_FLOAT_TYPE); - break; - } - - if (status == -1) - { - SLang_free_array (b); - return; - } - - ai = -1; /* last index of a */ - bi = 0; /* first index of b */ - if ((-1 == get_inner_product_parms (a, &ai, &a_loops, &a_stride)) - || (-1 == get_inner_product_parms (b, &bi, &b_loops, &b_inc))) - { - SLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product"); - goto free_and_return; - } - - a_num_dims = a->num_dims; - b_num_dims = b->num_dims; - - /* Coerse a 1-d vector to 2-d */ - if ((a_num_dims == 1) - && (b_num_dims == 2) - && (a->num_elements)) - { - a_num_dims = 2; - ai = 1; - a_loops = a->num_elements; - a_stride = 1; - } - - if ((ai_dims = a->dims[ai]) != b->dims[bi]) - { - SLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product"); - goto free_and_return; - } - - num_dims = a_num_dims + b_num_dims - 2; - if (num_dims > SLARRAY_MAX_DIMS) - { - SLang_verror (SL_NOT_IMPLEMENTED, - "Inner-product result exceed max allowed dimensions"); - goto free_and_return; - } - - if (num_dims) - { - j = 0; - for (i = 0; i < (int)a_num_dims; i++) - if (i != ai) dims [j++] = a->dims[i]; - for (i = 0; i < (int)b_num_dims; i++) - if (i != bi) dims [j++] = b->dims[i]; - } - else - { - /* a scalar */ - num_dims = 1; - dims[0] = 1; - } - - c_type = 0; fun = NULL; - switch (a->data_type) - { - case SLANG_FLOAT_TYPE: - switch (b->data_type) - { - case SLANG_FLOAT_TYPE: - c_type = SLANG_FLOAT_TYPE; - fun = innerprod_float_float; - break; - case SLANG_DOUBLE_TYPE: - c_type = SLANG_DOUBLE_TYPE; - fun = innerprod_float_double; - break; -#if SLANG_HAS_COMPLEX - case SLANG_COMPLEX_TYPE: - c_type = SLANG_COMPLEX_TYPE; - fun = innerprod_float_complex; - break; -#endif - } - break; - case SLANG_DOUBLE_TYPE: - switch (b->data_type) - { - case SLANG_FLOAT_TYPE: - c_type = SLANG_DOUBLE_TYPE; - fun = innerprod_double_float; - break; - case SLANG_DOUBLE_TYPE: - c_type = SLANG_DOUBLE_TYPE; - fun = innerprod_double_double; - break; -#if SLANG_HAS_COMPLEX - case SLANG_COMPLEX_TYPE: - c_type = SLANG_COMPLEX_TYPE; - fun = innerprod_double_complex; - break; -#endif - } - break; -#if SLANG_HAS_COMPLEX - case SLANG_COMPLEX_TYPE: - c_type = SLANG_COMPLEX_TYPE; - switch (b->data_type) - { - case SLANG_FLOAT_TYPE: - fun = innerprod_complex_float; - break; - case SLANG_DOUBLE_TYPE: - fun = innerprod_complex_double; - break; - case SLANG_COMPLEX_TYPE: - fun = innerprod_complex_complex; - break; - } - break; -#endif - default: - break; - } - - if (NULL == (c = SLang_create_array (c_type, 0, NULL, dims, num_dims))) - goto free_and_return; - - (*fun)(a, b, c, a_loops, a_stride, b_loops, b_inc, ai_dims); - - (void) SLang_push_array (c, 1); - /* drop */ - - free_and_return: - SLang_free_array (a); - SLang_free_array (b); -} - - - -static SLang_Intrin_Fun_Type Array_Fun_Table [] = -{ - MAKE_INTRINSIC_1("transpose", array_transpose, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), - SLANG_END_INTRIN_FUN_TABLE -}; - -int SLang_init_array (void) -{ - if (-1 == SLadd_intrin_fun_table (Array_Fun_Table, "__SLARRAY__")) - return -1; -#if SLANG_HAS_FLOAT - _SLang_Matrix_Multiply = do_inner_product; -#endif - return 0; -} - |