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;
}
}
SLang_Name_Type *SLang_pop_function (void)
{
SLang_Ref_Type *ref;
SLang_Name_Type *f;
if (SLang_peek_at_stack () == SLANG_STRING_TYPE)
{
char *name;
if (-1 == SLang_pop_slstring (&name))
return NULL;
if (NULL == (f = SLang_get_function (name)))
{
_pSLang_verror (SL_UNDEFINED_NAME, "Function %s does not exist", name);
SLang_free_slstring (name);
return NULL;
}
SLang_free_slstring (name);
return f;
}
if (-1 == SLang_pop_ref (&ref))
return NULL;
f = SLang_get_fun_from_ref (ref);
SLang_free_ref (ref);
return f;
}
/* On stack: (rli, callback) */
static int pop_set_rline_cb_args (SLang_MMT_Type **mmtp,
Rline_CB_Type **cbp, SLang_Name_Type **ntp)
{
SLang_Name_Type *nt;
Slsh_Readline_Type *sri;
SLang_MMT_Type *mmt;
if (SLang_peek_at_stack () == SLANG_NULL_TYPE)
nt = NULL;
else if (NULL == (nt = SLang_pop_function ()))
return -1;
if (NULL == (mmt = pop_sri_type (&sri)))
{
if (nt != NULL)
SLang_free_function (nt);
return -1;
}
if (-1 == SLrline_get_update_client_data (sri->rli, (VOID_STAR *)cbp))
goto return_error;
if (*cbp == NULL)
{
SLang_verror (SL_Application_Error, "\
Attempt to define an rline update callback without first creating a readline_update_hook");
goto return_error;
}
static int posix_fileno_int (void)
{
int fd;
SLFile_FD_Type *f;
if (SLang_peek_at_stack () == SLANG_FILE_PTR_TYPE)
{
SLang_MMT_Type *mmt;
FILE *fp;
if (-1 == SLang_pop_fileptr (&mmt, &fp))
return -1;
fd = fileno (fp);
SLang_free_mmt (mmt);
return fd;
}
if (-1 == SLfile_pop_fd (&f))
return -1;
if (-1 == get_fd (f, &fd))
fd = -1;
SLfile_free_fd (f);
return fd;
}
static void rline_setkey_intrinsic (char *keyseq)
{
char *str;
SLkeymap_Type *kmap;
if (NULL == (kmap = get_keymap ()))
return;
if (SLang_peek_at_stack () == SLANG_REF_TYPE)
{
SLang_Name_Type *nt;
if (NULL == (nt = SLang_pop_function ()))
return;
(void) SLkm_define_slkey (keyseq, nt, kmap);
return;
}
if (-1 == SLang_pop_slstring (&str))
return;
(void) SLang_define_key (keyseq, str, kmap);
SLang_free_slstring (str);
}
int SLang_pop_complex (double *r, double *i)
{
double *c;
switch (SLang_peek_at_stack ())
{
case SLANG_COMPLEX_TYPE:
if (-1 == SLclass_pop_ptr_obj (SLANG_COMPLEX_TYPE, VOID_STAR_STAR(&c)))
return -1;
*r = c[0];
*i = c[1];
SLfree ((char *) c);
break;
default:
*i = 0.0;
if (-1 == SLang_pop_double (r))
return -1;
break;
case -1:
return -1;
}
return 0;
}
static void sl_ssl_client (void){
// create an ssl object and return the memory managed type back to
// SLang. It needs the file descriptor of the object upon which
// communication will occur, and the protocol to use.
//
SSL_CTX *ctx;
SSL *ssl;
int proto, cret;
SLang_MMT_Type *mmt, *sslmmt;
SLsslctx_Type *slctx;
char *cadir=NULL, *cafile=NULL;
if (SLang_Num_Function_Args == 3)
if (SLang_pop_slstring(&cadir) == -1)
return;
if (SLang_Num_Function_Args > 1)
if (SLANG_NULL_TYPE==SLang_peek_at_stack())
SLdo_pop();
else if (SLang_pop_slstring(&cafile) == -1)
goto free;
if (SLang_pop_integer(&proto) == -1)
goto free;
if (proto==SSL_PROTO_SSL2)
ctx = SSL_CTX_new(SSLv23_client_method());
else if (proto==SSL_PROTO_SSL3)
ctx = SSL_CTX_new(SSLv3_client_method());
else if (proto==SSL_PROTO_TLS1)
ctx = SSL_CTX_new(TLSv1_client_method());
else if (proto==SSL_PROTO_ANY)
ctx = SSL_CTX_new(SSLv23_client_method());
cret = SSL_CTX_load_verify_locations(ctx, cafile, cadir);
if (cret == 0 && SLang_Num_Function_Args > 1){
SLang_verror(SL_APPLICATION_ERROR, "Failed to load CA file or path");
goto free;
}
slctx = (SLsslctx_Type *)malloc(sizeof(SLsslctx_Type));
slctx->is_server = 0;
slctx->ctx = (void *)ctx;
sslmmt = SLang_create_mmt(SLsslctx_Type_Id, (VOID_STAR) slctx);
if (0!=SLang_push_mmt(sslmmt))
SLang_free_mmt(sslmmt);
free:
if (NULL!=cadir)
SLang_free_slstring(cadir);
if (NULL!=cafile)
SLang_free_slstring(cafile);
}
static void test_pop_mmt (void)
{
SLang_MMT_Type *mmt;
if (NULL == (mmt = SLang_pop_mmt (SLang_peek_at_stack ())))
return;
if (-1 == SLang_push_mmt (mmt))
SLang_free_mmt (mmt);
}
static int pop_fd (int *fdp)
{
SLFile_FD_Type *f;
int status;
if (SLang_peek_at_stack () == SLANG_INT_TYPE)
return SLang_pop_int (fdp);
if (-1 == SLfile_pop_fd (&f))
return -1;
status = SLfile_get_fd (f, fdp);
SLfile_free_fd (f);
return status;
}
int user_create_ray (double *delta_t, double *energy,
double *cosx, double *cosy, double *cosz)
{
if (Num_Rays == 0)
{
if (-1 == SLexecute_function (Create_Ray))
{
SLang_verror (0, "Encountered an error processing %s\n", "user_create_ray");
return -1;
}
if (SLang_peek_at_stack () == SLANG_NULL_TYPE)
return -1; /* done */
if ((-1 == pop_array (&CosZ_Array))
|| (-1 == pop_array (&CosY_Array))
|| (-1 == pop_array (&CosX_Array))
|| (-1 == pop_array (&Energy_Array))
|| (-1 == pop_array (&dT_Array)))
{
SLang_verror (0, "Encountered an error processing %s\n", "user_create_ray");
return -1;
}
if (Num_Rays == 0)
return -1;
if (CosX_Array.num_elements < Num_Rays)
CosX_Array.di = 0;
if (CosY_Array.num_elements < Num_Rays)
CosY_Array.di = 0;
if (CosZ_Array.num_elements < Num_Rays)
CosZ_Array.di = 0;
if (dT_Array.num_elements < Num_Rays)
dT_Array.di = 0;
if (Energy_Array.num_elements < Num_Rays)
Energy_Array.di = 0;
}
*cosx = next_element (&CosX_Array);
*cosy = next_element (&CosY_Array);
*cosz = next_element (&CosZ_Array);
*delta_t = next_element (&dT_Array);
*energy = next_element (&Energy_Array);
Num_Rays--;
return 0;
}
static void set_prompt_hook (void)
{
SLang_Name_Type *h;
if (SLang_peek_at_stack () == SLANG_NULL_TYPE)
{
SLang_pop_null ();
h = NULL;
}
else if (NULL == (h = SLang_pop_function ()))
return;
if (Prompt_Hook != NULL)
SLang_free_function (Prompt_Hook);
Prompt_Hook = h;
}
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 Isis_Fit_Engine_Type *add_slang_fit_engine (char *eng_name, char *stat_name) /*{{{*/
{
Isis_Fit_Engine_Type *e;
if (NULL == (e = (Isis_Fit_Engine_Type *) ISIS_MALLOC (sizeof(Isis_Fit_Engine_Type))))
return NULL;
memset ((char *)e, 0, sizeof (*e));
if ((NULL == (e->engine_name = isis_make_string (eng_name)))
|| (NULL == (e->default_statistic_name = isis_make_string (stat_name))))
{
slfe_deallocate (e);
ISIS_FREE (e);
return NULL;
}
e->method = &slfe_optimize;
e->deallocate = &slfe_deallocate;
e->set_options = &slfe_set_options;
e->set_range_hook = NULL;
e->range_hook = NULL;
e->verbose_hook = NULL;
e->warn_hook = NULL;
if (NULL == (e->sl_optimize = SLang_pop_function ()))
{
slfe_deallocate (e);
return NULL;
}
if (SLANG_NULL_TYPE == SLang_peek_at_stack())
SLdo_pop();
else if (NULL == (e->sl_set_options = SLang_pop_function ()))
{
slfe_deallocate (e);
return NULL;
}
if (NULL == (e->option_string = isis_make_string (eng_name)))
{
slfe_deallocate (e);
return NULL;
}
return e;
}
static int is_callable_intrinsic (void)
{
SLang_Ref_Type *ref;
int ret;
if (SLang_peek_at_stack () != SLANG_REF_TYPE)
{
(void) SLdo_pop ();
return 0;
}
if (-1 == SLang_pop_ref (&ref))
return -1;
ret = _pSLang_ref_is_callable (ref);
SLang_free_ref (ref);
return ret;
}
static int pop_list_and_index (unsigned int num_indices,
SLang_List_Type **listp,
SLang_Array_Type **ind_atp,
SLindex_Type *indx)
{
SLang_List_Type *list;
*listp = NULL;
if (-1 == pop_list (&list))
return -1;
if (num_indices != 1)
{
_pSLang_verror (SL_InvalidParm_Error, "List_Type objects are limited to a single index");
free_list (list);
return -1;
}
*ind_atp = NULL;
if (SLang_peek_at_stack () == SLANG_ARRAY_INDEX_TYPE)
{
if (-1 == SLang_pop_array_index (indx))
{
free_list (list);
return -1;
}
}
else
{
if (-1 == _pSLarray_pop_index (list->length, ind_atp, indx))
{
free_list (list);
return -1;
}
}
*listp = list;
return 0;
}
static int pop_fd (int *fdp, SLFile_FD_Type **fp, SLang_MMT_Type **mmtp)
{
int fd;
*fp = NULL; *mmtp = NULL;
switch (SLang_peek_at_stack ())
{
case SLANG_FILE_PTR_TYPE:
{
SLang_MMT_Type *mmt;
FILE *p;
if (-1 == SLang_pop_fileptr (&mmt, &p))
return -1;
fd = fileno (p);
*mmtp = mmt;
}
break;
case SLANG_FILE_FD_TYPE:
{
SLFile_FD_Type *f;
if (-1 == SLfile_pop_fd (&f))
return -1;
if (-1 == get_fd (f, &fd))
{
SLfile_free_fd (f);
return -1;
}
}
break;
default:
if (-1 == SLang_pop_int (&fd))
return -1;
}
*fdp = fd;
return 0;
}
static int pop_fd_set (SLang_Array_Type **ats,
fd_set **fd_set_p, fd_set *fd_set_buf,
int *max_n)
{
unsigned int num, i;
SLang_Array_Type *at;
SLFile_FD_Type **f;
*ats = NULL;
*fd_set_p = NULL;
if (SLang_peek_at_stack () == SLANG_NULL_TYPE)
return SLang_pop_null ();
if (-1 == SLang_pop_array_of_type (&at, SLANG_FILE_FD_TYPE))
return -1;
FD_ZERO(fd_set_buf);
*fd_set_p = fd_set_buf;
*ats = at;
num = at->num_elements;
f = (SLFile_FD_Type **) at->data;
for (i = 0; i < num; i++)
{
int fd;
if (-1 == SLfile_get_fd (f[i], &fd))
continue;
if (fd > *max_n)
*max_n = fd;
FD_SET(fd, fd_set_buf);
}
return 0;
}
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 execute_read_callback (CSV_Type *csv, char **sptr)
{
char *s;
*sptr = NULL;
if ((-1 == SLang_start_arg_list ())
|| (-1 == SLang_push_anytype (csv->callback_data))
|| (-1 == SLang_end_arg_list ())
|| (-1 == SLexecute_function (csv->read_callback)))
return -1;
if (SLang_peek_at_stack () == SLANG_NULL_TYPE)
{
(void) SLang_pop_null ();
return 0;
}
if (-1 == SLang_pop_slstring (&s))
return -1;
*sptr = s;
return 1;
}
static int pop_new_push_old (SLang_Name_Type **handler)
{
SLang_Name_Type *new_handler;
SLang_Name_Type *old_handler;
old_handler = *handler;
if (SLang_peek_at_stack () == SLANG_NULL_TYPE)
{
SLang_pop_null ();
new_handler = NULL;
}
else if (NULL == (new_handler = SLang_pop_function ()))
return -1;
if (-1 == _pSLang_push_nt_as_ref (old_handler))
{
SLang_free_function (new_handler);
return -1;
}
SLang_free_function (old_handler);
*handler = new_handler;
return 0;
}
static void setitimer_intrinsic (void)
{
SLang_Ref_Type *interval_ref = NULL, *value_ref = NULL;
int w;
struct itimerval new_value, old_value;
double interval = 0.0, value;
int argc = SLang_Num_Function_Args;
if (SLang_peek_at_stack () == SLANG_REF_TYPE)
{
if (-1 == SLang_pop_ref (&value_ref))
return;
argc--;
if (SLang_peek_at_stack() == SLANG_REF_TYPE)
{
interval_ref = value_ref;
if (-1 == SLang_pop_ref (&value_ref))
goto free_and_return;
argc--;
}
}
switch (argc)
{
case 3:
if (-1 == SLang_pop_double (&interval))
goto free_and_return;
/* drop */
case 2:
default:
if ((-1 == SLang_pop_double (&value))
|| (-1 == SLang_pop_int (&w)))
goto free_and_return;
}
double_to_timeval (interval, &new_value.it_interval);
double_to_timeval (value, &new_value.it_value);
if (-1 == setitimer (w, &new_value, &old_value))
{
SLerrno_set_errno (errno);
SLang_verror (SL_OS_Error, "setitimer failed: %s", SLerrno_strerror (errno));
goto free_and_return;
}
if (value_ref != NULL)
{
value = timeval_to_double (&old_value.it_value);
if (-1 == SLang_assign_to_ref (value_ref, SLANG_DOUBLE_TYPE, &value))
goto free_and_return;
}
if (interval_ref != NULL)
{
interval = timeval_to_double (&old_value.it_interval);
if (-1 == SLang_assign_to_ref (interval_ref, SLANG_DOUBLE_TYPE, &interval))
goto free_and_return;
}
free_and_return:
if (value_ref != NULL)
SLang_free_ref (value_ref);
if (interval_ref != NULL)
SLang_free_ref (interval_ref);
}
static void signal_intrinsic (void)
{
SLang_Name_Type *f;
Signal_Type *s;
void (*old_handler) (int);
SLang_Ref_Type *old_ref;
if (SLang_Num_Function_Args == 3)
{
if (-1 == SLang_pop_ref (&old_ref))
return;
}
else old_ref = NULL;
if (SLang_Num_Function_Args == 0)
{
SLang_verror (SL_Internal_Error, "signal called with 0 args");
return;
}
if (SLANG_INT_TYPE == SLang_peek_at_stack ())
{
int h;
if ((-1 == SLang_pop_int (&h))
|| (-1 == pop_signal (&s)))
{
SLang_free_ref (old_ref);
return;
}
/* If this signal has already been caught, deliver it now to the old handler */
if (s->pending)
handle_signal (s);
/* Note that the signal has the potential of being lost if the user has
* blocked its delivery. For this reason, the unblock_signal intrinsic
* will have to deliver the signal via an explicit kill if it is pending.
*/
if (h == SIG_IGN_CONSTANT)
old_handler = SLsignal_intr (s->sig, SIG_IGN);
else if (h == SIG_DFL_CONSTANT)
old_handler = SLsignal_intr (s->sig, SIG_DFL);
else if (h == SIG_APP_CONSTANT)
old_handler = SLsignal_intr (s->sig, s->c_handler);
else
{
SLang_free_ref (old_ref);
_pSLang_verror (SL_INVALID_PARM, "Signal handler '%d' is invalid", h);
return;
}
if (-1 == set_old_handler (s, old_ref, old_handler))
{
SLang_free_ref (old_ref);
return;
}
if (s->handler != NULL)
{
SLang_free_function (s->handler);
s->handler = NULL;
}
SLang_free_ref (old_ref);
return;
}
if (NULL == (f = SLang_pop_function ()))
{
SLang_free_ref (old_ref);
return;
}
if (-1 == pop_signal (&s))
{
SLang_free_ref (old_ref);
SLang_free_function (f);
return;
}
old_handler = SLsignal_intr (s->sig, signal_handler);
if (-1 == set_old_handler (s, old_ref, old_handler))
{
SLang_free_ref (old_ref);
SLang_free_function (f);
return;
}
if (s->handler != NULL)
SLang_free_function (s->handler);
s->handler = f;
SLang_free_ref (old_ref);
}
/* Usage: onig_search (o, str [start, end] [,option]) */
static int do_onig_search (void)
{
int start_pos = 0, end_pos = -1;
char *str, *str_end;
SLang_BString_Type *bstr = NULL;
Onig_Type *o;
SLang_MMT_Type *mmt;
int status = -1;
OnigOptionType option = ONIG_OPTION_NONE;
switch (SLang_Num_Function_Args)
{
default:
SLang_verror (SL_Usage_Error, "Usage: n = onig_search (compiled_pattern, str [,start_ofs, end_ofs] [,option])");
return -1;
case 5:
if (-1 == pop_onig_option (&option))
return -1;
/* drop */
case 4:
if (-1 == SLang_pop_int (&end_pos))
return -1;
if (-1 == SLang_pop_int (&start_pos))
return -1;
break;
case 3:
if (-1 == pop_onig_option (&option))
return -1;
break;
case 2:
break;
}
switch(SLang_peek_at_stack())
{
case SLANG_STRING_TYPE:
if (-1 == SLang_pop_slstring (&str))
return -1;
str_end = str + strlen (str);
break;
case SLANG_BSTRING_TYPE:
default:
{
unsigned int len;
if (-1 == SLang_pop_bstring(&bstr))
return -1;
str = (char *)SLbstring_get_pointer(bstr, &len);
if (str == NULL)
{
SLbstring_free (bstr);
return -1;
}
str_end = str + len;
}
break;
}
if (end_pos < 0)
end_pos = (int) (str_end - str);
if (NULL == (mmt = SLang_pop_mmt (Onig_Type_Id)))
goto free_and_return;
o = (Onig_Type *)SLang_object_from_mmt (mmt);
status = do_onig_search_internal (o, option, (UChar *)str, (UChar *)str_end, start_pos, end_pos);
if (status >= 0)
{
o->match_pos = status;
status = o->region->num_regs;
goto free_and_return;
}
o->match_pos = -1;
if (status == -1)
{ /* no match */
status = 0;
goto free_and_return;
}
/* Else an error occurred */
/* drop */
free_and_return:
SLang_free_mmt (mmt);
if (bstr != NULL)
SLbstring_free (bstr);
else
SLang_free_slstring (str);
return status;
}
/* Usage: array_reverse (a, [,from, to] [,dim]) */
static void array_reverse (void)
{
int len;
unsigned char *src, *dst;
size_t sizeof_type;
int dim = 0;
/* int has_dim = 0; */
int from = 0;
int to = -1;
int nargs;
SLang_Array_Type *at;
nargs = SLang_Num_Function_Args;
if ((nargs == 2) || (nargs == 4))
{
/* FIXME!!! */
/* has_dim = 1; */
if (-1 == SLang_pop_integer (&dim))
return;
_pSLang_verror (SL_NotImplemented_Error, "dim argument not yet implemented");
return;
}
if (nargs >= 3)
{
if ((-1 == SLang_pop_integer (&to))
|| (-1 == SLang_pop_integer (&from)))
return;
}
if ((from == to)
|| (SLang_peek_at_stack () != SLANG_ARRAY_TYPE))
{
(void) SLdo_pop (); /* do nothing */
return;
}
if (-1 == pop_writable_array (&at))
return;
len = (int) at->num_elements;
if (len == 0)
{ /* nothing to reverse */
SLang_free_array (at);
return;
}
if (-1 == check_range_indices (len, &from, &to))
{
SLang_free_array (at);
return;
}
sizeof_type = at->cl->cl_sizeof_type;
src = (unsigned char *)at->data + from*sizeof_type;
dst = (unsigned char *)at->data + to*sizeof_type;
while (src < dst)
{
unsigned int k;
for (k = 0; k < sizeof_type; k++)
{
unsigned char tmp = src[k];
src[k] = dst[k];
dst[k] = tmp;
}
src += sizeof_type;
dst -= sizeof_type;
}
SLang_free_array (at);
}
