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 int _pgband (int *mode, int *posn, double *xref, double *yref,
SLang_Ref_Type *rx, SLang_Ref_Type *ry, SLang_Ref_Type *rc)
{
float x, y;
char c;
int status;
status = cpgband (*mode, *posn, *xref, *yref, &x, &y, &c);
if (status == 1)
{
(void) SLang_assign_to_ref (rx, SLANG_FLOAT_TYPE, &x);
(void) SLang_assign_to_ref (ry, SLANG_FLOAT_TYPE, &y);
(void) SLang_assign_to_ref (rc, SLANG_CHAR_TYPE, &c);
}
return status;
}
/* Usage: s1 = accept (s [,&host,&port]); */
static Socket_Type *accept_af_inet (Socket_Type *s, unsigned int nrefs, SLang_Ref_Type **refs)
{
struct sockaddr_in s_in;
Socket_Type *s1;
unsigned int addr_len;
if ((nrefs != 0) && (nrefs != 2))
{
SLang_verror (SL_NumArgs_Error, "accept (sock [,&host,&port])");
return NULL;
}
addr_len = sizeof (struct sockaddr_in);
s1 = perform_accept (s, (struct sockaddr *)&s_in, &addr_len);
if ((s1 == NULL) || (nrefs == 0))
return s1;
if (nrefs == 2)
{
char *host;
char host_ip[32]; /* aaa.bbb.ccc.ddd */
unsigned char *bytes = (unsigned char *)&s_in.sin_addr;
int port = ntohs (s_in.sin_port);
sprintf (host_ip, "%d.%d.%d.%d",
(int)bytes[0],(int)bytes[1],(int)bytes[2],(int)bytes[3]);
if (NULL == (host = SLang_create_slstring (host_ip)))
{
free_socket (s1);
return NULL;
}
if (-1 == SLang_assign_to_ref (refs[0], SLANG_STRING_TYPE, (VOID_STAR)&host))
{
SLang_free_slstring (host);
free_socket (s1);
return NULL;
}
SLang_free_slstring (host);
if (-1 == SLang_assign_to_ref (refs[1], SLANG_INT_TYPE, &port))
{
free_socket (s1);
return NULL;
}
}
return s1;
}
/* 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);
}
/* Usage: nn = read (f, &buf, n); */
static void posix_read (SLFile_FD_Type *f, SLang_Ref_Type *ref, unsigned int *nbytes)
{
unsigned int len;
char *b;
SLang_BString_Type *bstr;
b = NULL;
len = *nbytes;
if ((NULL == (b = SLmalloc (len + 1)))
|| (-1 == do_read (f, b, &len)))
goto return_error;
if (len != *nbytes)
{
char *b1 = SLrealloc (b, len + 1);
if (b1 == NULL)
goto return_error;
b = b1;
}
bstr = SLbstring_create_malloced ((unsigned char *) b, len, 0);
if (bstr != NULL)
{
if (-1 == SLang_assign_to_ref (ref, SLANG_BSTRING_TYPE, (VOID_STAR)&bstr))
{
SLbstring_free (bstr);
return;
}
SLbstring_free (bstr);
(void) SLang_push_uinteger (len);
return;
}
return_error:
if (b != NULL) SLfree ((char *)b);
(void) SLang_assign_to_ref (ref, SLANG_NULL_TYPE, NULL);
(void) SLang_push_integer (-1);
}
static int assign_mask_to_ref (sigset_t *mask, SLang_Ref_Type *ref)
{
SLang_Array_Type *at = mask_to_array (mask);
if (at == NULL)
return -1;
if (-1 == SLang_assign_to_ref (ref, SLANG_ARRAY_TYPE, (VOID_STAR)&at))
{
SLang_free_array (at);
return -1;
}
SLang_free_array (at);
return 0;
}
static int set_old_handler (Signal_Type *s, SLang_Ref_Type *ref, void (*old_handler)(int))
{
if (old_handler == (void (*)(int))SIG_ERR)
{
_pSLang_verror (0, "signal system call failed");
return -1;
}
if (ref != NULL)
{
int ret;
if (old_handler == signal_handler)
ret = SLang_assign_nametype_to_ref (ref, s->handler);
else
{
int h;
if (old_handler == SIG_IGN)
h = SIG_IGN_CONSTANT;
else if (old_handler == SIG_DFL)
h = SIG_DFL_CONSTANT;
else
h = SIG_APP_CONSTANT;
ret = SLang_assign_to_ref (ref, SLANG_INT_TYPE, &h);
}
if (ret == -1)
{
(void) SLsignal_intr (s->sig, old_handler);
return -1;
}
}
if (old_handler != signal_handler)
s->c_handler = old_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);
}