static int push_three_float_arrays (SLindex_Type n, float *a, float *b, float *c) /*{{{*/
{
SLang_Array_Type *sl_a=NULL, *sl_b=NULL, *sl_c=NULL;
int status = -1;
if (a == NULL || b == NULL || c == NULL)
return -1;
if ((NULL == (sl_a = SLang_create_array (SLANG_FLOAT_TYPE, 0, NULL, &n, 1)))
|| NULL == (sl_b = SLang_create_array (SLANG_FLOAT_TYPE, 0, NULL, &n, 1))
|| NULL == (sl_c = SLang_create_array (SLANG_FLOAT_TYPE, 0, NULL, &n, 1)))
goto return_status;
memcpy ((char *)sl_a->data, (char *)a, n * sizeof(float));
memcpy ((char *)sl_b->data, (char *)b, n * sizeof(float));
memcpy ((char *)sl_c->data, (char *)c, n * sizeof(float));
SLang_push_array (sl_a, 1);
SLang_push_array (sl_b, 1);
SLang_push_array (sl_c, 1);
status = 0;
return_status:
if (status)
{
SLang_free_array (sl_a);
SLang_free_array (sl_b);
SLang_free_array (sl_c);
}
return status;
}
static void _fft1d (int *isign, double *scaling) /*{{{*/
{
SLang_Array_Type *re, *im;
int dims;
int ndim = 1;
re = im = NULL;
if (-1 == SLang_pop_array_of_type (&im, SLANG_DOUBLE_TYPE)
|| im == NULL
|| -1 == SLang_pop_array_of_type (&re, SLANG_DOUBLE_TYPE)
|| re == NULL
|| re->num_elements != im->num_elements
|| abs(*isign) != 1)
{
isis_vmesg (FAIL, I_ERROR, __FILE__, __LINE__, "invalid input to FFT");
goto push_values;
}
dims = (int) re->num_elements;
if (-1 == JDMfftn (ndim, &dims, (double *)re->data,
(double *)im->data, *isign, *scaling))
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__, "computing FFT");
JDMfft_free ();
push_values:
(void) SLang_push_array (re, 1);
(void) SLang_push_array (im, 1);
}
static void read_image (int flipped)
{
int color_type;
char *file;
SLang_Ref_Type *ref = NULL;
SLang_Array_Type *at;
if ((SLang_Num_Function_Args == 2)
&& (-1 == SLang_pop_ref (&ref)))
return;
if (-1 == SLang_pop_slstring (&file))
{
file = NULL;
goto free_return;
}
if (NULL == (at = read_image_internal (file, flipped, &color_type)))
goto free_return;
if ((ref != NULL)
&& (-1 == SLang_assign_to_ref (ref, SLANG_INT_TYPE, &color_type)))
{
SLang_free_array (at);
goto free_return;
}
(void) SLang_push_array (at, 1);
free_return:
SLang_free_slstring (file);
if (ref != NULL)
SLang_free_ref (ref);
}
static void lu_solve_intrin (void)
{
Linear_System_Type t;
SLang_Array_Type *sl_b = NULL;
unsigned int *piv = NULL;
if ((-1 == pop_linear_system (&t))
|| (NULL == (piv = (unsigned int *) ISIS_MALLOC (t.n * sizeof(unsigned int)))))
{
isis_throw_exception (Isis_Error);
goto the_return;
}
if (-1 == isis_lu_solve (t.a, t.n, piv, t.b))
goto the_return;
sl_b = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &t.n, 1);
if (sl_b != NULL)
{
memcpy ((char *)sl_b->data, (char *)t.b, t.n * sizeof (double));
}
the_return:
SLang_push_array (sl_b, 1);
free_linear_system (&t);
ISIS_FREE(piv);
}
static int push_values_array (Values_Array_Type *av, int allow_empty_array)
{
SLang_Array_Type *at;
char **new_values;
if (av->num == 0)
{
if (allow_empty_array == 0)
return SLang_push_null ();
SLfree ((char *) av->values);
av->values = NULL;
}
else
{
if (NULL == (new_values = (char **)SLrealloc ((char *)av->values, av->num*sizeof(char *))))
return -1;
av->values = new_values;
}
av->num_allocated = av->num;
at = SLang_create_array (SLANG_STRING_TYPE, 0, av->values, &av->num, 1);
if (at == NULL)
return -1;
av->num_allocated = 0;
av->num = 0;
av->values = NULL;
return SLang_push_array (at, 1);
}
static void intrin_atof (void)
{
char *s;
SLang_Array_Type *ats;
SLang_Array_Type *ati;
double *ip;
char **strp, **strpmax;
if (-1 == pop_array_or_string (SLANG_DOUBLE_TYPE, &s, &ats, &ati))
return;
if (s != NULL)
{
(void) SLang_push_double(_pSLang_atof(s));
SLang_free_slstring (s);
return;
}
strp = (char **) ats->data;
strpmax = strp + ats->num_elements;
ip = (double *) ati->data;
while (strp < strpmax)
{
if (*strp == NULL)
*ip++ = _pSLang_NaN;
else
*ip++ = _pSLang_atof (*strp);
strp++;
}
SLang_free_array (ats);
(void) SLang_push_array (ati, 1);
}
static int push_cols (double *d, unsigned int n, unsigned int ncols) /*{{{*/
{
SLindex_Type nrows;
unsigned int c;
if ((ncols == 0) || (d == NULL))
return -1;
nrows = n / ncols;
for (c = 0; c < ncols; c++)
{
SLang_Array_Type *at;
unsigned int k, i;
double *x;
at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &nrows, 1);
if (at == NULL)
return -1;
x = (double *) at->data;
i = 0;
for (k = c; k < n; k += ncols)
{
x[i++] = d[k];
}
SLang_push_array (at, 1);
}
return 0;
}
static void atoll_intrin (void)
{
char *s;
SLang_Array_Type *ats;
SLang_Array_Type *ati;
long long *ip;
char **strp, **strpmax;
if (-1 == pop_array_or_string (_pSLANG_LLONG_TYPE, &s, &ats, &ati))
return;
if (s != NULL)
{
(void) SLang_push_long_long (ATOLL_FUN(s));
SLang_free_slstring (s);
return;
}
strp = (char **) ats->data;
strpmax = strp + ats->num_elements;
ip = (long long *) ati->data;
while (strp < strpmax)
{
if (*strp == NULL)
*ip++ = 0;
else
*ip++ = ATOLL_FUN (*strp);
strp++;
}
SLang_free_array (ats);
(void) SLang_push_array (ati, 1);
}
static void atoi_intrin (void)
{
char *s;
SLang_Array_Type *ats;
SLang_Array_Type *ati;
int *ip;
char **strp, **strpmax;
if (-1 == pop_array_or_string (SLANG_INT_TYPE, &s, &ats, &ati))
return;
if (s != NULL)
{
(void) SLang_push_integer (atoi (s));
SLang_free_slstring (s);
return;
}
strp = (char **) ats->data;
strpmax = strp + ats->num_elements;
ip = (int *) ati->data;
while (strp < strpmax)
{
if (*strp == NULL)
*ip++ = 0;
else
*ip++ = atoi (*strp);
strp++;
}
SLang_free_array (ats);
(void) SLang_push_array (ati, 1);
}
static void get_onig_names (Name_Map_Type *map)
{
SLindex_Type i, num;
SLang_Array_Type *at;
char **names;
Name_Map_Type *table;
table = map;
while (table->name != NULL)
table++;
num = (SLindex_Type) (table - map);
if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num, 1)))
return;
table = map;
names = (char **)at->data;
for (i = 0; i < num; i++)
{
if (NULL == (names[i] = SLang_create_slstring (table->name)))
{
SLang_free_array (at);
return;
}
table++;
}
(void) SLang_push_array (at, 1);
}
static void assoc_get_keys (SLang_Assoc_Array_Type *a)
{
SLang_Array_Type *at;
SLindex_Type i, num;
char **data;
_pSLAssoc_Array_Element_Type *e, *emax;
/* Note: If support for threads is added, then we need to modify this
* algorithm to prevent another thread from modifying the array.
* However, that should be handled in inner_interp.
*/
num = a->num_occupied - a->num_deleted;
if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num, 1)))
return;
data = (char **)at->data;
e = a->elements;
emax = e + a->table_len;
i = 0;
while (e < emax)
{
if ((e->key != NULL) && (e->key != Deleted_Key))
{
/* Next cannot fail because it is an slstring */
data [i] = _pSLstring_dup_hashed_string (e->key, e->hash);
i++;
}
e++;
}
(void) SLang_push_array (at, 1);
}
static int do_binary_function (double (*f)(double, double))
{
SLtype type;
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.is_float = (a_ast.is_float && b_ast.is_float);
c_ast.at = NULL;
c_ast.num = 1;
c_ast.inc = 0;
if (c_ast.is_float)
{
type = SLANG_FLOAT_TYPE;
c_ast.fptr = &c_ast.f;
}
else
{
type = SLANG_DOUBLE_TYPE;
c_ast.dptr = &c_ast.d;
}
if ((a_ast.at != NULL) || (b_ast.at != NULL))
{
if (NULL == (c_ast.at = create_from_tmp_array (a_ast.at, b_ast.at, type)))
{
free_array_or_scalar (&a_ast);
free_array_or_scalar (&b_ast);
return -1;
}
c_ast.fptr = (float *) c_ast.at->data;
c_ast.dptr = (double *) 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_ff_fun (f, &a_ast, &b_ast, &c_ast);
else
(void) do_fd_fun (f, &a_ast, &b_ast, &c_ast);
}
else if (b_ast.is_float)
(void) do_df_fun (f, &a_ast, &b_ast, &c_ast);
else
(void) do_dd_fun (f, &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);
if (c_ast.is_float)
return SLang_push_float (c_ast.f);
return SLang_push_double (c_ast.d);
}
static void prand_array (double *rate, SLindex_Type *num) /*{{{*/
{
SLang_Array_Type *at = NULL;
double *ai;
SLindex_Type i, n;
n = *num;
if (n == 0)
return;
else if (n == 1)
{
SLang_push_double (prand (*rate));
return;
}
if (NULL == (at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))
{
isis_vmesg (INTR, I_FAILED, __FILE__, __LINE__, "creating array of random values");
return;
}
ai = (double *) at->data;
for (i = 0; i < n; i++)
{
ai[i] = prand (*rate);
}
SLang_push_array (at, 1);
}
static void rand_array (SLindex_Type num, double (*rand_fun)(void)) /*{{{*/
{
SLang_Array_Type *at = NULL;
double *ad;
SLindex_Type i;
if (num <= 0)
return;
else if (num == 1)
{
SLang_push_double ((*rand_fun)());
return;
}
if (NULL == (at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &num, 1)))
{
isis_vmesg (INTR, I_FAILED, __FILE__, __LINE__, "creating array of random values");
return;
}
ad = (double *) at->data;
for (i = 0; i < num; i++)
ad[i] = (*rand_fun) ();
SLang_push_array (at, 1);
}
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);
}
static void prand_vec (void) /*{{{*/
{
SLang_Array_Type *rate = NULL;
double *r;
SLindex_Type i, n;
if (-1 == SLang_pop_array_of_type (&rate, SLANG_DOUBLE_TYPE)
|| rate == NULL)
{
SLang_free_array (rate); rate = NULL;
SLang_push_array (rate, 1);
return;
}
n = rate->num_elements;
r = (double *)rate->data;
for (i = 0; i < n; i++)
{
r[i] = prand (r[i]);
}
SLang_push_array (rate, 1);
}
static void termios_get_cc (struct termios *s)
{
SLang_Array_Type *at;
SLindex_Type dims = NCCS;
int i;
unsigned char *at_data;
at = SLang_create_array (SLANG_UCHAR_TYPE, 0, NULL, &dims, 1);
if (at == NULL)
return;
at_data = (unsigned char *) at->data;
for (i = 0; i < NCCS; i++)
at_data[i] = (unsigned char) s->c_cc[i];
(void) SLang_push_array (at, 1);
}
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);
}
int _pSLstring_list_push (_pSLString_List_Type *p, int delete_list)
{
SLang_Array_Type *at;
if ((p == NULL)
|| (p->buf == NULL))
{
int ret = SLang_push_null ();
if (delete_list)
_pSLstring_list_delete (p);
return ret;
}
if (NULL == (at = string_list_to_array (p, delete_list)))
return -1;
return SLang_push_array (at, 1);
}
static void assoc_get_values (SLang_Assoc_Array_Type *a)
{
SLang_Array_Type *at;
SLindex_Type num;
char *dest_data;
SLtype type;
SLang_Class_Type *cl;
unsigned int sizeof_type;
_pSLAssoc_Array_Element_Type *e, *emax;
/* Note: If support for threads is added, then we need to modify this
* algorithm to prevent another thread from modifying the array.
* However, that should be handled in inner_interp.
*/
num = a->num_occupied - a->num_deleted;
type = a->type;
cl = _pSLclass_get_class (type);
sizeof_type = cl->cl_sizeof_type;
if (NULL == (at = SLang_create_array (type, 0, NULL, &num, 1)))
return;
dest_data = (char *)at->data;
e = a->elements;
emax = e + a->table_len;
while (e < emax)
{
if ((e->key != NULL) && (e->key != Deleted_Key))
{
if (-1 == transfer_element (cl, (VOID_STAR) dest_data, &e->value))
{
SLang_free_array (at);
return;
}
dest_data += sizeof_type;
}
e++;
}
(void) SLang_push_array (at, 1);
}
static void intrin_apropos (void)
{
int num_args;
char *pat;
char *namespace_name;
unsigned int flags;
SLang_Array_Type *at;
num_args = SLang_Num_Function_Args;
if (-1 == SLang_pop_uinteger (&flags))
return;
if (-1 == SLang_pop_slstring (&pat))
return;
namespace_name = NULL;
at = NULL;
if (num_args == 3)
{
if (-1 == SLang_pop_slstring (&namespace_name))
goto free_and_return;
}
at = _pSLang_apropos (namespace_name, pat, flags);
if (num_args == 3)
{
(void) SLang_push_array (at, 0);
goto free_and_return;
}
/* Maintain compatibility with old version of the function. That version
* did not take three arguments and returned everything to the stack.
* Yuk.
*/
(void) push_string_array_elements (at);
free_and_return:
/* NULLs ok */
SLang_free_slstring (namespace_name);
SLang_free_slstring (pat);
SLang_free_array (at);
}
static void nth_match (Onig_Type *o, int *np)
{
unsigned int start, stop;
SLang_Array_Type *at;
SLindex_Type two = 2;
int *data;
if (-1 == get_nth_start_stop (o, (unsigned int) *np, &start, &stop))
{
SLang_push_null ();
return;
}
if (NULL == (at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &two, 1)))
return;
data = (int *)at->data;
data[0] = (int)start;
data[1] = (int)stop;
(void) SLang_push_array (at, 1);
}
static int push_c_string_array (char **argv, int argc)
{
SLang_Array_Type *at;
char **strs;
int i;
if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 1, NULL, &argc, 1)))
return -1;
strs = (char **) at->data;
for (i = 0; i < argc; i++)
{
if (NULL == (strs[i] = SLang_create_slstring (argv[i])))
{
SLang_free_array (at);
return -1;
}
}
return SLang_push_array (at, 1);
}
static int apply_line_modifier (Model_t *m, Model_Info_Type *info, DB_line_t *line, double *emis) /*{{{*/
{
Plasma_State_Type lm_state;
lm_state.temperature = m->temperature;
lm_state.ndensity = m->density;
SLang_start_arg_list ();
SLang_push_array (info->line_emis_modifier_params, 0);
SLang_push_int (line->indx);
if (-1 == SLang_push_cstruct ((VOID_STAR)&lm_state, Plasma_State_Layout))
return -1;
SLang_push_double (*emis);
if (info->line_emis_modifier_args != NULL)
isis_push_args (info->line_emis_modifier_args);
if (info->line_emis_modifier_qualifiers == NULL)
{
SLang_end_arg_list ();
if (-1 == SLexecute_function (info->line_emis_modifier))
return -1;
}
else
{
if ((-1 == SLang_push_function (info->line_emis_modifier))
|| (-1 == SLang_push_struct (info->line_emis_modifier_qualifiers)))
return -1;
SLang_end_arg_list ();
if (-1 == SLang_execute_function ("_isis->do_eval_with_qualifiers"))
return -1;
}
if (-1 == SLang_pop_double (emis))
return -1;
return 0;
}
static void sl_ssl_get_cert(void){
SLssl_Type *ssl;
SLang_MMT_Type *sslmmt;
STACK_OF(X509) *cert;
unsigned char **buf;
SLang_BString_Type **certout;
SLang_Array_Type *arr;
SLindex_Type nelem;
int len,i;
if (NULL==(sslmmt=SLang_pop_mmt(SLssl_Type_Id)))
return;
ssl=(SLssl_Type *)SLang_object_from_mmt(sslmmt);
cert=SSL_get_peer_cert_chain((SSL *)ssl->ssl);
if (cert==NULL)
return NULL;
nelem=(SLindex_Type)sk_X509_num(cert);
// now we have chain of certs, create array of pointers and the
// array to hold them
buf = (unsigned char **)malloc(nelem*sizeof(unsigned char *));
arr = SLang_create_array(SLANG_BSTRING_TYPE,0,NULL,&nelem,1);
// array data structure is of bstring type
certout = (SLang_BString_Type **)arr->data;
for (i=0;i<nelem;i++){
buf[i] = NULL;
len = i2d_X509(sk_X509_value(cert,i), &(buf[i]));
certout[i] = SLbstring_create(buf[i],len);
}
SLang_push_array(arr,1);
// free the X509 stack
sk_X509_pop_free(cert,X509_free);
}
int Plot_symbol_points (SLindex_Type n, float *x, float *y, int *symbol) /*{{{*/
{
SLang_Array_Type *sl_sym=NULL;
int status = -1;
if (pli_undefined())
return -1;
if (PLI->plot_symbol_points == NULL)
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"plot: plot_symbol_points operation is not supported");
return -1;
}
if (NULL == (sl_sym = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &n, 1)))
return -1;
memcpy ((char *)sl_sym->data, (char *)symbol, n * sizeof(int));
SLang_start_arg_list ();
status = push_two_float_arrays (n, x, y);
SLang_push_array (sl_sym, 1);
SLang_end_arg_list ();
if ((status < 0) || (-1 == SLexecute_function (PLI->plot_symbol_points)))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__, "failed plotting points");
return -1;
}
if (-1 == SLang_pop_integer (&status))
{
isis_vmesg (FAIL, I_ERROR, __FILE__, __LINE__, "failed plotting points");
return -1;
}
return status;
}
static void rline_get_history_intrinsic (void)
{
SLindex_Type i, num;
RL_History_Type *h;
char **data;
SLang_Array_Type *at;
if (Active_Rline_Info == NULL)
{
SLang_push_null ();
return;
}
num = 0;
h = Active_Rline_Info->root;
while (h != NULL)
{
h = h->next;
num++;
}
if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num, 1)))
return;
data = (char **)at->data;
h = Active_Rline_Info->root;
for (i = 0; i < num; i++)
{
if (NULL == (data[i] = SLang_create_slstring (h->buf)))
{
SLang_free_array (at);
return;
}
h = h->next;
}
(void) SLang_push_array (at, 1);
}
static void svd_solve_intrin (void)
{
Linear_System_Type t;
SLang_Array_Type *sl_b = NULL;
if (-1 == pop_linear_system (&t))
{
isis_throw_exception (Isis_Error);
goto the_return;
}
if (-1 == isis_svd_solve (t.a, t.n, t.b))
goto the_return;
sl_b = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &t.n, 1);
if (sl_b != NULL)
{
memcpy ((char *)sl_b->data, (char *)t.b, t.n * sizeof (double));
}
the_return:
SLang_push_array (sl_b, 1);
free_linear_system (&t);
}
static void intrin_get_namespaces (void)
{
SLang_push_array (_pSLns_list_namespaces (), 1);
}
static void make_2d_histogram (int *reverse) /*{{{*/
{
SLang_Array_Type *grid_x, *grid_y, *sl_x, *sl_y, *b;
SLang_Array_Type *rev;
double *x, *y, *bx, *by;
double xmax, ymax;
SLindex_Type *num;
SLindex_Type dims[2];
SLindex_Type i, n, nx, ny, nbins;
SLindex_Type *r = NULL;
grid_x = grid_y = sl_x = sl_y = b = rev = NULL;
if (-1 == pop_two_darrays (&grid_x, &grid_y))
goto push_result;
/* need at least 1 point */
if ((-1 == pop_two_darrays (&sl_x, &sl_y))
|| (sl_x->num_elements != sl_y->num_elements)
|| (sl_x->num_elements < 1))
goto push_result;
n = sl_x->num_elements;
nx = grid_x->num_elements;
ny = grid_y->num_elements;
if (*reverse == 0)
r = NULL;
else
{
if (NULL == (r = (SLindex_Type *) ISIS_MALLOC (n * sizeof (SLindex_Type))))
{
isis_throw_exception (Isis_Error);
goto push_result;
}
for (i = 0; i < n; i++)
{
r[i] = -1;
}
}
dims[0] = nx;
dims[1] = ny;
nbins = dims[0] * dims[1];
if (NULL == (b = SLang_create_array (SLANG_INT_TYPE, 0, NULL, dims, 2)))
{
isis_throw_exception (Isis_Error);
goto push_result;
}
num = (SLindex_Type *)b->data;
memset ((char *)num, 0, nbins * sizeof(SLindex_Type));
bx = (double *)sl_x->data;
by = (double *)sl_y->data;
x = (double *)grid_x->data;
y = (double *)grid_y->data;
xmax = x[nx-1];
ymax = y[ny-1];
for (i = 0; i < n; i++)
{
double b_x = bx[i];
double b_y = by[i];
SLindex_Type ix, iy, k;
if (b_x >= xmax)
ix = nx-1;
else if ((ix = find_bin (b_x, x, x+1, nx-1)) < 0)
continue;
if (b_y >= ymax)
iy = ny-1;
else if ((iy = find_bin (b_y, y, y+1, ny-1)) < 0)
continue;
k = iy + ny * ix;
num[k] += 1;
if (r != NULL) r[i] = k;
}
if ((r != NULL)
&& (NULL == (rev = convert_reverse_indices (r, n, nx*ny))))
goto push_result;
push_result:
SLang_free_array (sl_x);
SLang_free_array (sl_y);
SLang_free_array (grid_x);
SLang_free_array (grid_y);
ISIS_FREE(r);
SLang_push_array (b, 1);
SLang_push_array (rev, 1);
}
