// socket-shutdown
scm_obj_t
subr_socket_shutdown(VM* vm, int argc, scm_obj_t argv[])
{
if (argc == 2) {
if (SOCKETP(argv[0])) {
if (FIXNUMP(argv[1])) {
intptr_t how = FIXNUM(argv[1]);
if (how >= 0 && how <= 2) {
try {
socket_shutdown((scm_socket_t)argv[0], FIXNUM(argv[1]));
return scm_unspecified;
} catch (io_exception_t& e) {
raise_io_error(vm, "socket-shutdown", e.m_operation, e.m_message, e.m_err, argv[0], scm_false);
return scm_undef;
}
}
}
wrong_type_argument_violation(vm, "socket-shutdown", 1, "0, 1, or 2", argv[1], argc, argv);
return scm_undef;
}
wrong_type_argument_violation(vm, "socket-shutdown", 0, "socket", argv[0], argc, argv);
return scm_undef;
}
wrong_number_of_arguments_violation(vm, "socket-shutdown", 2, 2, argc, argv);
return scm_undef;
}
void
VM::backtrace_each(printer_t* prt, int n, scm_obj_t note)
{
assert(PAIRP(note));
if (n < 10) prt->byte(' ');
if (CDR(note) == scm_nil) {
// (expr) : dynamic
prt->format(" %d ~u", n, CAR(note));
} else if (FIXNUMP(CDR(note))) {
// (path . fixnum) : load
assert(STRINGP(CAR(note)));
scm_string_t string = (scm_string_t)CAR(note);
int comment = FIXNUM(CDR(note));
int line = comment / MAX_SOURCE_COLUMN;
int column = comment % MAX_SOURCE_COLUMN;
scm_obj_t expr = backtrace_fetch(string->name, line, column);
if (expr == scm_unspecified) {
prt->format(" %d --- unknown ---", n);
} else {
prt->format(" %d ~u", n, expr);
}
prt->format("~% ...~s line %d", string, line);
} else {
// (expr path . fixnum) : repl
scm_string_t string = (scm_string_t)CADR(note);
int comment = FIXNUM(CDDR(note));
int line = comment / MAX_SOURCE_COLUMN;
prt->format(" %d ~u", n, CAR(note));
prt->format("~% ...~s line %d", string, line);
}
prt->format("~%");
}
// shared-queue-pop!
scm_obj_t subr_shared_queue_pop(VM* vm, int argc, scm_obj_t argv[])
{
#if USE_PARALLEL_VM
if (argc == 1 || argc == 2) {
if (SHAREDQUEUEP(argv[0])) {
int timeout = 0;
if (argc == 2) {
if (FIXNUMP(argv[1]) && FIXNUM(argv[1]) >= 0) {
timeout = FIXNUM(argv[1]);
} else {
wrong_type_argument_violation(vm, "shared-queue-pop!", 1, "non-negative fixnum", argv[1], argc, argv);
return scm_undef;
}
}
scm_sharedqueue_t queue = (scm_sharedqueue_t)argv[0];
intptr_t id;
bool succ;
if (queue->queue.wait_lock_try_get(&id)) goto receive;
if (argc == 2) {
if (timeout == 0) goto timeout;
vm->m_interp->update(vm, VM_STATE_BLOCK);
succ = queue->queue.get(&id, timeout);
vm->m_interp->update(vm, VM_STATE_ACTIVE);
if (!succ) goto timeout;
} else {
vm->m_interp->update(vm, VM_STATE_BLOCK);
succ = queue->queue.get(&id);
vm->m_interp->update(vm, VM_STATE_ACTIVE);
if (!succ) return scm_shutdown;
}
receive:
{
#if USE_SHARED_QUEUE_QUICK_ENCODE
if (id < 0) return MAKEFIXNUM(id);
if (id == INTPTR_MAX) return scm_true;
if (id == INTPTR_MAX - 1) return scm_false;
#endif
scm_bvector_t bvector = make_bvector(vm->m_heap, queue->buf.size(id));
queue->buf.get(id, bvector->elts);
scm_obj_t obj = deserializer_t(vm->m_heap).translate((scm_bvector_t)bvector);
if (obj) return obj;
invalid_serialized_object_violation(vm, "shared-queue-pop!", bvector, argc, argv);
return scm_undef;
}
timeout:
if (queue->queue.no_more_get()) return scm_shutdown;
return scm_timeout;
}
wrong_type_argument_violation(vm, "shared-queue-pop!", 0, "shared queue", argv[0], argc, argv);
return scm_undef;
}
wrong_number_of_arguments_violation(vm, "shared-queue-pop!", 1, 2, argc, argv);
return scm_undef;
#else
fatal("%s:%u shared-queue-pop! not supported on this build",__FILE__ , __LINE__);
#endif
}
// shared-bag-put!
scm_obj_t
subr_shared_bag_put(VM* vm, int argc, scm_obj_t argv[])
{
#if USE_PARALLEL_VM
if (argc == 3 || argc == 4) {
if (SHAREDBAGP(argv[0])) {
if (STRINGP(argv[1])) {
int timeout = 0;
if (argc == 4) {
if (FIXNUMP(argv[3]) && FIXNUM(argv[3]) >= 0) {
timeout = FIXNUM(argv[3]);
} else {
wrong_type_argument_violation(vm, "shared-bag-put!", 3, "non-negative fixnum", argv[3], argc, argv);
return scm_undef;
}
}
scm_string_t string = (scm_string_t)argv[1];
sharedbag_slot_t* slot = lookup_sharedbag((scm_sharedbag_t)argv[0], string->name, string->size);
assert(slot);
#if CYCLIC_CHECK_BEFORE_SERIALIZE
if (cyclic_objectp(vm->m_heap, argv[2])) {
serialize_cyclic_object_violation(vm, "shared-bag-put!", argv[2], argc, argv);
return scm_undef;
}
#endif
scm_obj_t obj = serializer_t(vm->m_heap).translate(argv[2]);
if (BVECTORP(obj)) {
scm_bvector_t bvector = (scm_bvector_t)obj;
int id = slot->buf.put(bvector->elts, bvector->count);
if (slot->queue.wait_lock_try_put(id)) return scm_true;
if (argc == 4) {
vm->m_interp->update(vm, VM_STATE_BLOCK);
bool succ = slot->queue.put(id, timeout);
vm->m_interp->update(vm, VM_STATE_ACTIVE);
if (succ) return scm_true;
if (slot->queue.no_more_put()) return scm_shutdown;
return scm_timeout;
} else {
vm->m_interp->update(vm, VM_STATE_BLOCK);
bool succ = slot->queue.put(id);
vm->m_interp->update(vm, VM_STATE_ACTIVE);
return succ ? scm_true : scm_shutdown;
}
}
non_serializable_object_violation(vm, "shared-bag-put!", obj, argc, argv);
return scm_undef;
}
wrong_type_argument_violation(vm, "shared-bag-put!", 1, "string", argv[1], argc, argv);
return scm_undef;
}
wrong_type_argument_violation(vm, "shared-bag-put!", 0, "shared bag", argv[0], argc, argv);
return scm_undef;
}
wrong_number_of_arguments_violation(vm, "shared-bag-put!", 3, 4, argc, argv);
return scm_undef;
#else
fatal("%s:%u shared-bag-put! not supported on this build", __FILE__, __LINE__);
#endif
}
// shared-bag-get!
scm_obj_t
subr_shared_bag_get(VM* vm, int argc, scm_obj_t argv[])
{
#if USE_PARALLEL_VM
if (argc == 2 || argc == 3) {
if (SHAREDBAGP(argv[0])) {
int timeout = 0;
if (argc == 3) {
if (FIXNUMP(argv[2]) && FIXNUM(argv[2]) >= 0) {
timeout = FIXNUM(argv[2]);
} else {
wrong_type_argument_violation(vm, "shared-bag-get!", 2, "non-negative fixnum", argv[2], argc, argv);
return scm_undef;
}
}
scm_string_t string = (scm_string_t)argv[1];
sharedbag_slot_t* slot = lookup_sharedbag((scm_sharedbag_t)argv[0], string->name, string->size);
assert(slot);
intptr_t id;
bool succ;
if (slot->queue.wait_lock_try_get(&id)) goto receive;
if (argc == 3) {
if (timeout == 0) goto timeout;
vm->m_interp->update(vm, VM_STATE_BLOCK);
succ = slot->queue.get(&id, timeout);
vm->m_interp->update(vm, VM_STATE_ACTIVE);
if (!succ) goto timeout;
} else {
vm->m_interp->update(vm, VM_STATE_BLOCK);
succ = slot->queue.get(&id);
vm->m_interp->update(vm, VM_STATE_ACTIVE);
if (!succ) return scm_shutdown;
}
receive:
{
scm_bvector_t bvector = make_bvector(vm->m_heap, slot->buf.size(id));
slot->buf.get(id, bvector->elts);
scm_obj_t obj = deserializer_t(vm->m_heap).translate((scm_bvector_t)bvector);
if (obj) return obj;
invalid_serialized_object_violation(vm, "shared-bag-get!", bvector, argc, argv);
return scm_undef;
}
timeout:
if (slot->queue.no_more_get()) return scm_shutdown;
return scm_timeout;
}
wrong_type_argument_violation(vm, "shared-bag-get!", 0, "shared bag", argv[0], argc, argv);
return scm_undef;
}
wrong_number_of_arguments_violation(vm, "shared-bag-get!", 1, 2, argc, argv);
return scm_undef;
#else
fatal("%s:%u shared-bag-get! not supported on this build",__FILE__ , __LINE__);
#endif
}
bool
VM::backtrace(scm_port_t port)
{
if (flags.m_backtrace == scm_false) return false;
scoped_lock lock(port->lock);
printer_t prt(this, port);
scm_obj_t obj = scm_unspecified;
if (m_trace_tail != scm_unspecified && CDR(m_trace_tail) != scm_nil) {
obj = m_trace_tail;
} else if (m_trace != scm_unspecified && CDR(m_trace) != scm_nil) {
obj = m_trace;
} else {
void* lnk = m_cont;
while (lnk) {
vm_cont_t cont = (vm_cont_t)((intptr_t)lnk - offsetof(vm_cont_rec_t, up));
if (cont->trace != scm_unspecified && CDR(cont->trace)) {
obj = cont->trace;
break;
}
lnk = (*(void**)lnk);
}
}
if (obj == scm_unspecified) return false;
int bt_level = FIXNUMP(flags.m_backtrace) ? FIXNUM(flags.m_backtrace) : FIXNUM_MAX;
int n = 0;
if (n == bt_level) return false;
prt.format("~%backtrace:~%");
prt.column_limit(FIXNUM(flags.m_backtrace_line_length));
if (m_trace_tail != scm_unspecified) {
backtrace_each(&prt, n++, m_trace_tail);
if (n == bt_level) return true;
}
if (m_trace != scm_unspecified) {
backtrace_each(&prt, n++, m_trace);
if (n == bt_level) return true;
}
void* lnk = m_cont;
while (lnk) {
vm_cont_t cont = (vm_cont_t)((intptr_t)lnk - offsetof(vm_cont_rec_t, up));
if (cont->trace != scm_unspecified) {
backtrace_each(&prt, n++, cont->trace);
if (n == bt_level) return true;
}
lnk = (*(void**)lnk);
}
return true;
}
LispObj *
Lisp_XawTextSearch(LispBuiltin *builtin)
/*
xaw-text-search widget direction text
*/
{
Widget widget;
XawTextScanDirection direction;
XawTextBlock block;
LispObj *owidget, *odirection, *otext;
otext = ARGUMENT(2);
odirection = ARGUMENT(1);
owidget = ARGUMENT(0);
if (!CHECKO(owidget, xawWidget_t))
LispDestroy("%s: cannot convert %s to Widget",
STRFUN(builtin), STROBJ(owidget));
widget = (Widget)(owidget->data.opaque.data);
CHECK_INDEX(odirection);
direction = (XawTextPosition)FIXNUM_VALUE(odirection);
if (direction != XawsdLeft && direction != XawsdRight)
LispDestroy("%s: %d does not fit in XawTextScanDirection",
STRFUN(builtin), direction);
CHECK_STRING(otext);
block.firstPos = 0;
block.ptr = THESTR(otext);
block.length = strlen(block.ptr);
block.format = FMT8BIT;
return (FIXNUM(XawTextSearch(widget, direction, &block)));
}
LispObj *
Lisp_DigitCharP(LispBuiltin *builtin)
/*
digit-char-p character &optional radix
*/
{
long radix = 10, character;
LispObj *ochar, *oradix, *result = NIL;
oradix = ARGUMENT(1);
ochar = ARGUMENT(0);
CHECK_SCHAR(ochar);
character = SCHAR_VALUE(ochar);
if (oradix != UNSPEC) {
CHECK_INDEX(oradix);
radix = FIXNUM_VALUE(oradix);
}
if (radix < 2 || radix > 36)
LispDestroy("%s: radix must be >= 2 and <= 36, not %ld",
STRFUN(builtin), radix);
if (character >= '0' && character <= '9')
character -= '0';
else if (character >= 'A' && character <= 'Z')
character -= 'A' - 10;
else if (character >= 'a' && character <= 'z')
character -= 'a' - 10;
if (character < radix)
result = FIXNUM(character);
return (result);
}
elem Verify_CountTheEntities(elem str)
{
elem t;
char *s;
int ltc, gtc, ampc, qc, dqc;
ltc=0;
gtc=0;
ampc=0;
qc=0;
dqc=0;
s=ELEM_TOSTRING(str);
while(*s)
{
switch(*s++)
{
case '<':
ltc++;
break;
case '>':
gtc++;
break;
case '&':
ampc++;
break;
case '\'':
qc++;
break;
case '"':
dqc++;
break;
default:
break;
}
}
t=TyObj_CloneNull();
TyObj_SetSlot(t, SYM("ctLeftAngleBrackets"), FIXNUM(ltc));
TyObj_SetSlot(t, SYM("ctRightAngleBrackets"), FIXNUM(gtc));
TyObj_SetSlot(t, SYM("ctAmpersands"), FIXNUM(ampc));
TyObj_SetSlot(t, SYM("ctApostrophes"), FIXNUM(qc));
TyObj_SetSlot(t, SYM("ctQuotes"), FIXNUM(dqc));
return(t);
}
static int string_ref(vm_thread_t *thread, obj_t *ostr, obj_t *opos)
{
SAFE_ASSERT(IS_STRING(*ostr));
SAFE_ASSERT(IS_FIXNUM(*opos));
string_t *str = PTR(*ostr);
int pos = FIXNUM(*opos);
SAFE_ASSERT(pos < str->size-1);
RETURN_CHAR(str->str[pos]);
}
// spawn-heap-limit
scm_obj_t
subr_spawn_heap_limit(VM* vm, int argc, scm_obj_t argv[])
{
#if USE_PARALLEL_VM
if (argc == 1) {
if (FIXNUMP(argv[0]) && FIXNUM(argv[0]) >= 0) {
vm->m_spawn_heap_limit = FIXNUM(argv[0]);
return scm_unspecified;
} else {
wrong_type_argument_violation(vm, "spawn-heap-limit", 0, "non-negative fixnum", argv[0], argc, argv);
return scm_undef;
}
}
if (argc == 0) return MAKEFIXNUM(vm->m_spawn_heap_limit);
wrong_number_of_arguments_violation(vm, "spawn-heap-limit", 0, 1, argc, argv);
return scm_undef;
#else
fatal("%s:%u spawn-heap-limit not supported on this build", __FILE__, __LINE__);
#endif
}
/* XXX preserve-whitespace is being ignored */
LispObj *
Lisp_ReadFromString(LispBuiltin *builtin)
/*
read-from-string string &optional eof-error-p eof-value &key start end preserve-whitespace
*/
{
GC_ENTER();
char *string;
LispObj *stream, *result;
long length, start, end, bytes_read;
LispObj *ostring, *eof_error_p, *eof_value, *ostart, *oend;
oend = ARGUMENT(4);
ostart = ARGUMENT(3);
eof_value = ARGUMENT(2);
eof_error_p = ARGUMENT(1);
ostring = ARGUMENT(0);
CHECK_STRING(ostring);
string = THESTR(ostring);
LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
&start, &end, &length);
if (start > 0 || end < length)
length = end - start;
stream = LSTRINGSTREAM(string + start, STREAM_READ, length);
if (eof_value == UNSPEC)
eof_value = NIL;
LispPushInput(stream);
result = LispRead();
/* stream->data.stream.source.string->input is
* the offset of the last byte read in string */
bytes_read = stream->data.stream.source.string->input;
LispPopInput(stream);
if (result == NULL) {
if (eof_error_p == NIL)
result = eof_value;
else
LispDestroy("%s: unexpected end of input", STRFUN(builtin));
}
GC_PROTECT(result);
RETURN(0) = FIXNUM(start + bytes_read);
RETURN_COUNT = 1;
GC_LEAVE();
return (result);
}
static int string_set(vm_thread_t *thread, obj_t *ostr,
obj_t *opos, obj_t *oval)
{
SAFE_ASSERT(IS_STRING(*ostr));
SAFE_ASSERT(IS_FIXNUM(*opos));
SAFE_ASSERT(IS_CHAR(*oval));
string_t *str = PTR(*ostr);
int pos = FIXNUM(*opos);
SAFE_ASSERT((pos >= 0) && (pos < str->size-1));
str->str[pos] = CHAR(*oval);
RETURN_OBJ(cvoid);
}
elem Verify_ArrayOfStructsTest(elem lst)
{
elem cur, t;
int i;
i=0;
cur=lst;
while(ELEM_CONSP(cur))
{
t=TyObj_GetSlot(CAR(cur), SYM("curly"));
i+=TOINT(t);
cur=CDR(cur);
}
return(FIXNUM(i));
}
static int substring(vm_thread_t *thread, obj_t *ostr, obj_t *ostart, obj_t *oend)
{
SAFE_ASSERT(IS_STRING(*ostr));
SAFE_ASSERT(IS_FIXNUM(*ostart));
SAFE_ASSERT(IS_FIXNUM(*oend));
int start = FIXNUM(*ostart);
int end = FIXNUM(*oend);
string_t *str = PTR(*ostr);
SAFE_ASSERT((start >= 0)
&& (start <= end)
&& (end < str->size));
size_t nsize = end-start;
void *mem = heap_alloc(&thread->heap, nsize+sizeof(string_t), t_string);
string_t *dstr = mem;
dstr->str = mem+sizeof(string_t);
dstr->allocated = 1;
dstr->size = nsize+1;
memcpy(dstr->str, &CSTRING(*ostr)[start], nsize);
RETURN_OBJ(MAKE_HEAP_PTR(dstr));
}
int test(struct IridiumContext * context) {
object integer;
char * c_integer;
setup(context);
integer = FIXNUM(-11);
c_integer = C_STRING(context, send(integer, "to_s"));
assertEqual(strcmp(c_integer, "-11"), 0);
return 0;
}
elem Verify_NestedStructTest(elem str)
{
elem t, t2;
int i;
t=TyObj_GetSlot(str, SYM("2000"));
t=TyObj_GetSlot(t, SYM("04"));
t=TyObj_GetSlot(t, SYM("01"));
i=0;
i+=TOINT(TyObj_GetSlot(t, SYM("curly")));
i+=TOINT(TyObj_GetSlot(t, SYM("larry")));
i+=TOINT(TyObj_GetSlot(t, SYM("moe")));
return(FIXNUM(i));
}
LispObj *
Lisp_XawTextLastPosition(LispBuiltin *builtin)
/*
xaw-text-last-position widget
*/
{
LispObj *owidget;
owidget = ARGUMENT(0);
if (!CHECKO(owidget, xawWidget_t))
LispDestroy("%s: cannot convert %s to Widget",
STRFUN(builtin), STROBJ(owidget));
return (FIXNUM(XawTextLastPosition((Widget)(owidget->data.opaque.data))));
}
LispObj *
Lisp_XawTextGetInsertionPoint(LispBuiltin *builtin)
/*
xaw-text-get-insertion-point widget
*/
{
LispObj *owidget;
owidget = ARGUMENT(0);
if (!CHECKO(owidget, xawWidget_t))
LispDestroy("%s: cannot convert %s to Widget",
STRFUN(builtin), STROBJ(owidget));
return (FIXNUM(XawTextGetInsertionPoint((Widget)(owidget->data.opaque.data))));
}
LispObj *
Lisp_XHeightOfScreen(LispBuiltin *builtin)
/*
x-height-of-screen screen
*/
{
LispObj *screen;
screen = ARGUMENT(0);
if (!CHECKO(screen, x11Screen_t))
LispDestroy("%s: cannot convert %s to Screen*",
STRFUN(builtin), STROBJ(screen));
return (FIXNUM(HeightOfScreen((Screen*)(screen->data.opaque.data))));
}
elem Verify_EasyStructTest(elem obj)
{
elem t;
int i;
i=0;
t=TyObj_GetSlot(obj, SYM("moe"));
i+=TOINT(t);
t=TyObj_GetSlot(obj, SYM("larry"));
i+=TOINT(t);
t=TyObj_GetSlot(obj, SYM("curly"));
i+=TOINT(t);
return(FIXNUM(i));
}
static int string_copy_to(vm_thread_t *thread, obj_t *odest, obj_t *opos, obj_t *osrc)
{
SAFE_ASSERT(IS_STRING(*odest));
SAFE_ASSERT(IS_HEAP_PTR(*odest));
SAFE_ASSERT(IS_STRING(*osrc));
SAFE_ASSERT(IS_FIXNUM(*opos));
string_t *src = PTR(*osrc);
string_t *dst = PTR(*odest);
SAFE_ASSERT(dst->allocated);
int pos = FIXNUM(*opos);
SAFE_ASSERT((pos >= 0)
&& (pos+src->size <= dst->size));
memcpy(&dst->str[pos], src->str, src->size-1);
RETURN_OBJ(cvoid);
}
static int make_string(vm_thread_t *thread, obj_t *olen, obj_t *ofill)
{
SAFE_ASSERT(IS_FIXNUM(*olen));
SAFE_ASSERT(IS_CHAR(*ofill));
size_t len = FIXNUM(*olen);
void *mem = heap_alloc(&thread->heap, sizeof(string_t)+len+1, t_string);
string_t *str = mem;
str->str = mem+sizeof(string_t);
str->size = len+1;
str->allocated = 1;
char fill = CHAR(*ofill);
int i;
for (i = 0; i < len; i++)
str->str[i] = fill;
str->str[len] = '\0';
RETURN_OBJ(MAKE_HEAP_PTR(str));
}
static LispObj *
LispCharOp(LispBuiltin *builtin, int operation)
{
int value;
LispObj *result, *character;
character = ARGUMENT(0);
CHECK_SCHAR(character);
value = (int)SCHAR_VALUE(character);
switch (operation) {
case CHAR_ALPHAP:
result = isalpha(value) ? T : NIL;
break;
case CHAR_DOWNCASE:
result = SCHAR(tolower(value));
break;
case CHAR_UPCASE:
result = SCHAR(toupper(value));
break;
case CHAR_INT:
result = FIXNUM(value);
break;
case CHAR_BOTHP:
result = isupper(value) || islower(value) ? T : NIL;
break;
case CHAR_UPPERP:
result = isupper(value) ? T : NIL;
break;
case CHAR_LOWERP:
result = islower(value) ? T : NIL;
break;
case CHAR_GRAPHICP:
result = value == ' ' || isgraph(value) ? T : NIL;
break;
default:
result = NIL;
break;
}
return (result);
}
// spawn-timeout
scm_obj_t
subr_spawn_timeout(VM* vm, int argc, scm_obj_t argv[])
{
#if USE_PARALLEL_VM
if (argc == 1) {
if ((FIXNUMP(argv[0]) && FIXNUM(argv[0]) >= 0) || argv[0] == scm_false) {
vm->m_spawn_timeout = argv[0];
return scm_unspecified;
} else {
wrong_type_argument_violation(vm, "spawn-timeout", 0, "#f or non-negative fixnum", argv[0], argc, argv);
return scm_undef;
}
}
if (argc == 0) return vm->m_spawn_timeout;
wrong_number_of_arguments_violation(vm, "spawn-timeout", 0, 1, argc, argv);
return scm_undef;
#else
fatal("%s:%u spawn-timeout not supported on this build", __FILE__, __LINE__);
#endif
}
// make-shared-bag
scm_obj_t
subr_make_shared_bag(VM* vm, int argc, scm_obj_t argv[])
{
#if USE_PARALLEL_VM
if (argc == 0) {
scm_sharedbag_t bag = make_sharedbag(vm->m_heap, 1);
return bag;
}
if (argc == 1) {
if (FIXNUMP(argv[0])) {
scm_sharedbag_t bag = make_sharedbag(vm->m_heap, FIXNUM(argv[0]));
return bag;
}
wrong_type_argument_violation(vm, "make-shared-bag", 1, "fixnum", argv[0], argc, argv);
return scm_undef;
}
wrong_number_of_arguments_violation(vm, "make-shared-bag", 0, 1, argc, argv);
return scm_undef;
#else
fatal("%s:%u make-shared-bag not supported on this build", __FILE__, __LINE__);
#endif
}
LispObj *
Lisp_XawTextReplace(LispBuiltin *builtin)
/*
xaw-text-replace widget left right text
*/
{
Widget widget;
XawTextPosition left, right;
XawTextBlock block;
LispObj *owidget, *oleft, *oright, *otext;
otext = ARGUMENT(3);
oright = ARGUMENT(2);
oleft = ARGUMENT(1);
owidget = ARGUMENT(0);
if (!CHECKO(owidget, xawWidget_t))
LispDestroy("%s: cannot convert %s to Widget",
STRFUN(builtin), STROBJ(owidget));
widget = (Widget)(owidget->data.opaque.data);
CHECK_INDEX(oleft);
left = (XawTextPosition)FIXNUM_VALUE(oleft);
CHECK_INDEX(oright);
right = (XawTextPosition)FIXNUM_VALUE(oright);
CHECK_STRING(otext);
block.firstPos = 0;
block.ptr = THESTR(otext);
block.length = strlen(block.ptr);
block.format = FMT8BIT;
return (FIXNUM(XawTextReplace(widget, left, right, &block)));
}
// shared-queue-push!
scm_obj_t
subr_shared_queue_push(VM* vm, int argc, scm_obj_t argv[])
{
#if USE_PARALLEL_VM
if (argc == 2 || argc == 3) {
if (SHAREDQUEUEP(argv[0])) {
int timeout = 0;
if (argc == 3) {
if (FIXNUMP(argv[2]) && FIXNUM(argv[2]) >= 0) {
timeout = FIXNUM(argv[2]);
} else {
wrong_type_argument_violation(vm, "shared-queue-push!", 2, "non-negative fixnum", argv[2], argc, argv);
return scm_undef;
}
}
scm_sharedqueue_t queue = (scm_sharedqueue_t)argv[0];
intptr_t id;
#if USE_SHARED_QUEUE_QUICK_ENCODE
if (FIXNUMP(argv[1])) {
id = FIXNUM(argv[1]) | INTPTR_MIN;
}
else if (argv[1] == scm_true) {
id = INTPTR_MAX;
}
else if (argv[1] == scm_false) {
id = INTPTR_MAX - 1;
}
else
#endif
{
#if CYCLIC_CHECK_BEFORE_SERIALIZE
if (cyclic_objectp(vm->m_heap, argv[1])) {
serialize_cyclic_object_violation(vm, "shared-queue-push!", argv[1], argc, argv);
return scm_undef;
}
#endif
scm_obj_t obj = serializer_t(vm->m_heap).translate(argv[1]);
if (BVECTORP(obj)) {
scm_bvector_t bvector = (scm_bvector_t)obj;
id = queue->buf.put(bvector->elts, bvector->count);
} else {
non_serializable_object_violation(vm, "shared-queue-push!", obj, argc, argv);
return scm_undef;
}
}
if (queue->queue.wait_lock_try_put(id)) return scm_true;
if (argc == 3) {
vm->m_interp->update(vm, VM_STATE_BLOCK);
bool succ = queue->queue.put(id, timeout);
vm->m_interp->update(vm, VM_STATE_ACTIVE);
if (succ) return scm_true;
if (queue->queue.no_more_put()) return scm_shutdown;
return scm_timeout;
} else {
vm->m_interp->update(vm, VM_STATE_BLOCK);
bool succ = queue->queue.put(id);
vm->m_interp->update(vm, VM_STATE_ACTIVE);
return succ ? scm_true : scm_shutdown;
}
}
wrong_type_argument_violation(vm, "shared-queue-push!", 0, "shared queue", argv[0], argc, argv);
return scm_undef;
}
wrong_number_of_arguments_violation(vm, "shared-queue-push!", 2, 3, argc, argv);
return scm_undef;
#else
fatal("%s:%u shared-queue-push! not supported on this build", __FILE__, __LINE__);
#endif
}
LispObj *
Lisp_Reexec(LispBuiltin *builtin)
/*
re-exec regex string &key count start end notbol noteol
*/
{
size_t nmatch;
re_mat match[10];
long start, end, length;
int code, cflags, eflags;
char *string;
LispObj *result;
re_cod *regexp;
LispObj *regex, *ostring, *count, *ostart, *oend, *notbol, *noteol;
noteol = ARGUMENT(6);
notbol = ARGUMENT(5);
oend = ARGUMENT(4);
ostart = ARGUMENT(3);
count = ARGUMENT(2);
ostring = ARGUMENT(1);
regex = ARGUMENT(0);
if (STRINGP(regex))
regexp = LispRecomp(builtin, THESTR(regex), cflags = 0);
else {
CHECK_REGEX(regex);
regexp = regex->data.regex.regex;
cflags = regex->data.regex.options;
}
CHECK_STRING(ostring);
if (count == UNSPEC)
nmatch = 1;
else {
CHECK_INDEX(count);
nmatch = FIXNUM_VALUE(count);
if (nmatch > 10)
LispDestroy("%s: COUNT cannot be larger than 10", STRFUN(builtin));
}
if (nmatch && (cflags & RE_NOSUB))
nmatch = 1;
eflags = RE_STARTEND;
if (notbol != UNSPEC && notbol != NIL)
eflags |= RE_NOTBOL;
if (noteol != UNSPEC && noteol != NIL)
eflags |= RE_NOTEOL;
string = THESTR(ostring);
LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
&start, &end, &length);
match[0].rm_so = start;
match[0].rm_eo = end;
code = reexec(regexp, string, nmatch, &match[0], eflags);
if (code == 0) {
if (nmatch && match[0].rm_eo >= match[0].rm_so) {
result = CONS(CONS(FIXNUM(match[0].rm_so),
FIXNUM(match[0].rm_eo)), NIL);
if (nmatch > 1 && match[1].rm_eo >= match[1].rm_so) {
int i;
GC_ENTER();
LispObj *cons = result;
GC_PROTECT(result);
for (i = 1;
i < nmatch && match[i].rm_eo >= match[i].rm_so;
i++) {
RPLACD(cons, CONS(CONS(FIXNUM(match[i].rm_so),
FIXNUM(match[i].rm_eo)), NIL));
cons = CDR(cons);
}
GC_LEAVE();
}
}
else
result = NIL;
}
else
result = Knomatch;
/* Maybe shoud cache compiled regex, but better the caller do it */
if (!XREGEXP(regex)) {
refree(regexp);
LispFree(regexp);
}
return (result);
}
elem XmlRpc_DecodeValue(elem val)
{
elem t, x;
char *s, *s2;
int i, j;
char buf[5];
if(ELEM_STRINGP(val))return(val);
if(CAR(val)==SYM("i4"))
{
s=ELEM_TOSTRING(CADDR(val));
t=FIXNUM(atoi(s));
return(t);
}
if(CAR(val)==SYM("int"))
{
s=ELEM_TOSTRING(CADDR(val));
t=FIXNUM(atoi(s));
return(t);
}
if(CAR(val)==SYM("boolean"))
{
s=ELEM_TOSTRING(CADDR(val));
i=atoi(s);
t=MISC_TRUE;
if(!i)t=MISC_FALSE;
return(t);
}
if(CAR(val)==SYM("string"))
{
t=CADDR(val);
return(t);
}
if(CAR(val)==SYM("double"))
{
s=ELEM_TOSTRING(CADDR(val));
t=FLONUM(atof(s));
return(t);
}
if(CAR(val)==SYM("dateTime.iso8601"))
{
s=ELEM_TOSTRING(CADDR(val));
x=MISC_EOL;
memset(buf, 0, 5);
strncpy(buf, s, 4);
t=FIXNUM(atoi(buf));
x=CONS(t, x);
memset(buf, 0, 5);
strncpy(buf, s+4, 2);
t=FIXNUM(atoi(buf));
x=CONS(t, x);
strncpy(buf, s+6, 2);
t=FIXNUM(atoi(buf));
x=CONS(t, x);
strncpy(buf, s+9, 2);
t=FIXNUM(atoi(buf));
x=CONS(t, x);
strncpy(buf, s+12, 2);
t=FIXNUM(atoi(buf));
x=CONS(t, x);
strncpy(buf, s+15, 2);
t=FIXNUM(atoi(buf));
x=CONS(t, x);
x=TyFcn_NReverse(x);
x=CONS(SYM("date-time:"), x);
return(x);
}
if(CAR(val)==SYM("base64"))
{
s=ELEM_TOSTRING(CADDR(val));
i=strlen(s);
j=(i*3)/4;
t=VECTOR_NEWT(j, VECTOR_U8);
s2=TyFcn_ByteVectorBody(t);
kprint("recv mime %d->%d\n", i, j);
HttpNode_DecodeMime(s2, s, i);
return(t);
}
if(CAR(val)==SYM("struct"))
{
t=XmlRpc_DecodeStruct(val);
return(t);
}
if(CAR(val)==SYM("array"))
{
t=XmlRpc_DecodeArray(val);
return(t);
}
}
