static void fast_read_fast_op(int fast_op_arity, bool has_next, lref_t reader, lref_t * fop)
{
assert((fast_op_arity >= 0) && (fast_op_arity <= 2));
lref_t opcode_obj;
fast_read(reader, &opcode_obj, false);
if (!FIXNUMP(opcode_obj))
vmerror_fast_read("Expected fixnum for opcode.", reader, opcode_obj);
lref_t op_arg1 = NIL;
lref_t op_arg2 = NIL;
lref_t next = NIL;
if (fast_op_arity > 0)
fast_read(reader, &op_arg1, false);
if (fast_op_arity > 1)
fast_read(reader, &op_arg2, false);
if (has_next)
fast_read(reader, &next, false);
*fop = fast_op((int) FIXNM(opcode_obj), op_arg1, op_arg2, next);
}
static void fast_read_string(lref_t reader, lref_t * retval)
{
lref_t l;
fast_read(reader, &l, false);
if (!FIXNUMP(l))
vmerror_fast_read("strings must have a fixnum length", reader, NIL);
fixnum_t expected_length = FIXNM(l);
_TCHAR *buf = (_TCHAR *) gc_malloc((size_t) (expected_length + 1));
memset(buf, 0, (size_t) (expected_length + 1));
fixnum_t actual_length =
read_bytes(FASL_READER_PORT(reader), buf, (size_t)(expected_length * sizeof(_TCHAR)));
if (actual_length != expected_length) {
gc_free(buf);
vmerror_fast_read("EOF during string data", reader, NIL);
}
*retval = strconsbufn((size_t) actual_length, buf);
gc_free(buf);
}
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("~%");
}
lref_t lstress_c_heap(lref_t c, lref_t s)
{
if (!FIXNUMP(c))
vmerror_wrong_type_n(1, c);
if (!FIXNUMP(s))
vmerror_wrong_type_n(2, s);
fixnum_t count = FIXNM(c);
fixnum_t size = FIXNM(s);
for (fixnum_t i = 0; i < count; i++)
vectorcons(size, NIL);
return NIL;
}
static void fast_read_structure(lref_t reader, lref_t * st)
{
lref_t st_meta;
fast_read(reader, &st_meta, false);
if (!CONSP(st_meta))
vmerror_fast_read("Expected list for structure metadata", reader, st_meta);
lref_t st_length;
fast_read(reader, &st_length, false);
if (!FIXNUMP(st_length))
vmerror_fast_read("Expected fixnum for structure length", reader, st_length);
*st = lstructurecons(vectorcons(FIXNM(st_length), NIL), st_meta);
for (fixnum_t ii = 0; ii < FIXNM(st_length); ii++)
{
lref_t object;
fast_read(reader, &object, false);
if (EOFP(object))
vmerror_fast_read("incomplete structure definition", reader, *st);
SET_STRUCTURE_ELEM(*st, ii, object);
}
}
// 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;
}
// 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
}
static int
plist_get_margin (Lisp_Object plist, Lisp_Object prop, int mm_p)
{
Lisp_Object val =
Fplist_get (plist, prop, make_fixnum (mswindows_get_default_margin (prop)));
if (!FIXNUMP (val))
invalid_argument ("Margin value must be an integer", val);
return MulDiv (XFIXNUM (val), mm_p ? 254 : 100, 144);
}
static size_t get_trap_id(lref_t trap_id)
{
if (!FIXNUMP(trap_id))
vmerror_wrong_type_n(1, trap_id);
size_t id = (size_t)FIXNM(trap_id);
if (id > TRAP_LAST)
vmerror_arg_out_of_range(trap_id, _T("[0,TRAP_LAST]"));
return id;
}
lref_t lstress_lisp_heap(lref_t c)
{
if (!FIXNUMP(c))
vmerror_wrong_type_n(1, c);
fixnum_t count = FIXNM(c);
for (fixnum_t i = 0; i < count; i++)
lcons(NIL, NIL);
return NIL;
}
lref_t lset_debug_flags(lref_t v)
{
if (!FIXNUMP(v))
vmerror_wrong_type_n(1, v);
fixnum_t old_flags = interp.debug_flags;
interp.debug_flags = (enum debug_flag_t) FIXNM(v);
return fixcons(old_flags);
}
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;
}
static fixnum_t fast_read_table_index(lref_t reader)
{
lref_t index;
fast_read(reader, &index, false);
if (!FIXNUMP(index))
vmerror_fast_read("Expected fixnum for FASL table index", reader, index);
if (FIXNM(index) < 0)
vmerror_fast_read("FASL table indicies must be >=0", reader, index);
fasl_ensure_valid_table_index(reader, (size_t) FIXNM(index));
return FIXNM(index);
}
lref_t lstructure_ref(lref_t st, lref_t index)
{
if (!STRUCTUREP(st))
vmerror_wrong_type_n(1, st);
if (!FIXNUMP(index))
vmerror_wrong_type_n(2, index);
fixnum_t idx = get_c_fixnum(index);
if ((idx >= 0) && ((size_t) idx < STRUCTURE_DIM(st)))
return STRUCTURE_ELEM(st, idx);
vmerror_index_out_of_bounds(index, st);
return NIL; // unreached
}
// 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
}
// 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
}
lref_t lstructure_set(lref_t st, lref_t index, lref_t value)
{
if (!STRUCTUREP(st))
vmerror_wrong_type_n(1, st);
if (!FIXNUMP(index))
vmerror_wrong_type_n(2, index);
fixnum_t idx = get_c_fixnum(index);
if ((idx >= 0) && ((size_t) idx < STRUCTURE_DIM(st)))
{
SET_STRUCTURE_ELEM(st, idx, value);
return st;
}
vmerror_index_out_of_bounds(index, st);
return NIL;
}
static void fast_read_vector(lref_t reader, lref_t * vec)
{
lref_t vec_length;
fast_read(reader, &vec_length, false);
if (!FIXNUMP(vec_length))
vmerror_fast_read("Expected fixnum for vector length", reader, vec_length);
*vec = vectorcons(FIXNM(vec_length), NIL);
for (fixnum_t ii = 0; ii < FIXNM(vec_length); ii++)
{
lref_t object;
fast_read(reader, &object, false);
if (EOFP(object))
vmerror_fast_read("incomplete vector definition", reader, *vec);
(*vec)->as.vector.data[ii] = object;
}
}
static void fast_read_loader_application(lref_t reader, enum fasl_opcode_t opcode)
{
assert(FASL_READER_P(reader));
size_t argc = 0;
lref_t argv[FAST_LOAD_STACK_DEPTH];
fast_read(reader, &argv[0], false);
if (!(SUBRP(argv[0]) || CLOSUREP(argv[0])))
vmerror_fast_read(_T("Invalid function to apply"), reader, NIL);
if (opcode == FASL_OP_LOADER_APPLYN)
{
lref_t ac;
fast_read(reader, &ac, false);
if (!FIXNUMP(ac))
vmerror_fast_read("Expected fixnum for loader application argc", reader, ac);
argc = (size_t)FIXNM(ac);
if (argc > FAST_LOAD_STACK_DEPTH) /* Assuming FAST_LOAD_STACK_DEPTH <= ARG_BUF_LEN - 2 */
vmerror_fast_read("Loader application, argc < FAST_LOAD_STACK_DEPTH", reader, ac);
for(size_t ii = 0; ii < argc; ii++)
argv[ii + 1] = fast_loader_stack_pop(reader);
/* Fake a final NIL argument so that we can pass in the argv arguments
* as scalars rather than as a list. */
argc++;
argv[argc] = NIL;
}
else if (opcode != FASL_OP_LOADER_APPLY0)
panic("invalid opcode in fast_read_loader_application");
dscwritef(DF_SHOW_FAST_LOAD_FORMS, (_T("; DEBUG: FASL applying ~s (argc=~cd)\n"), argv[0], argc));
FASL_READER_STREAM(reader)->accum = lapply(argc + 1, argv);
}
static void fast_read_list(lref_t reader, bool read_listd, lref_t * list)
{
*list = NIL;
lref_t list_bud = NIL;
lref_t next_list_cell = NIL;
lref_t list_length;
fast_read(reader, &list_length, false);
if (!FIXNUMP(list_length))
vmerror_fast_read("expected fixnum for list length", reader, list_length);
*list = NIL;
for (fixnum_t ii = 0; ii < FIXNM(list_length); ii++)
{
next_list_cell = lcons(NIL, NIL);
if (NULLP(*list))
*list = next_list_cell;
else
SET_CDR(list_bud, next_list_cell);
list_bud = next_list_cell;
fast_read(reader, &(next_list_cell->as.cons.car), false);
if (EOFP(CAR(next_list_cell)))
vmerror_fast_read("incomplete list definition", reader, NIL);
}
if (read_listd)
{
fast_read(reader, &(list_bud->as.cons.cdr), false);
if (EOFP(CDR(list_bud)))
vmerror_fast_read("incomplete list defintion, missing cdr", reader, NIL);
}
}
// 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
}
// 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
}
static Lisp_Object
get_object_file_name (Lisp_Object filepos)
{
REGISTER int fd;
REGISTER Ibyte *name_nonreloc = 0;
EMACS_INT position;
Lisp_Object file, tem;
Lisp_Object name_reloc = Qnil;
int standard_doc_file = 0;
if (FIXNUMP (filepos))
{
file = Vinternal_doc_file_name;
standard_doc_file = 1;
position = XFIXNUM (filepos);
}
else if (CONSP (filepos) && FIXNUMP (XCDR (filepos)))
{
file = XCAR (filepos);
position = XFIXNUM (XCDR (filepos));
if (position < 0)
position = - position;
}
else
return Qnil;
if (!STRINGP (file))
return Qnil;
/* Put the file name in NAME as a C string.
If it is relative, combine it with Vdoc_directory. */
tem = Ffile_name_absolute_p (file);
if (NILP (tem))
{
Bytecount minsize;
/* XEmacs: Move this check here. OK if called during loadup to
load byte code instructions. */
if (!STRINGP (Vdoc_directory))
return Qnil;
minsize = XSTRING_LENGTH (Vdoc_directory);
/* sizeof ("../lib-src/") == 12 */
if (minsize < 12)
minsize = 12;
name_nonreloc = alloca_ibytes (minsize + XSTRING_LENGTH (file) + 8);
string_join (name_nonreloc, Vdoc_directory, file);
}
else
name_reloc = file;
fd = qxe_open (name_nonreloc ? name_nonreloc :
XSTRING_DATA (name_reloc), O_RDONLY | OPEN_BINARY, 0);
if (fd < 0)
{
if (purify_flag)
{
/* sizeof ("../lib-src/") == 12 */
name_nonreloc = alloca_ibytes (12 + XSTRING_LENGTH (file) + 8);
/* Preparing to dump; DOC file is probably not installed.
So check in ../lib-src. */
qxestrcpy_ascii (name_nonreloc, "../lib-src/");
qxestrcat (name_nonreloc, XSTRING_DATA (file));
fd = qxe_open (name_nonreloc, O_RDONLY | OPEN_BINARY, 0);
}
if (fd < 0)
report_file_error ("Cannot open doc string file",
name_nonreloc ? build_istring (name_nonreloc) :
name_reloc);
}
tem = extract_object_file_name (fd, position, name_nonreloc, name_reloc,
standard_doc_file);
retry_close (fd);
if (!STRINGP (tem))
signal_error_1 (Qinvalid_byte_code, tem);
return tem;
}
