static int is_numeric_intrinsic (void) { int type; if (-1 == (type = SLang_peek_at_stack1 ())) return -1; (void) SLdo_pop (); return is_numeric ((SLtype) type); }
static int pop_array_or_scalar (Array_Or_Scalar_Type *ast) { SLang_Array_Type *at; ast->at = NULL; ast->inc = 0; ast->num = 1; switch (SLang_peek_at_stack1 ()) { case -1: return -1; case SLANG_FLOAT_TYPE: ast->is_float = 1; if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE) { if (-1 == SLang_pop_array_of_type (&at, SLANG_FLOAT_TYPE)) return -1; ast->fptr = (float *) at->data; ast->inc = 1; ast->num = at->num_elements; ast->at = at; return 0; } ast->fptr = &ast->f; if (-1 == SLang_pop_float (ast->fptr)) return -1; return 0; default: ast->is_float = 0; if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE) { if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE)) return -1; ast->dptr = (double *) at->data; ast->inc = 1; ast->num = at->num_elements; ast->at = at; return 0; } ast->dptr = &ast->d; if (-1 == SLang_pop_double (ast->dptr)) return -1; return 0; } }
static void nint_intrin (void) { double x; SLang_Array_Type *at, *bt; int (*at_to_int_fun)(SLang_Array_Type *, SLang_Array_Type *); if (SLang_peek_at_stack () != SLANG_ARRAY_TYPE) { if (-1 == SLang_pop_double (&x)) return; (void) SLang_push_int (do_nint (x)); return; } switch (SLang_peek_at_stack1 ()) { case -1: return; case SLANG_INT_TYPE: return; case SLANG_FLOAT_TYPE: if (-1 == SLang_pop_array_of_type (&at, SLANG_FLOAT_TYPE)) return; at_to_int_fun = float_to_nint; break; case SLANG_DOUBLE_TYPE: default: if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE)) return; at_to_int_fun = double_to_nint; break; } if (NULL == (bt = SLang_create_array1 (SLANG_INT_TYPE, 0, NULL, at->dims, at->num_dims, 1))) { SLang_free_array (at); return; } if (0 == (*at_to_int_fun) (at, bt)) (void) SLang_push_array (bt, 0); SLang_free_array (bt); SLang_free_array (at); }
static int map_or_contract_array (SLCONST SLarray_Map_Type *c, int use_contraction, int dim_specified, int *use_this_dim, VOID_STAR clientdata) { int k, use_all_dims; SLang_Array_Type *at, *new_at; SLindex_Type *old_dims; SLindex_Type old_dims_buf[SLARRAY_MAX_DIMS]; SLindex_Type sub_dims[SLARRAY_MAX_DIMS]; SLindex_Type tmp_dims[SLARRAY_MAX_DIMS]; unsigned int i, j, old_num_dims, sub_num_dims; SLtype new_data_type, old_data_type; char *old_data, *new_data; SLindex_Type w[SLARRAY_MAX_DIMS], wk; size_t old_sizeof_type, new_sizeof_type; SLuindex_Type dims_k; int from_type; SLCONST SLarray_Map_Type *csave; SLarray_Map_Fun_Type *fmap; SLarray_Contract_Fun_Type *fcon; use_all_dims = 1; k = 0; if (dim_specified) { if (use_this_dim != NULL) { k = *use_this_dim; use_all_dims = 0; } } else if (SLang_Num_Function_Args == 2) { if (-1 == SLang_pop_integer (&k)) return -1; use_all_dims = 0; } if (-1 == (from_type = SLang_peek_at_stack1 ())) return -1; csave = c; while (c->f != NULL) { if (c->from_type == (SLtype) from_type) break; c++; } /* Look for a more generic version */ if (c->f != NULL) { if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type)) return -1; } else { /* Look for a wildcard match */ c = csave; while (c->f != NULL) { if (c->from_type == SLANG_VOID_TYPE) break; c++; } if (c->f == NULL) { _pSLang_verror (SL_TYPE_MISMATCH, "%s is not supported by this function", SLclass_get_datatype_name (from_type)); return -1; } /* Found it. So, typecast it to appropriate type */ if (c->typecast_to_type == SLANG_VOID_TYPE) { if (-1 == SLang_pop_array (&at, 1)) return -1; } else if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type)) return -1; } old_data_type = at->data_type; if (SLANG_VOID_TYPE == (new_data_type = c->result_type)) new_data_type = old_data_type; old_num_dims = at->num_dims; if (use_all_dims == 0) { if (k < 0) k += old_num_dims; if ((k < 0) || (k >= (int)old_num_dims)) { _pSLang_verror (SL_INVALID_PARM, "Dimension %d is invalid for a %d-d array", k, old_num_dims); SLang_free_array (at); return -1; } old_dims = at->dims; } else { old_dims = old_dims_buf; old_dims[0] = (SLindex_Type)at->num_elements; old_num_dims = 1; } fcon = (SLarray_Contract_Fun_Type *) c->f; fmap = c->f; if (use_contraction && (use_all_dims || (old_num_dims == 1))) { SLang_Class_Type *cl; VOID_STAR buf; int status = 0; cl = _pSLclass_get_class (new_data_type); buf = cl->cl_transfer_buf; if (at->num_elements == 0) { /* If there are no elements, the fcon may or may not * compute a value. So, clear the buffer */ memset ((char *)buf, 0, cl->cl_sizeof_type); } if ((-1 == (*fcon) (at->data, 1, at->num_elements, buf)) || (-1 == SLang_push_value (new_data_type, buf))) status = -1; SLang_free_array (at); return status; } /* The offset for the index i_0,i_1,...i_{N-1} is * i_0*W_0 + i_1*W_1 + ... i_{N-1}*W{N-1} * where W_j = d_{j+1}d_{j+2}...d_{N-1} * and d_k is the number of elements of the kth dimension. * * For a specified value of k, we * So, summing over all elements in the kth dimension of the array * means using the set of offsets given by * * i_k*W_k + sum(j!=k) i_j*W_j. * * So, we want to loop of all dimensions except for the kth using an * offset given by sum(j!=k)i_jW_j, and an increment W_k between elements. */ wk = 1; i = old_num_dims; while (i != 0) { i--; w[i] = wk; wk *= old_dims[i]; } wk = w[k]; /* Now set up the sub array */ j = 0; for (i = 0; i < old_num_dims; i++) { if (i == (unsigned int) k) continue; sub_dims[j] = old_dims[i]; w[j] = w[i]; tmp_dims[j] = 0; j++; } sub_num_dims = old_num_dims - 1; if (use_contraction) new_at = SLang_create_array1 (new_data_type, 0, NULL, sub_dims, sub_num_dims, 1); else new_at = SLang_create_array1 (new_data_type, 0, NULL, old_dims, old_num_dims, 1); if (new_at == NULL) { SLang_free_array (at); return -1; } new_data = (char *)new_at->data; old_data = (char *)at->data; old_sizeof_type = at->sizeof_type; new_sizeof_type = new_at->sizeof_type; dims_k = old_dims[k] * wk; /* Skip this for cases such as sum(Double_Type[0,0], 1). Otherwise, * (*fcon) will write to new_data, which has no length */ if (new_at->num_elements) do { size_t offset = 0; int status; for (i = 0; i < sub_num_dims; i++) offset += w[i] * tmp_dims[i]; if (use_contraction) { status = (*fcon) ((VOID_STAR)(old_data + offset*old_sizeof_type), wk, dims_k, (VOID_STAR) new_data); new_data += new_sizeof_type; } else { status = (*fmap) (old_data_type, (VOID_STAR) (old_data + offset*old_sizeof_type), wk, dims_k, new_data_type, (VOID_STAR) (new_data + offset*new_sizeof_type), clientdata); } if (status == -1) { SLang_free_array (new_at); SLang_free_array (at); return -1; } } while (-1 != _pSLarray_next_index (tmp_dims, sub_dims, sub_num_dims)); SLang_free_array (at); return SLang_push_array (new_at, 1); }
/* 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); SLtype c_type; SLindex_Type 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))) { _pSLang_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]) { _pSLang_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) { _pSLang_verror (SL_NOT_IMPLEMENTED, "Inner-product result exceeds maximum 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); }