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); }