static pobject mod(pobject env, pobject params)
{
pobject o1 = eval(env, cons_nth(params, 1));
pobject o2 = eval(env, cons_nth(params, 2));
return (is_number(o1) && is_number(o2))
? gc_add((number_new( (int)number_value(o1) % (int)number_value(o2) )))
: NIL;
}
static pobject gt(pobject env, pobject params)
{
pobject o1 = eval(env, cons_car(params));
pobject o2 = eval(env, cons_car(cons_cdr(params)));
return object_bool(is_number(o1)
&& is_number(o2)
&& number_value(o1) > number_value(o2));
}
static int
sock_handle_read (int argc, RESULT_NODE **argv, void *item, RESULT_NODE *result, THREAD *gsl_thread)
{
RESULT_NODE *buffer = argc > 0 ? argv [0] : NULL;
RESULT_NODE *minimum = argc > 1 ? argv [1] : NULL;
RESULT_NODE *timeout = argc > 2 ? argv [2] : NULL;
RESULT_NODE *error = argc > 3 ? argv [3] : NULL;
if (! buffer)
{
strcpy (object_error, "Missing argument: buffer");
return -1;
}
{
SOCK_HANDLE_ITEM
*socket = item;
THREAD
*thread;
if (start_socket_agent ())
return -1;
thread = thread_create (AGENT_NAME, "");
tcb = thread-> tcb;
tcb-> gsl_thread = gsl_thread;
tcb-> result = result;
tcb-> buffer = buffer;
tcb-> error = error;
tcb-> sock_handle = socket;
tcb-> context = NULL;
tcb-> handle = 0;
lsend_smtsock_readh (& sockq-> qid,
& thread-> queue-> qid,
NULL, NULL, NULL, 0,
(word) (timeout ? number_value (&timeout-> value): 0),
socket-> handle,
(dbyte) 0xFFFF, /* Maximum */
minimum ? (word) number_value (& minimum-> value) : 1,
0);
return 0;
}
return 0; /* Just in case */
}
LISPTR lisp_print(LISPTR x, FILE* out)
{
if (consp(x)) {
fputwc('(', out);
while (true) {
lisp_print(car(x), out);
x = cdr(x);
if (!consp(x)) {
if (x != NIL) {
fputws(L" . ", out);
lisp_print(x, out);
}
break;
}
fputwc(' ', out);
}
fputwc(')', out);
} else if (symbolp(x)) {
fputws(string_text(symbol_name(x)), out);
} else if (numberp(x)) {
fwprintf(out, L"%g", number_value(x));
} else if (stringp(x)) {
fputwc('"', out);
fputws(string_text(x), out);
fputwc('"', out);
} else {
fputws(L"*UNKOBJ*", out);
}
return x;
}
static int
conv_number (int argc, RESULT_NODE **argv, void *item, RESULT_NODE *result, THREAD *gsl_thread)
{
RESULT_NODE *arg = argc > 0 ? argv [0] : NULL;
if (! arg)
{
strcpy (object_error, "Missing argument: arg");
return -1;
}
if (arg-> value. type == TYPE_UNDEFINED)
{
result-> culprit = arg-> culprit;
arg-> culprit = NULL;
return 0;
}
{
number_value (&arg-> value);
if (arg-> value. type == TYPE_NUMBER)
copy_value (&result-> value, &arg-> value);
return 0;
}
return 0; /* Just in case */
}
static pobject div(pobject env, pobject params)
{
float result = 0;
pobject o = eval(env, cons_car(params));
if (is_number(o)) {
result = number_value(o);
params = cons_cdr(params);
if (is_cons(params)) {
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result /= number_value(o); /* TODO: division by zero error handling */
params = cons_cdr(params);
}
}
}
return gc_add(number_new(result));
}
static int
sock_handle_write (int argc, RESULT_NODE **argv, void *item, RESULT_NODE *result, THREAD *gsl_thread)
{
RESULT_NODE *buffer = argc > 0 ? argv [0] : NULL;
RESULT_NODE *timeout = argc > 1 ? argv [1] : NULL;
RESULT_NODE *error = argc > 2 ? argv [2] : NULL;
if (! buffer)
{
strcpy (object_error, "Missing argument: buffer");
return -1;
}
if (buffer-> value. type == TYPE_UNDEFINED)
{
result-> culprit = buffer-> culprit;
buffer-> culprit = NULL;
lsend_ggcode_call_ok (& gsl_thread-> queue-> qid, NULL,
NULL, NULL, NULL, 0);
return 0;
}
{
SOCK_HANDLE_ITEM
*socket = item;
THREAD
*thread;
if (start_socket_agent ())
return -1;
thread = thread_create (AGENT_NAME, "");
tcb = thread-> tcb;
tcb-> gsl_thread = gsl_thread;
tcb-> result = result;
tcb-> buffer = NULL;
tcb-> error = error;
tcb-> sock_handle = socket;
tcb-> context = NULL;
tcb-> handle = 0;
lsend_smtsock_writeh (& sockq-> qid,
& thread-> queue-> qid,
NULL, NULL, NULL, 0,
(word) (timeout ? number_value (& timeout-> value) : 0),
socket-> handle,
(qbyte) strlen (string_value (& buffer-> value)),
(byte *) buffer-> value. s,
TRUE,
0);
return 0;
}
return 0; /* Just in case */
}
static int
sock_connect (int argc, RESULT_NODE **argv, void *item, RESULT_NODE *result, THREAD *gsl_thread)
{
RESULT_NODE *host = argc > 0 ? argv [0] : NULL;
RESULT_NODE *service = argc > 1 ? argv [1] : NULL;
RESULT_NODE *timeout = argc > 2 ? argv [2] : NULL;
RESULT_NODE *error = argc > 3 ? argv [3] : NULL;
if (! service)
{
strcpy (object_error, "Missing argument: service");
return -1;
}
if (service-> value. type == TYPE_UNDEFINED)
{
result-> culprit = service-> culprit;
service-> culprit = NULL;
lsend_ggcode_call_ok (& gsl_thread-> queue-> qid, NULL,
NULL, NULL, NULL, 0);
return 0;
}
{
THREAD
*thread;
if (start_socket_agent ())
return -1;
thread = thread_create (AGENT_NAME, "");
tcb = thread-> tcb;
tcb-> gsl_thread = gsl_thread;
tcb-> result = result;
tcb-> buffer = NULL;
tcb-> error = error;
tcb-> sock_handle = NULL;
tcb-> context = item;
tcb-> handle = 0;
lsend_smtsock_connect (& sockq-> qid,
& thread-> queue-> qid,
NULL, NULL, NULL, 0,
(word) (timeout ? number_value (& timeout-> value) : 0),
"tcp",
host ? string_value (& host-> value) : "",
string_value (& service-> value),
0, 0, 0);
return 0;
}
return 0; /* Just in case */
}
static pobject mult(pobject env, pobject params)
{
float result = 1;
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result *= number_value(o);
params = cons_cdr(params);
}
return gc_add(number_new(result));
}
static pobject minus(pobject env, pobject params)
{
float result = 0;
pobject o = eval(env, cons_car(params));
if (is_number(o)) {
result = number_value(o);
params = cons_cdr(params);
if (is_cons(params)) {
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result -= number_value(o);
params = cons_cdr(params);
}
} else {
result = -result;
}
}
return gc_add(number_new(result));
}
static int
conv_chr (int argc, RESULT_NODE **argv, void *item, RESULT_NODE *result, THREAD *gsl_thread)
{
RESULT_NODE *arg = argc > 0 ? argv [0] : NULL;
if (! arg)
{
strcpy (object_error, "Missing argument: arg");
return -1;
}
if (arg-> value. type == TYPE_UNDEFINED)
{
result-> culprit = arg-> culprit;
arg-> culprit = NULL;
return 0;
}
{
number_value (&arg-> value);
if (arg-> value. type == TYPE_NUMBER)
{
result-> value. type = TYPE_STRING;
result-> value. s = mem_alloc (2);
ASSERT (result-> value. s);
if (arg-> value. n > 0
&& arg-> value. n < 256)
result-> value. s [0] = (char) arg-> value. n;
else
result-> value. s [0] = '\0';
result-> value. s [1] = '\0';
}
else
{
result-> culprit = arg-> culprit;
arg-> culprit = NULL;
}
return 0;
}
return 0; /* Just in case */
}
static int
sock_handle_close (int argc, RESULT_NODE **argv, void *item, RESULT_NODE *result, THREAD *gsl_thread)
{
RESULT_NODE *timeout = argc > 0 ? argv [0] : NULL;
RESULT_NODE *error = argc > 1 ? argv [1] : NULL;
{
SOCK_HANDLE_ITEM
*socket = item;
THREAD
*thread;
if (start_socket_agent ())
return -1;
thread = thread_create (AGENT_NAME, "");
tcb = thread-> tcb;
tcb-> gsl_thread = gsl_thread;
tcb-> result = result;
tcb-> buffer = NULL;
tcb-> error = error;
tcb-> sock_handle = socket;
tcb-> context = NULL;
tcb-> handle = 0;
lsend_smtsock_close (& sockq-> qid,
& thread-> queue-> qid,
NULL, NULL, NULL, 0,
(word) (timeout ? number_value (& timeout-> value) : 0),
socket-> handle,
TRUE,
0);
return 0;
}
return 0; /* Just in case */
}
int
format_output (char *format, char conversion, int width,
RESULT_NODE *node)
{
char
local_buffer [LINE_MAX + 1],
*line_ptr,
*line_end,
*buffer,
*buf_ptr;
int
total_length,
line_length,
out_length,
rc = 0;
if (conversion == 's')
{
string_value (& node-> value);
total_length = 0;
line_ptr = node-> value. s;
while (line_ptr && *line_ptr)
{
line_end = strchr (line_ptr, '\n');
if (line_end)
line_length = line_end - line_ptr;
else
line_length = strlen (line_ptr);
if (line_length < width)
line_length = width;
total_length += line_length;
if (line_end)
{
line_ptr = line_end + 1;
total_length += 1;
}
else
line_ptr = NULL;
}
buffer = mem_alloc (total_length + 1);
buf_ptr = buffer;
line_ptr = node-> value. s;
out_length = 0;
while (line_ptr && *line_ptr)
{
line_end = strchr (line_ptr, '\n');
if (line_end)
*line_end = 0;
rc = sprintf (buf_ptr, format, line_ptr);
buf_ptr += rc;
out_length += rc;
if (line_end)
{
*line_end = '\n';
*buf_ptr = '\n';
buf_ptr += 1;
out_length += 1;
line_ptr = line_end + 1;
}
else
break;
}
*buf_ptr = 0;
ASSERT (out_length == total_length);
mem_free (node-> value. s);
node-> value. s = buffer;
}
else
{
// The following conversion is only valid for doubles in the range
// (0 .. 2^32)
if (strchr ("diouxX", conversion))
rc = snprintf (local_buffer, LINE_MAX, format,
(unsigned long) number_value (& node-> value));
else
if (strchr ("eEfg", conversion))
rc = snprintf (local_buffer, LINE_MAX, format,
number_value (& node-> value));
else
if (conversion == 'c')
rc = snprintf (local_buffer, LINE_MAX, format,
(int) number_value (& node-> value));
mem_free (node-> value. s);
node-> value. s = mem_strdup (local_buffer);
}
if (node-> value. type == TYPE_BLOCK)
construct_block (& node-> value);
else
node-> value. type = TYPE_UNKNOWN;
return rc;
}
