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 int push_opt_data (Isis_Fit_Statistic_Optional_Data_Type *opt_data) /*{{{*/
{
Optional_Data_Type odt;
int n, status=-1;
if (opt_data == NULL)
{
SLang_push_null ();
return 0;
}
memset ((char *)&odt, 0, sizeof odt);
n = opt_data->num;
if ((NULL == (odt.bkg = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))
|| (NULL == (odt.bkg_at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))
|| ((NULL == (odt.src_at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1)))))
goto free_and_return;
memcpy ((char *)odt.bkg->data, (char *)opt_data->bkg, n*sizeof(double));
memcpy ((char *)odt.bkg_at->data, (char *)opt_data->bkg_at, n*sizeof(double));
memcpy ((char *)odt.src_at->data, (char *)opt_data->src_at, n*sizeof(double));
if (-1 == SLang_push_cstruct ((VOID_STAR)&odt, Optional_Data_Type_Layout))
goto free_and_return;
status = 0;
free_and_return:
SLang_free_array (odt.bkg);
SLang_free_array (odt.bkg_at);
SLang_free_array (odt.src_at);
return status;
}
/* reverse index converter from John Davis */
static SLang_Array_Type *convert_reverse_indices (SLindex_Type *r, SLindex_Type num_r, SLindex_Type num_h)
{
SLang_Array_Type *new_r;
SLang_Array_Type **new_r_data;
SLindex_Type i, *lens;
if (NULL == (new_r = SLang_create_array (SLANG_ARRAY_TYPE, 0, NULL, &num_h, 1)))
return NULL;
if (NULL == (lens = (SLindex_Type *)SLmalloc (num_h * sizeof (SLindex_Type))))
{
SLang_free_array (new_r);
return NULL;
}
memset ((char *)lens, 0, num_h*sizeof(SLindex_Type));
for (i = 0; i < num_r; i++)
{
SLindex_Type r_i = r[i];
if (r_i >= 0)
lens[r_i]++;
}
new_r_data = (SLang_Array_Type **) new_r->data;
for (i = 0; i < num_h; i++)
{
if (NULL == (new_r_data[i] = SLang_create_array (SLANG_ARRAY_INDEX_TYPE, 0, NULL, &lens[i], 1)))
goto return_error;
lens[i] = 0;
}
for (i = 0; i < num_r; i++)
{
SLang_Array_Type *at;
SLindex_Type r_i = r[i];
if (r_i < 0)
continue;
at = new_r_data[r_i];
((SLindex_Type *)at->data)[lens[r_i]] = i;
lens[r_i]++;
}
SLfree ((char *)lens);
return new_r;
return_error:
SLfree ((char *) lens);
SLang_free_array (new_r);
return NULL;
}
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 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 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 SLang_Array_Type *string_list_to_array (_pSLString_List_Type *p, int delete_list)
{
unsigned int num;
SLindex_Type inum;
SLang_Array_Type *at;
char **buf;
buf = p->buf;
num = p->num;
if (delete_list == 0)
return _pSLstrings_to_array (buf, num);
inum = (SLindex_Type) num;
if (num == 0) num++; /* so realloc succeeds */
/* Since the list is to be deleted, we can steal the buffer */
if ((num != p->max_num)
&& (NULL == (buf = (char **)SLrealloc ((char *) buf, sizeof (char *) * num))))
{
_pSLstring_list_delete (p);
return NULL;
}
p->max_num = num;
p->buf = buf;
if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, (VOID_STAR) buf, &inum, 1)))
{
_pSLstring_list_delete (p);
return NULL;
}
p->buf = NULL;
_pSLstring_list_delete (p);
return at;
}
SLang_Array_Type *_pSLstrings_to_array (char **strs, unsigned int n)
{
char **data;
SLindex_Type i, inum;
SLang_Array_Type *at;
inum = (SLindex_Type) n;
if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &inum, 1)))
return NULL;
data = (char **)at->data;
for (i = 0; i < inum; i++)
{
if (strs[i] == NULL)
{
data[i] = NULL;
continue;
}
if (NULL == (data[i] = SLang_create_slstring (strs[i])))
{
SLang_free_array (at);
return NULL;
}
}
return at;
}
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_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 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 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 SLang_Array_Type *mask_to_array (sigset_t *mask)
{
SLang_Array_Type *at;
SLindex_Type num;
Signal_Type *s;
int *data;
num = 0;
s = Signal_Table;
while (s->name != NULL)
{
if (sigismember (mask, s->sig))
num++;
s++;
}
at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &num, 1);
if (at == NULL)
return NULL;
s = Signal_Table;
data = (int *)at->data;
while (s->name != NULL)
{
if (sigismember (mask, s->sig))
*data++ = s->sig;
s++;
}
return at;
}
/* Warning: This routine differs from its pgplot counterpart.
* It does not allow the use of old arrays. At most, 1024 points are allocated.
*/
static void _pglcur_pgncur_pgolin (SLang_Ref_Type *rx, SLang_Ref_Type *ry,
int symbol, int what)
{
SLang_Array_Type *a, *b;
float x[1024];
float y[1024];
SLindex_Type n_it;
int n;
n = 0;
switch (what)
{
case 1:
cpglcur (1024, &n, x, y);
break;
case 2:
cpgncur (1024, &n, x, y, symbol);
break;
case 3:
cpgolin (1024, &n, x, y, symbol);
break;
}
if (n < 0)
n = 0;
n_it = n;
if (NULL == (a = SLang_create_array (SLANG_FLOAT_TYPE, 0, NULL, &n_it, 1)))
return;
if (NULL == (b = SLang_create_array (SLANG_FLOAT_TYPE, 0, NULL, &n_it, 1)))
{
SLang_free_array (a);
return;
}
memcpy ((char *)a->data, (char *)x, n * sizeof (float));
memcpy ((char *)b->data, (char *)y, n * sizeof (float));
(void) SLang_assign_to_ref (rx, SLANG_ARRAY_TYPE, &a);
(void) SLang_assign_to_ref (ry, SLANG_ARRAY_TYPE, &b);
free_arrays (a, b, NULL, NULL);
}
static SLang_Array_Type *do_fdisset (int nready, SLang_Array_Type *fds, fd_set *fdset)
{
SLang_Array_Type *at;
int i, num;
SLFile_FD_Type **f;
SLindex_Type ind_nready;
if (fds == NULL)
nready = 0;
if (nready)
{
nready = 0;
num = fds->num_elements;
f = (SLFile_FD_Type **) fds->data;
for (i = 0; i < num; i++)
{
int fd;
if (-1 == SLfile_get_fd (f[i], &fd))
continue;
if (FD_ISSET(fd, fdset))
nready++;
}
}
ind_nready = (SLindex_Type) nready;
at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &ind_nready, 1);
if (at == NULL)
return NULL;
if (nready)
{
int *indx = (int *) at->data;
f = (SLFile_FD_Type **) fds->data;
num = fds->num_elements;
for (i = 0; i < num; i++)
{
int fd;
if (-1 == SLfile_get_fd (f[i], &fd))
continue;
if (FD_ISSET(fd, fdset))
*indx++ = (int) i;
}
}
return at;
}
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 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 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 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);
}
SLang_Array_Type *_SLns_list_namespaces (void)
{
SLang_NameSpace_Type *table_list;
SLang_Array_Type *at;
int num, i;
num = 0;
table_list = Namespace_Tables;
while (table_list != NULL)
{
if (table_list->namespace_name != NULL)
num++;
table_list = table_list->next;
}
at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num, 1);
if (at == NULL)
return NULL;
table_list = Namespace_Tables;
i = 0;
while ((table_list != NULL)
&& (i < num))
{
if (table_list->namespace_name != NULL)
{
char *name = table_list->namespace_name;
if (-1 == SLang_set_array_element (at, &i, (VOID_STAR)&name))
{
SLang_free_array (at);
return NULL;
}
i++;
}
table_list = table_list->next;
}
return at;
}
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 int slfe_optimize (Isis_Fit_Type *ift, void *clientdata, /*{{{*/
double *x, double *y, double *weights, unsigned int npts,
double *pars, unsigned int npars)
{
Isis_Fit_Engine_Type *e;
SLang_Array_Type *sl_pars=NULL, *sl_pars_min=NULL, *sl_pars_max=NULL;
SLang_Array_Type *sl_new_pars=NULL;
SLindex_Type n;
int status = -1;
(void) clientdata; (void) x; (void) y; (void) weights; (void) npts;
if ((ift == NULL) || (pars == NULL) || (npars <= 0)
|| (Current_Fit_Object_MMT == NULL))
return -1;
e = ift->engine;
n = (SLindex_Type) npars;
sl_pars = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1);
sl_pars_min = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1);
sl_pars_max = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &n, 1);
if ((NULL == sl_pars) || (NULL == sl_pars_min) || (NULL == sl_pars_max))
return -1;
memcpy ((char *)sl_pars->data, (char *)pars, npars * sizeof(double));
memcpy ((char *)sl_pars_min->data, (char *)e->par_min, npars * sizeof(double));
memcpy ((char *)sl_pars_max->data, (char *)e->par_max, npars * sizeof(double));
/* FIXME: Increment the reference count to prevent a segv.
* There must be a better way.
*/
SLang_inc_mmt (Current_Fit_Object_MMT);
SLang_start_arg_list ();
if ((-1 == SLang_push_mmt (Current_Fit_Object_MMT))
|| (-1 == SLang_push_array (sl_pars, 1))
|| (-1 == SLang_push_array (sl_pars_min, 1))
|| (-1 == SLang_push_array (sl_pars_max, 1)))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"calling user-defined optimization method '%s'",
e->engine_name);
goto return_error;
}
SLang_end_arg_list ();
if (-1 == SLexecute_function (e->sl_optimize))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"executing optimization method '%s'",
e->engine_name);
goto return_error;
}
if (-1 == SLang_pop_array_of_type (&sl_new_pars, SLANG_DOUBLE_TYPE))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"returning results from optimization method '%s'",
e->engine_name);
goto return_error;
}
if ((sl_new_pars == NULL) || (sl_new_pars->num_elements != npars))
{
isis_vmesg (FAIL, I_ERROR, __FILE__, __LINE__,
"corrupted parameter array returned from optimization method '%s'",
e->engine_name);
goto return_error;
}
memcpy ((char *)pars, (char *)sl_new_pars->data, npars * sizeof(double));
status = 0;
return_error:
SLang_free_array (sl_new_pars);
if (SLang_get_error())
{
isis_throw_exception (SLang_get_error());
return -1;
}
return status;
}
/* For little endian systems, ARGB is equivalent to the int32 BGRA.
* So, to read the image as RGB
*/
static SLang_Array_Type *read_image_internal (char *file, int flip, int *color_typep)
{
Png_Type *p;
png_uint_32 width, height, rowbytes;
png_struct *png;
png_info *info;
int bit_depth;
int interlace_type;
int color_type;
unsigned int sizeof_type;
SLindex_Type dims[2];
SLtype data_type;
png_byte **image_pointers = NULL;
png_byte *data = NULL;
SLang_Array_Type *at;
void (*fixup_array_fun) (SLang_Array_Type *);
if (NULL == (p = open_png_file (file)))
return NULL;
png = p->png;
if (setjmp (png_jmpbuf (png)))
{
free_png_type (p);
if (data != NULL) SLfree ((char *) data);
free_image_pointers (image_pointers);
SLang_verror (SL_Read_Error, "Error encountered during I/O to %s", file);
return NULL;
}
png_init_io (png, p->fp);
png_set_sig_bytes (png, 8);
info = p->info;
png_read_info(png, info);
width = png_get_image_width (png, info);
height = png_get_image_height (png, info);
interlace_type = png_get_interlace_type (png, info);
bit_depth = png_get_bit_depth (png, info);
if (bit_depth == 16)
png_set_strip_16 (png);
switch (png_get_color_type (png, info))
{
case PNG_COLOR_TYPE_GRAY:
#if defined(PNG_LIBPNG_VER) && (PNG_LIBPNG_VER >= 10209)
if (bit_depth < 8) png_set_expand_gray_1_2_4_to_8 (png);
#else /* deprecated */
if (bit_depth < 8) png_set_gray_1_2_4_to_8 (png);
#endif
break;
case PNG_COLOR_TYPE_GRAY_ALPHA:
/* png_set_gray_to_rgb (png); */
break;
case PNG_COLOR_TYPE_PALETTE:
png_set_palette_to_rgb (png);
break;
}
if (png_get_valid(png, info, PNG_INFO_tRNS))
png_set_tRNS_to_alpha(png);
png_read_update_info (png, info);
color_type = png_get_color_type (png, info);
switch (color_type)
{
case PNG_COLOR_TYPE_RGBA:
sizeof_type = 4;
fixup_array_fun = fixup_array_rgba;
data_type = SLang_get_int_type (32);
break;
case PNG_COLOR_TYPE_RGB:
sizeof_type = 4;
fixup_array_fun = fixup_array_rgb;
data_type = SLang_get_int_type (32);
break;
case PNG_COLOR_TYPE_GRAY_ALPHA:
sizeof_type = 2;
fixup_array_fun = fixup_array_ga;
data_type = SLang_get_int_type (16);
break;
case PNG_COLOR_TYPE_GRAY:
sizeof_type = 1;
fixup_array_fun = NULL;
data_type = SLANG_UCHAR_TYPE;
break;
default:
SLang_verror (SL_Read_Error, "Unsupported PNG color-type");
free_png_type (p);
return NULL;
}
*color_typep = color_type;
/* Use the high-level interface */
rowbytes = png_get_rowbytes (png, info);
if (rowbytes > width * sizeof_type)
{
SLang_verror (SL_INTERNAL_ERROR, "Unexpected value returned from png_get_rowbytes");
free_png_type (p);
return NULL;
}
if (NULL == (data = (png_byte *) SLmalloc (height * width * sizeof_type)))
{
free_png_type (p);
return NULL;
}
if (NULL == (image_pointers = allocate_image_pointers (height, data, width * sizeof_type, flip)))
{
SLfree ((char *) data);
free_png_type (p);
return NULL;
}
png_read_image(png, image_pointers);
dims[0] = height;
dims[1] = width;
if (NULL == (at = SLang_create_array (data_type, 0, (VOID_STAR) data, dims, 2)))
{
SLfree ((char *) data);
free_image_pointers (image_pointers);
free_png_type (p);
return NULL;
}
free_png_type (p);
free_image_pointers (image_pointers);
if (fixup_array_fun != NULL)
(*fixup_array_fun) (at);
return at;
}
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);
}
static void make_1d_histogram (int *reverse) /*{{{*/
{
SLang_Array_Type *v, *lo, *hi, *b, *rev;
double *xlo, *xhi, *bv;
unsigned int *num;
SLindex_Type i, n, nbins;
SLindex_Type *r = NULL;
v = lo = hi = b = rev = NULL;
if ((-1 == pop_two_darrays (&lo, &hi))
|| -1 == SLang_pop_array_of_type (&v, SLANG_DOUBLE_TYPE)
|| (v == NULL))
goto push_result;
if (lo->num_elements != hi->num_elements)
{
isis_vmesg (INTR, I_ERROR, __FILE__, __LINE__, "inconsistent array sizes");
goto push_result;
}
n = v->num_elements;
nbins = lo->num_elements;
if (n < 1 || nbins < 1)
goto push_result;
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;
}
if (NULL == (b = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &nbins, 1)))
{
isis_throw_exception (Isis_Error);
goto push_result;
}
num = (unsigned int *)b->data;
memset ((char *)num, 0, nbins * sizeof(unsigned int));
bv = (double *)v->data;
xlo = (double *)lo->data;
xhi = (double *)hi->data;
/* If the (lo,hi) grid has holes, this algorithm will
* give the wrong answer because every item will go
* into a bin. But what if the grid has holes by
* accident because it was poorly constructed?
* Perhaps that is a strong reason to deprecate this
* interface.
*/
for (i = 0; i < n; i++)
{
double t = bv[i];
int k = find_bin (t, xlo, xhi, (int) nbins);
if (k >= 0)
{
num[k] += 1;
if (r != NULL) r[i] = k;
}
}
if ((r != NULL)
&& (NULL == (rev = convert_reverse_indices (r, n, nbins))))
goto push_result;
push_result:
SLang_free_array (v);
SLang_free_array (hi);
SLang_free_array (lo);
ISIS_FREE(r);
SLang_push_array (b, 1);
SLang_push_array (rev, 1);
}
void _pSLunpack (char *format, SLang_BString_Type *bs)
{
Format_Type ft;
unsigned char *b;
unsigned int len;
unsigned int num_bytes;
check_native_byte_order ();
if (-1 == compute_size_for_format (format, &num_bytes))
return;
b = SLbstring_get_pointer (bs, &len);
if (b == NULL)
return;
if (len < num_bytes)
{
_pSLang_verror (SL_INVALID_PARM,
"unpack format %s is too large for input string",
format);
return;
}
while (1 == parse_a_format (&format, &ft))
{
char *str, *s;
if (ft.repeat == 0)
continue;
if (ft.data_type == 0)
{ /* skip padding */
b += ft.repeat;
continue;
}
if (ft.is_scalar)
{
SLang_Array_Type *at;
SLindex_Type dims;
if (ft.repeat == 1)
{
SLang_Class_Type *cl;
cl = _pSLclass_get_class (ft.data_type);
memcpy ((char *)cl->cl_transfer_buf, (char *)b, ft.sizeof_type);
if (ft.byteorder != NATIVE_ORDER)
byteswap (ft.byteorder, (unsigned char *)cl->cl_transfer_buf, ft.sizeof_type, 1);
if (-1 == (cl->cl_apush (ft.data_type, cl->cl_transfer_buf)))
return;
b += ft.sizeof_type;
continue;
}
dims = (SLindex_Type) ft.repeat;
at = SLang_create_array (ft.data_type, 0, NULL, &dims, 1);
if (at == NULL)
return;
num_bytes = ft.repeat * ft.sizeof_type;
memcpy ((char *)at->data, (char *)b, num_bytes);
if (ft.byteorder != NATIVE_ORDER)
byteswap (ft.byteorder, (unsigned char *)at->data, ft.sizeof_type, ft.repeat);
if (-1 == SLang_push_array (at, 1))
return;
b += num_bytes;
continue;
}
/* string type: s, S, or Z */
if (ft.format_type == 's')
len = ft.repeat;
else
len = get_unpadded_strlen ((char *)b, ft.pad, ft.repeat);
str = SLmalloc (len + 1);
if (str == NULL)
return;
memcpy ((char *) str, (char *)b, len);
str [len] = 0;
/* Avoid a bstring if possible */
s = SLmemchr (str, 0, len);
if (s == NULL)
{
if (-1 == SLang_push_malloced_string (str))
return;
}
else
{
SLang_BString_Type *new_bs;
new_bs = SLbstring_create_malloced ((unsigned char *)str, len, 1);
if (new_bs == NULL)
return;
if (-1 == SLang_push_bstring (new_bs))
{
SLfree (str);
return;
}
SLbstring_free (new_bs);
}
b += ft.repeat;
}
}
static int slfe_set_options (Isis_Fit_Engine_Type *e, Isis_Option_Type *opts) /*{{{*/
{
SLang_Array_Type *sl_opts;
SLindex_Type i, n;
if (opts == NULL)
return -1;
n = opts->num_options;
if (n == 0)
return 0;
if (NULL == (sl_opts = SLang_create_array (SLANG_STRING_TYPE, 1, NULL, &n, 1)))
return -1;
for (i = 0; i < n; i++)
{
int have_value = (opts->option_values[i] != 0);
char *s;
if (have_value)
{
s = isis_mkstrcat (opts->option_names[i], "=",
opts->option_values[i], NULL);
}
else s = opts->option_names[i];
if ((s == NULL)
|| (-1 == SLang_set_array_element (sl_opts, &i, &s)))
{
SLang_free_array (sl_opts);
if (have_value) ISIS_FREE(s);
}
if (have_value) ISIS_FREE(s);
}
SLang_start_arg_list();
(void) SLang_push_array (sl_opts, 1);
SLang_end_arg_list();
/* converts options array to a struct */
SLang_execute_function ("_isis->options_to_struct");
/* this function then pops the struct off the stack */
if (-1 == SLexecute_function (e->sl_set_options))
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"setting options for fit method '%s'",
e->engine_name);
return -1;
}
if (SLang_get_error ())
{
isis_vmesg (FAIL, I_FAILED, __FILE__, __LINE__,
"S-Lang error while setting options for fit method '%s'",
e->engine_name);
return -1;
}
return 0;
}
