static int do_binary_function_c (int (*f)(double, double,VOID_STAR), VOID_STAR cd) { Array_Or_Scalar_Type a_ast, b_ast, c_ast; if (-1 == pop_2_arrays_or_scalar (&a_ast, &b_ast)) return -1; c_ast.at = NULL; c_ast.num = 1; c_ast.inc = 0; c_ast.cptr = &c_ast.c; if ((a_ast.at != NULL) || (b_ast.at != NULL)) { if (a_ast.at != NULL) c_ast.at = SLang_create_array1 (SLANG_CHAR_TYPE, 0, NULL, a_ast.at->dims, a_ast.at->num_dims, 1); else c_ast.at = SLang_create_array1 (SLANG_CHAR_TYPE, 0, NULL, b_ast.at->dims, b_ast.at->num_dims, 1); if (c_ast.at == NULL) { free_array_or_scalar (&a_ast); free_array_or_scalar (&b_ast); return -1; } c_ast.cptr = (char *) c_ast.at->data; c_ast.num = c_ast.at->num_elements; c_ast.inc = 1; } if (a_ast.is_float) { if (b_ast.is_float) (void) do_c_ff_fun (f, cd, &a_ast, &b_ast, &c_ast); else (void) do_c_fd_fun (f, cd, &a_ast, &b_ast, &c_ast); } else if (b_ast.is_float) (void) do_c_df_fun (f, cd, &a_ast, &b_ast, &c_ast); else (void) do_c_dd_fun (f, cd, &a_ast, &b_ast, &c_ast); free_array_or_scalar (&a_ast); free_array_or_scalar (&b_ast); if (c_ast.at != NULL) return SLang_push_array (c_ast.at, 1); return SLang_push_char (c_ast.c); }
/* This is called when at is 2d */ static SLang_Array_Type *allocate_transposed_array (SLang_Array_Type *at) { SLang_Array_Type *bt; int no_init; no_init = (0 == (at->flags & SLARR_DATA_VALUE_IS_POINTER)); bt = SLang_create_array1 (at->data_type, 0, NULL, at->dims, 2, no_init); if (bt != NULL) { bt->dims[1] = at->dims[0]; bt->dims[0] = at->dims[1]; } return bt; }
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 SLang_Array_Type *create_from_tmp_array (SLang_Array_Type *a, SLang_Array_Type *b, SLtype type) { SLang_Array_Type *c; if ((a != NULL) && (a->data_type == type) && (a->num_refs == 1)) { a->num_refs += 1; return a; } if ((b != NULL) && (b->data_type == type) && (b->num_refs == 1)) { b->num_refs += 1; return b; } if (a != NULL) c = a; else c = b; return SLang_create_array1 (type, 0, NULL, c->dims, c->num_dims, 1); }
static int pop_array_or_string (SLtype itype, char **sp, SLang_Array_Type **atsp, SLang_Array_Type **atip) { char *s; if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE) { SLang_Array_Type *ats, *ati; *sp = NULL; if (-1 == SLang_pop_array_of_type (&ats, SLANG_STRING_TYPE)) { *atsp = NULL; *atip = NULL; return -1; } if (NULL == (ati = SLang_create_array1 (itype, 0, NULL, ats->dims, ats->num_dims, 1))) { *atsp = NULL; *atip = NULL; SLang_free_array (ats); return -1; } *atsp = ats; *atip = ati; return 0; } *atsp = NULL; *atip = NULL; if (-1 == SLang_pop_slstring (&s)) { *sp = NULL; return -1; } *sp = s; return 0; }
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); }