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