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);
}
/* 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 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 pop_hooks_info (char **s, SLang_Name_Type **nt)
{
if (NULL == (*nt = SLang_pop_function ()))
return -1;
if (-1 == SLang_pop_slstring (s))
return -1;
return 0;
}
static void set_verb_warn_func (void)
{
SLang_Name_Type *sf;
if (NULL == (sf = SLang_pop_function ()))
return;
if (Verb_Warn_Func != NULL)
SLang_free_function (Verb_Warn_Func);
Verb_Warn_Func = sf;
}
static Isis_Fit_Statistic_Type *init_sl_statistic (void) /*{{{*/
{
SLang_Name_Type *statistic_fun, *report_fun;
Isis_Fit_Statistic_Type *s;
if (NULL == (s = (Isis_Fit_Statistic_Type *) ISIS_MALLOC (sizeof(Isis_Fit_Statistic_Type))))
return NULL;
memset ((char *)s, 0, sizeof (*s));
if (NULL == (report_fun = SLang_pop_function ()))
{
ISIS_FREE (s);
return NULL;
}
if (NULL == (statistic_fun = SLang_pop_function ()))
{
ISIS_FREE (s);
SLang_free_function (report_fun);
return NULL;
}
if (NULL == (s->symbol = isis_make_string (statistic_fun->name)))
{
ISIS_FREE(s);
SLang_free_function (report_fun);
SLang_free_function (statistic_fun);
return NULL;
}
s->compute_statistic = sl_statistic_function;
s->deallocate = sl_deallocate_function;
s->report = sl_report_function;
s->sl_fun = statistic_fun;
s->sl_report = report_fun;
return s;
}
static void rline_set_list_completions_callback (void)
{
SLang_Name_Type *nt;
if (NULL == (nt = SLang_pop_function ()))
return;
if (Active_Rline_Info == NULL)
{
SLang_free_function (Default_List_Completions_Callback);
Default_List_Completions_Callback = nt;
return;
}
SLang_free_function (Active_Rline_Info->list_completions_callback);
Active_Rline_Info->list_completions_callback = nt;
}
static void set_rline_update_hook (void)
{
Rline_CB_Type *cb;
SLrline_Type *rli;
if (NULL == (cb = (Rline_CB_Type *)SLmalloc(sizeof(Rline_CB_Type))))
return;
memset ((char *)cb, 0, sizeof(Rline_CB_Type));
switch (SLang_Num_Function_Args)
{
default:
SLang_verror (SL_Usage_Error, "Usage: rline_set_update_hook (rli [,&hook [,clientdata]]);");
return;
case 3:
if (-1 == SLang_pop_anytype (&cb->cd))
return;
/* drop */
case 2:
if (NULL == (cb->update_hook = SLang_pop_function ()))
goto free_and_return;
/* drop */
case 1:
if (NULL == (cb->mmt = pop_sri_type (&cb->sri)))
goto free_and_return;
}
cb->sri->output_newline = 0;
rli = cb->sri->rli;
SLrline_set_update_clear_cb (rli, rline_update_clear_cb);
SLrline_set_update_preread_cb (rli, rline_update_preread_cb);
SLrline_set_update_postread_cb (rli, rline_update_postread_cb);
SLrline_set_update_width_cb (rli, rline_update_width_cb);
if (0 == SLrline_set_update_hook (rli, rline_call_update_hook, (VOID_STAR)cb))
{
SLrline_set_free_update_cb (rli, free_rli_update_data_cb);
return;
}
/* drop */
free_and_return:
free_cb_info (cb);
}
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;
}
/* Usage: obj = cvs_decoder_new (&read_callback, callback_data, delim, quote, flags) */
static void new_csv_decoder_intrin (void)
{
CSV_Type *csv;
SLang_MMT_Type *mmt;
if (NULL == (csv = (CSV_Type *)SLmalloc(sizeof(CSV_Type))))
return;
memset ((char *)csv, 0, sizeof(CSV_Type));
if ((-1 == SLang_pop_int (&csv->flags))
||(-1 == SLang_pop_char (&csv->quotechar))
|| (-1 == SLang_pop_char (&csv->delimchar))
|| (-1 == SLang_pop_anytype (&csv->callback_data))
|| (NULL == (csv->read_callback = SLang_pop_function ()))
|| (NULL == (mmt = SLang_create_mmt (CSV_Type_Id, (VOID_STAR)csv))))
{
free_csv_type (csv);
return;
}
if (-1 == SLang_push_mmt (mmt))
SLang_free_mmt (mmt);
}
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 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);
}
