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;
}
static void alarm_intrinsic (void)
{
#ifndef HAVE_ALARM
SLang_set_error (SL_NotImplemented_Error);
#else
SLang_Ref_Type *ref = NULL;
unsigned int secs;
Signal_Type *s;
if (SLang_Num_Function_Args == 2)
{
if (-1 == SLang_pop_ref (&ref))
return;
}
if (-1 == SLang_pop_uint (&secs))
{
SLang_free_ref (ref); /* NULL ok */
return;
}
#ifdef SIGALRM
if ((NULL != (s = find_signal (SIGALRM)))
&& s->forbidden)
{
SLang_set_error (SL_Forbidden_Error);
return;
}
#endif
secs = alarm (secs);
if (ref != NULL)
(void) SLang_assign_to_ref (ref, SLANG_UINT_TYPE, &secs);
#endif
}
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 sl_ssl_read(void){
SLssl_Type *ssl;
SLang_MMT_Type *sslmmt;
SLang_Ref_Type *buff;
void *ibuff;
SLang_BString_Type *data;
int r, rlen;
if (SLang_pop_integer(&rlen)==-1 ||
SLang_pop_ref(&buff)==-1 ||
NULL==(sslmmt=SLang_pop_mmt(SLssl_Type_Id)))
return;
ssl=(SLssl_Type *)SLang_object_from_mmt(sslmmt);
ibuff=(void *)malloc(rlen);
r=SSL_read((SSL *)ssl->ssl,ibuff,rlen);
data=SLbstring_create((unsigned char *)ibuff,r);
SLang_assign_to_ref(buff, SLANG_BSTRING_TYPE, (VOID_STAR)&data);
if (r>=0)
SLang_push_integer(r);
else
SLang_verror(r,"SSL read returned error code %d",
SSL_get_error((SSL *)ssl->ssl,r));
SLang_free_ref(buff);
}
static void sigprocmask_intrinsic (void)
{
sigset_t mask, oldmask;
SLang_Ref_Type *ref = NULL;
int how;
if (SLang_Num_Function_Args == 3)
{
if (-1 == SLang_pop_ref (&ref))
return;
}
if (-1 == pop_signal_mask (&mask))
{
SLang_free_ref (ref);
return;
}
if (-1 == SLang_pop_int (&how))
{
SLang_free_ref (ref);
return;
}
if ((how != SIG_BLOCK) && (how != SIG_UNBLOCK) && (how != SIG_SETMASK))
{
_pSLang_verror (SL_InvalidParm_Error, "sigprocmask: invalid operation");
SLang_free_ref (ref);
return;
}
do_sigprocmask (how, &mask, &oldmask);
if (ref == NULL)
return;
if (-1 == assign_mask_to_ref (&oldmask, ref))
do_sigprocmask (SIG_SETMASK, &oldmask, NULL);
SLang_free_ref (ref);
}
static void accept_intrin (void)
{
SLFile_FD_Type *f;
Socket_Type *s, *s1;
Domain_Methods_Type *methods;
int nargs = SLang_Num_Function_Args;
SLang_Ref_Type *refs[MAX_ACCEPT_REF_ARGS];
int i;
if (nargs <= 0)
{
SLang_verror (SL_Usage_Error, "s1 = accept (s [,&v...])");
return;
}
if (-1 == SLroll_stack (-nargs))
return;
if (NULL == (s = pop_socket (&f)))
return;
nargs--;
if (nargs > MAX_ACCEPT_REF_ARGS)
{
SLang_verror (SL_NumArgs_Error, "accept: too many reference args");
SLfile_free_fd (f);
}
memset ((char *)refs, 0, sizeof (refs));
i = nargs;
while (i != 0)
{
i--;
if (-1 == SLang_pop_ref (refs+i))
goto free_return;
}
methods = s->methods;
if (NULL != (s1 = (*methods->accept)(s, nargs, refs)))
(void) push_socket (s1); /* frees it upon error */
/* drop */
free_return:
for (i = 0; i < nargs; i++)
{
if (refs[i] != NULL)
SLang_free_ref (refs[i]);
}
SLfile_free_fd (f);
}
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 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);
}
/* FIXME: This function does not handle LONG_LONG */
int _pSLang_sscanf (void)
{
int num;
unsigned int num_refs;
char *format;
char *input_string, *input_string_max;
SLFUTURE_CONST char *f, *s;
unsigned char map8[256], map10[256], map16[256];
if (SLang_Num_Function_Args < 2)
{
_pSLang_verror (SL_INVALID_PARM, "Int_Type sscanf (str, format, ...)");
return -1;
}
num_refs = (unsigned int) SLang_Num_Function_Args;
if (-1 == SLreverse_stack (num_refs))
return -1;
num_refs -= 2;
if (-1 == SLang_pop_slstring (&input_string))
return -1;
if (-1 == SLang_pop_slstring (&format))
{
SLang_free_slstring (input_string);
return -1;
}
f = format;
s = input_string;
input_string_max = input_string + strlen (input_string);
init_map (map8, 8);
init_map (map10, 10);
init_map (map16, 16);
num = 0;
while (num_refs != 0)
{
SLang_Object_Type obj;
SLang_Ref_Type *ref;
SLFUTURE_CONST char *smax;
unsigned char *map;
int base;
int no_assign;
int is_short;
int is_long;
int status;
char chf;
unsigned int width;
int has_width;
chf = *f++;
if (chf == 0)
{
/* Hmmm.... what is the most useful thing to do?? */
#if 1
break;
#else
_pSLang_verror (SL_INVALID_PARM, "sscanf: format not big enough for output list");
goto return_error;
#endif
}
if (isspace (chf))
{
char *s1 = _pSLskip_whitespace (s);
if (s1 == s)
break;
s = s1;
continue;
}
if ((chf != '%')
|| ((chf = *f++) == '%'))
{
if (*s != chf)
break;
s++;
continue;
}
no_assign = 0;
is_short = 0;
is_long = 0;
width = 0;
smax = input_string_max;
/* Look for the flag character */
if (chf == '*')
{
no_assign = 1;
chf = *f++;
}
/* Width */
has_width = isdigit (chf);
if (has_width)
{
f--;
(void) parse_uint (&f, f + strlen(f), &width, 10, map10);
chf = *f++;
}
/* Now the type modifier */
switch (chf)
{
case 'h':
is_short = 1;
chf = *f++;
break;
case 'L': /* not implemented */
case 'l':
is_long = 1;
chf = *f++;
break;
}
status = -1;
if ((chf != 'c') && (chf != '['))
{
s = _pSLskip_whitespace (s);
if (*s == 0)
break;
}
if (has_width)
{
if (width > (unsigned int) (input_string_max - s))
width = (unsigned int) (input_string_max - s);
smax = s + width;
}
/* Now the format descriptor */
map = map10;
base = 10;
try_again: /* used by i, x, and o, conversions */
switch (chf)
{
case 0:
_pSLang_verror (SL_INVALID_PARM, "sscanf: Unexpected end of format");
goto return_error;
case 'D':
is_long = 1;
case 'd':
if (is_short)
{
obj.o_data_type = SLANG_SHORT_TYPE;
status = parse_short (&s, smax, &obj.v.short_val, base, map);
}
else if (is_long)
{
obj.o_data_type = SLANG_LONG_TYPE;
status = parse_long (&s, smax, &obj.v.long_val, base, map);
}
else
{
obj.o_data_type = SLANG_INT_TYPE;
status = parse_int (&s, smax, &obj.v.int_val, base, map);
}
break;
case 'U':
is_long = 1;
case 'u':
if (is_short)
{
obj.o_data_type = SLANG_USHORT_TYPE;
status = parse_ushort (&s, smax, &obj.v.ushort_val, base, map);
}
else if (is_long)
{
obj.o_data_type = SLANG_ULONG_TYPE;
status = parse_ulong (&s, smax, &obj.v.ulong_val, base, map);
}
else
{
obj.o_data_type = SLANG_INT_TYPE;
status = parse_uint (&s, smax, &obj.v.uint_val, base, map);
}
break;
case 'I':
is_long = 1;
case 'i':
if ((s + 1 >= smax)
|| (*s != 0))
chf = 'd';
else if (((s[1] == 'x') || (s[1] == 'X'))
&& (s + 2 < smax))
{
s += 2;
chf = 'x';
}
else chf = 'o';
goto try_again;
case 'O':
is_long = 1;
case 'o':
map = map8;
base = 8;
chf = 'd';
goto try_again;
case 'X':
is_long = 1;
case 'x':
base = 16;
map = map16;
chf = 'd';
goto try_again;
case 'E':
case 'F':
is_long = 1;
case 'e':
case 'f':
case 'g':
#if SLANG_HAS_FLOAT
if (is_long)
{
obj.o_data_type = SLANG_DOUBLE_TYPE;
status = parse_double (&s, smax, &obj.v.double_val);
}
else
{
obj.o_data_type = SLANG_FLOAT_TYPE;
status = parse_float (&s, smax, &obj.v.float_val);
}
#else
_pSLang_verror (SL_NOT_IMPLEMENTED,
"This version of the S-Lang does not support floating point");
status = -1;
#endif
break;
case 's':
obj.o_data_type = SLANG_STRING_TYPE;
status = parse_string (&s, smax, &obj.v.s_val);
break;
case 'c':
if (has_width == 0)
{
obj.o_data_type = SLANG_UCHAR_TYPE;
obj.v.uchar_val = *s++;
status = 1;
break;
}
obj.o_data_type = SLANG_STRING_TYPE;
status = parse_bstring (&s, smax, &obj.v.s_val);
break;
case '[':
obj.o_data_type = SLANG_STRING_TYPE;
status = parse_range (&s, smax, &f, &obj.v.s_val);
break;
case 'n':
obj.o_data_type = SLANG_UINT_TYPE;
obj.v.uint_val = (unsigned int) (s - input_string);
status = 1;
break;
default:
status = -1;
_pSLang_verror (SL_NOT_IMPLEMENTED, "format specifier '%c' is not supported", chf);
break;
}
if (status == 0)
break;
if (status == -1)
goto return_error;
if (no_assign)
{
SLang_free_object (&obj);
continue;
}
if (-1 == SLang_pop_ref (&ref))
{
SLang_free_object (&obj);
goto return_error;
}
if (-1 == SLang_push (&obj))
{
SLang_free_object (&obj);
SLang_free_ref (ref);
goto return_error;
}
if (-1 == _pSLang_deref_assign (ref))
{
SLang_free_ref (ref);
goto return_error;
}
SLang_free_ref (ref);
num++;
num_refs--;
}
if (-1 == SLdo_pop_n (num_refs))
goto return_error;
SLang_free_slstring (format);
SLang_free_slstring (input_string);
return num;
return_error:
/* NULLS ok */
SLang_free_slstring (format);
SLang_free_slstring (input_string);
return -1;
}
static void ref_destroy (SLtype type, VOID_STAR ptr)
{
(void) type;
SLang_free_ref (*(SLang_Ref_Type **)ptr);
}