static void validate_structure_layout(size_t slots, lref_t layout)
{
if (!CONSP(layout))
vmerror_wrong_type_n(2, layout);
size_t len = (size_t) get_c_long(llength(layout));
if (len != 2)
vmerror_arg_out_of_range(layout, _T("bad structure layout, length<>2"));
lref_t slot_layout = CAR(CDR(layout));
if (get_c_long(llength(slot_layout)) != (long) slots)
vmerror_arg_out_of_range(lcons(slot_layout, fixcons(slots)),
_T("bad structure layout, wrong number of slots"));
for (; CONSP(slot_layout); slot_layout = CDR(slot_layout))
{
if (!CONSP(CAR(slot_layout)))
vmerror_arg_out_of_range(lcons(slot_layout, layout),
_T("bad structure layout, bad slot layout"));
if (!SYMBOLP(CAR(CAR(slot_layout))))
vmerror_arg_out_of_range(layout,
_T("bad structure layout, missing slot name"));
}
}
lref_t lstructure_length(lref_t st)
{
if (!STRUCTUREP(st))
vmerror_wrong_type_n(1, st);
return fixcons(STRUCTURE_DIM(st));
}
lref_t lmemref(lref_t addr)
{
size_t baseaddr = (size_t) get_c_long(addr);
intptr_t *obj = (intptr_t *) baseaddr;
return fixcons((fixnum_t)*obj);
}
static void fast_read_fixnum_int64(lref_t reader, lref_t * retval)
{
fixnum_t data = 0;
if (read_binary_fixnum_int64(FASL_READER_PORT(reader), &data))
*retval = fixcons(data);
else
*retval = lmake_eof();
}
lref_t lifoplog_snapshot()
{
lref_t result = vectorcons(FOPLOG_SIZE, fixcons(-1));
for(int ii = 0; ii < FOPLOG_SIZE; ii++)
SET_VECTOR_ELEM(result, ii, CURRENT_TIB()->foplog[ii]);
return result;
}
lref_t lport_column(lref_t port)
{
if (NULLP(port))
port = CURRENT_INPUT_PORT();
if (!TEXT_PORTP(port))
vmerror_wrong_type_n(1, port);
return fixcons(PORT_TEXT_INFO(port)->col);
}
lref_t vmtrap(enum trap_type_t trap, enum vmt_options_t options, size_t argc, ...)
{
assert((trap > 0) && (trap <= TRAP_LAST));
assert(argc < ARG_BUF_LEN);
dscwritef(DF_SHOW_TRAPS, (_T("; DEBUG: trap : ~cS\n"),
trap_type_name(trap)));
lref_t handler = interp.trap_handlers[trap];
if (!PROCEDUREP(handler))
{
if(!NULLP(handler))
vmtrap_panic(trap, "bad trap handler");
if (!(options & VMT_OPTIONAL_TRAP))
vmtrap_panic(trap, "missing trap handler");
return NIL;
}
lref_t retval = NIL;
va_list args;
va_start(args, argc);
lref_t argv[ARG_BUF_LEN];
argv[0] = fixcons(trap);
argv[1] = fixcons((fixnum_t)CURRENT_TIB()->frame);
for (size_t ii = 2; ii < argc + 2; ii++)
argv[ii] = va_arg(args, lref_t);
va_end(args);
retval = apply1(handler, argc + 2, argv);
if (options & VMT_HANDLER_MUST_ESCAPE)
vmtrap_panic(trap, "trap handler must escape");
return retval;
}
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);
}
lref_t ltime_apply0(lref_t fn)
{
if (!PROCEDUREP(fn))
vmerror_wrong_type_n(1, fn);
flonum_t t = sys_runtime();
flonum_t gc_t = interp.gc_total_run_time;
size_t cells = interp.gc_total_cells_allocated;
size_t fops = CURRENT_TIB()->count_fop;
size_t frames = CURRENT_TIB()->count_enter_frame;
lref_t argv[6];
argv[0] = apply1(fn, 0, NULL);
argv[1] = flocons(sys_runtime() - t);
argv[2] = flocons(interp.gc_total_run_time - gc_t);
argv[3] = fixcons(interp.gc_total_cells_allocated - cells);
argv[4] = fixcons(CURRENT_TIB()->count_fop - fops);
argv[5] = fixcons(CURRENT_TIB()->count_enter_frame - frames);
return lvector(6, argv);
}
lref_t lset_stack_limit(lref_t amount)
{
size_t new_size_limit = 0;
if (!NULLP(amount) && !FALSEP(amount))
new_size_limit = get_c_long(amount);
void *new_limit_obj = sys_set_stack_limit(new_size_limit);
if (!new_size_limit)
{
dscwritef(DF_SHOW_GC, ("stack limit disabled!"));
return boolcons(false);
}
dscwritef(DF_SHOW_GC, ("stack_size = ~cd bytes, [~c&,~c&]\n", new_size_limit, new_limit_obj, sys_get_stack_start()));
return fixcons(new_size_limit);
}
lref_t lheap_cell_count_by_typecode()
{
lref_t obj, org, end;
enum typecode_t type;
lref_t result = NIL;
size_t internal_type_counts[LAST_INTERNAL_TYPEC + 1];
for (size_t ii = 0; ii < LAST_INTERNAL_TYPEC + 1; ii++)
internal_type_counts[ii] = 0;
/* Traverse the heaps, counting each type */
for (size_t heap_no = 0; heap_no < interp.gc_max_heap_segments; heap_no++)
{
if (interp.gc_heap_segments[heap_no] == NULL)
continue;
org = interp.gc_heap_segments[heap_no];
end = org + interp.gc_heap_segment_size;
for (obj = org; obj < end; ++obj)
{
type = TYPE(obj);
internal_type_counts[type]++;
}
}
/* Build the result list */
result = vectorcons(LAST_INTERNAL_TYPEC + 1, NIL);
for (size_t ii = 0; ii <= LAST_INTERNAL_TYPEC; ii++)
result->as.vector.data[ii] = fixcons(internal_type_counts[ii]);
return result;
}
static lref_t execute_fast_op(lref_t fop, lref_t env)
{
lref_t retval = NIL;
lref_t sym;
lref_t binding;
lref_t fn;
lref_t args;
size_t argc;
lref_t argv[ARG_BUF_LEN];
lref_t after;
lref_t tag;
lref_t cell;
lref_t escape_retval;
jmp_buf *jmpbuf;
STACK_CHECK(&fop);
_process_interrupts();
fstack_enter_eval_frame(&fop, fop, env);
while(!NULLP(fop)) {
switch(fop->header.opcode)
{
case FOP_LITERAL:
retval = fop->as.fast_op.arg1;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_REF:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
retval = binding;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_SET:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, retval);
fop = fop->as.fast_op.next;
break;
case FOP_APPLY_GLOBAL:
sym = fop->as.fast_op.arg1;
fn = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(fn))
vmerror_unbound(sym);
argc = 0;
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_APPLY:
argc = 0;
fn = execute_fast_op(fop->as.fast_op.arg1, env);
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_IF_TRUE:
if (TRUEP(retval))
fop = fop->as.fast_op.arg1;
else
fop = fop->as.fast_op.arg2;
break;
case FOP_RETVAL:
fop = fop->as.fast_op.next;
break;
case FOP_SEQUENCE:
retval = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.arg2;
break;
case FOP_THROW:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
escape_retval = execute_fast_op(fop->as.fast_op.arg2, env);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw ~a, retval = ~a\n"), tag, escape_retval));
CURRENT_TIB()->escape_frame = find_matching_escape(CURRENT_TIB()->frame, tag);
CURRENT_TIB()->escape_value = escape_retval;
if (CURRENT_TIB()->escape_frame == NULL) {
/* If we don't find a matching catch for the throw, we have a
* problem and need to invoke a trap. */
vmtrap(TRAP_UNCAUGHT_THROW,
(enum vmt_options_t)(VMT_MANDATORY_TRAP | VMT_HANDLER_MUST_ESCAPE),
2, tag, escape_retval);
}
unwind_stack_for_throw();
fop = fop->as.fast_op.next;
break;
case FOP_CATCH:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
jmpbuf = fstack_enter_catch_frame(tag, CURRENT_TIB()->frame);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: setjmp tag: ~a, frame: ~c&, jmpbuf: ~c&\n"), tag, CURRENT_TIB()->frame, jmpbuf));
if (setjmp(*jmpbuf) == 0) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
} else {
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: catch, retval = ~a\n"), CURRENT_TIB()->escape_value));
retval = CURRENT_TIB()->escape_value;
CURRENT_TIB()->escape_value = NIL;
}
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_WITH_UNWIND_FN:
fstack_enter_unwind_frame(execute_fast_op(fop->as.fast_op.arg1, env));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
after = CURRENT_TIB()->frame[FOFS_UNWIND_AFTER];
fstack_leave_frame();
apply1(after, 0, NULL);
fop = fop->as.fast_op.next;
break;
case FOP_CLOSURE:
retval = lclosurecons(env,
lcons(lcar(fop->as.fast_op.arg1),
fop->as.fast_op.arg2),
lcdr(fop->as.fast_op.arg1));
fop = fop->as.fast_op.next;
break;
case FOP_CAR:
retval = lcar(retval);
fop = fop->as.fast_op.next;
break;
case FOP_CDR:
retval = lcdr(retval);
fop = fop->as.fast_op.next;
break;
case FOP_NOT:
retval = boolcons(!TRUEP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_NULLP:
retval = boolcons(NULLP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_EQP:
retval = boolcons(EQ(execute_fast_op(fop->as.fast_op.arg1, env),
execute_fast_op(fop->as.fast_op.arg2, env)));
fop = fop->as.fast_op.next;
break;
case FOP_GET_ENV:
retval = env;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_DEF: // three args, third was genv, but currently unused
retval = lidefine_global(fop->as.fast_op.arg1, fop->as.fast_op.arg2);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FSP:
retval = fixcons((fixnum_t)CURRENT_TIB()->fsp);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FRAME:
retval = fixcons((fixnum_t)CURRENT_TIB()->frame);
fop = fop->as.fast_op.next;
break;
case FOP_GET_HFRAMES:
retval = CURRENT_TIB()->handler_frames;
fop = fop->as.fast_op.next;
break;
case FOP_SET_HFRAMES:
CURRENT_TIB()->handler_frames = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_PRESERVE_FRAME:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, fixcons((fixnum_t)CURRENT_TIB()->frame));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fop = fop->as.fast_op.next;
break;
case FOP_STACK_BOUNDARY:
sym = execute_fast_op(fop->as.fast_op.arg1, env);
fstack_enter_boundary_frame(sym);
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_FAST_ENQUEUE_CELL:
retval = execute_fast_op(fop->as.fast_op.arg2, env);
cell = execute_fast_op(fop->as.fast_op.arg1, env);
SET_CDR(CAR(retval), cell);
SET_CAR(retval, cell);
fop = fop->as.fast_op.next;
break;
case FOP_WHILE_TRUE:
while(TRUEP(execute_fast_op(fop->as.fast_op.arg1, env))) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
}
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_REF_BY_INDEX:
retval = lenvlookup_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_REF_RESTARG:
retval = lenvlookup_restarg_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_SET_BY_INDEX:
lenvlookup_set_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env,
retval);
fop = fop->as.fast_op.next;
break;
default:
panic("Unsupported fast-op");
}
}
fstack_leave_frame();
return retval;
}
lref_t ldebug_flags()
{
return fixcons(interp.debug_flags);
}
lref_t lobaddr(lref_t object) /* object->address */
{
return fixcons((fixnum_t) object);
}
static void fast_read(lref_t reader, lref_t * retval, bool allow_loader_ops /* = false */ )
{
lref_t *fasl_table_entry = NULL;
*retval = NIL;
if (!FASL_READER_P(reader))
vmerror_wrong_type_n(1, reader);
assert(NULLP(FASL_READER_STREAM(reader)->table) || VECTORP(FASL_READER_STREAM(reader)->table));
/* The core of this function is wrapped in a giant while loop to remove
* tail recursive calls. Some opcodes don't directly return anything:
* they just tail recursively read the next opcode after performing their
* action via side effect. */
bool current_read_complete = false;
while (!current_read_complete)
{
/* Assume we're going to complete the read unless we find out otherwise.. */
current_read_complete = true;
size_t opcode_location = PORT_BYTES_READ(FASL_READER_PORT(reader));
enum fasl_opcode_t opcode = fast_read_opcode(reader);
fixnum_t index = 0;
lref_t name;
if (DEBUG_FLAG(DF_FASL_SHOW_OPCODES))
{
const _TCHAR *opcode_name = fasl_opcode_name(opcode);
dscwritef(DF_FASL_SHOW_OPCODES,
(_T("; DEBUG: fasl-opcode@~cx :~cS\n"),
opcode_location, opcode_name ? opcode_name : _T("<INVALID>")));
}
switch (opcode)
{
case FASL_OP_NIL:
*retval = NIL;
break;
case FASL_OP_TRUE:
*retval = boolcons(true);
break;
case FASL_OP_FALSE:
*retval = boolcons(false);
break;
case FASL_OP_CHARACTER:
fast_read_character(reader, retval);
break;
case FASL_OP_LIST:
fast_read_list(reader, false, retval);
break;
case FASL_OP_LISTD:
fast_read_list(reader, true, retval);
break;
case FASL_OP_FIX8:
fast_read_fixnum_int8(reader, retval);
break;
case FASL_OP_FIX16:
fast_read_fixnum_int16(reader, retval);
break;
case FASL_OP_FIX32:
fast_read_fixnum_int32(reader, retval);
break;
case FASL_OP_FIX64:
fast_read_fixnum_int64(reader, retval);
break;
case FASL_OP_FLOAT:
fast_read_flonum(reader, false, retval);
break;
case FASL_OP_COMPLEX:
fast_read_flonum(reader, true, retval);
break;
case FASL_OP_STRING:
fast_read_string(reader, retval);
break;
case FASL_OP_PACKAGE:
fast_read_package(reader, retval);
break;
case FASL_OP_VECTOR:
fast_read_vector(reader, retval);
break;
case FASL_OP_HASH:
fast_read_hash(reader, retval);
break;
case FASL_OP_CLOSURE:
fast_read_closure(reader, retval);
break;
case FASL_OP_MACRO:
fast_read_macro(reader, retval);
break;
case FASL_OP_SYMBOL:
fast_read_symbol(reader, retval);
break;
case FASL_OP_SUBR:
fast_read_subr(reader, retval);
break;
case FASL_OP_STRUCTURE:
fast_read_structure(reader, retval);
break;
case FASL_OP_STRUCTURE_LAYOUT:
fast_read_structure_layout(reader, retval);
break;
case FASL_OP_FAST_OP_0:
fast_read_fast_op(0, false, reader, retval);
break;
case FASL_OP_FAST_OP_1:
fast_read_fast_op(1, false, reader, retval);
break;
case FASL_OP_FAST_OP_2:
fast_read_fast_op(2, false, reader, retval);
break;
case FASL_OP_FAST_OP_0N:
fast_read_fast_op(0, true, reader, retval);
break;
case FASL_OP_FAST_OP_1N:
fast_read_fast_op(1, true, reader, retval);
break;
case FASL_OP_FAST_OP_2N:
fast_read_fast_op(2, true, reader, retval);
break;
case FASL_OP_NOP_1:
case FASL_OP_NOP_2:
case FASL_OP_NOP_3:
current_read_complete = false;
break;
case FASL_OP_COMMENT_1:
case FASL_OP_COMMENT_2:
fast_read_to_newline(reader);
current_read_complete = false;
break;
case FASL_OP_RESET_READER_DEFS:
FASL_READER_STREAM(reader)->table = NIL;
current_read_complete = false;
break;
case FASL_OP_READER_DEFINITION:
index = fast_read_table_index(reader);
fasl_table_entry = &(FASL_READER_STREAM(reader)->table->as.vector.data[index]);
fast_read(reader, fasl_table_entry, allow_loader_ops);
/* This should throw if the FASL table was resized
* during the call to read. */
assert(fasl_table_entry == &(FASL_READER_STREAM(reader)->table->as.vector.data[index]));
*retval = *fasl_table_entry;
break;
case FASL_OP_READER_REFERENCE:
index = fast_read_table_index(reader);
*retval = FASL_READER_STREAM(reader)->table->as.vector.data[index];
break;
case FASL_OP_EOF:
*retval = lmake_eof();
break;
case FASL_OP_LOADER_DEFINEQ:
case FASL_OP_LOADER_DEFINEA0:
if (!allow_loader_ops)
vmerror_fast_read(_T("loader definitions not allowed outside loader"), reader, NIL);
fast_read_loader_definition(reader, opcode);
current_read_complete = false;
break;
case FASL_OP_LOADER_APPLY0:
case FASL_OP_LOADER_APPLYN:
if (!allow_loader_ops)
vmerror_fast_read(_T("loader function applications not allowed outside loader"), reader, NIL);
fast_read_loader_application(reader, opcode);
break;
case FASL_OP_BEGIN_LOAD_UNIT:
if (!allow_loader_ops)
vmerror_fast_read(_T("load units are not allowed outside loader"), reader, NIL);
fast_read(reader, &name, allow_loader_ops);
dscwritef(DF_SHOW_FAST_LOAD_UNITS, ("; DEBUG: FASL entering unit ~s\n", name));
break;
case FASL_OP_END_LOAD_UNIT:
if (!allow_loader_ops)
vmerror_fast_read(_T("load units are not allowed outside loader"), reader, NIL);
fast_read(reader, &name, allow_loader_ops);
dscwritef(DF_SHOW_FAST_LOAD_UNITS, ("; DEBUG: FASL leaving unit ~s\n", name));
break;
case FASL_OP_LOADER_PUSH:
fast_loader_stack_push(reader, FASL_READER_STREAM(reader)->accum);
break;
case FASL_OP_LOADER_DROP:
fast_loader_stack_pop(reader);
break;
default:
vmerror_fast_read("invalid opcode", reader, fixcons(opcode));
}
}
}
/* A C function to do Lisp-style Formatted I/O ******************
*
* ~s - write the lisp object
* ~a - display the lisp object
* REVISIT: remove scvwritef ~u in favor of some kind of print_unreadable_object call
* ~u - display the lisp object in unprintable fashion (ie. <type@addr...>
*
* ~cs - display the C string
* ~cS - display the C string/arglist with a recursive call to scvwritef
* ~cd - display the C integer
* ~cf - display the C flonum
* ~c& - display the C pointer
* ~cc - display the C character
* ~cC - display the C integer as an octal character constant
* ~cB - display the C integer as a byte
*
* Prefixing a format code with a #\! (ie. ~!L) causes the corresponding
* value to be returned from the function as a Lisp object.
*/
lref_t scvwritef(const _TCHAR * format_str, lref_t port, va_list arglist)
{
char ch;
if (NULLP(port))
port = CURRENT_OUTPUT_PORT();
assert(PORTP(port));
_TCHAR buf[STACK_STRBUF_LEN];
lref_t lisp_arg_value = NULL;
_TCHAR *str_arg_value = NULL;
_TCHAR char_arg_value = _T('\0');
long int long_arg_value = 0;
unsigned long int ulong_arg_value = 0;
flonum_t flonum_arg_value = 0.0;
lref_t unprintable_object = NIL;
lref_t return_value = NIL;
for (;;)
{
ch = *format_str;
if (ch == '\0')
break;
bool return_next_value = false;
format_str++;
if (ch != '~')
{
write_char(port, ch);
continue;
}
ch = *format_str;
format_str++;
if (ch == '!')
{
ch = *format_str;
format_str++;
return_next_value = true;
}
switch (ch)
{
case 's':
lisp_arg_value = va_arg(arglist, lref_t);
if (return_next_value)
return_value = lisp_arg_value;
debug_print_object(lisp_arg_value, port, true);
break;
case 'a':
lisp_arg_value = va_arg(arglist, lref_t);
if (return_next_value)
return_value = lisp_arg_value;
debug_print_object(lisp_arg_value, port, false);
break;
case 'u':
unprintable_object = va_arg(arglist, lref_t);
if (return_next_value)
return_value = unprintable_object;
if (DEBUG_FLAG(DF_PRINT_FOR_DIFF))
scwritef("#<~cs@(no-addr)", port, typecode_name(TYPE(unprintable_object)));
else
scwritef("#<~cs@~c&", port,
typecode_name(TYPE(unprintable_object)), unprintable_object);
break;
case '~':
write_char(port, '~');
break;
case 'c': /* C object prefix */
ch = *format_str; /* read the next format character */
format_str++;
switch (ch)
{
case 's':
str_arg_value = va_arg(arglist, _TCHAR *);
if (return_next_value)
return_value = strconsbuf(str_arg_value);
if (str_arg_value)
write_text(port, str_arg_value, _tcslen(str_arg_value));
else
WRITE_TEXT_CONSTANT(port, _T("<null>"));
break;
case 'S':
str_arg_value = va_arg(arglist, _TCHAR *);
if (return_next_value)
return_value = scvwritef(str_arg_value, port, arglist);
else
scvwritef(str_arg_value, port, arglist);
break;
case 'd':
long_arg_value = va_arg(arglist, long int);
if (return_next_value)
return_value = fixcons(long_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%d"), (int) long_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case 'x':
long_arg_value = va_arg(arglist, long int);
if (return_next_value)
return_value = fixcons(long_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%08lx"), long_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case 'f':
flonum_arg_value = va_arg(arglist, flonum_t);
if (return_next_value)
return_value = flocons(flonum_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%f"), flonum_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case '&':
_sntprintf(buf, STACK_STRBUF_LEN, _T("%p"), (void *) va_arg(arglist, void *));
if (return_next_value)
return_value = strconsbuf(buf);
write_text(port, buf, _tcslen(buf));
break;
case 'c':
ulong_arg_value = va_arg(arglist, unsigned long int);
if (return_next_value)
return_value = fixcons(ulong_arg_value);
char_arg_value = (_TCHAR) ulong_arg_value;
write_text(port, &char_arg_value, 1);
break;
case 'C':
ulong_arg_value = va_arg(arglist, unsigned long int);
if (return_next_value)
return_value = fixcons(ulong_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("%03o"), (uint32_t) ulong_arg_value);
write_text(port, buf, _tcslen(buf));
break;
case 'B':
ulong_arg_value = va_arg(arglist, unsigned long int);
if (return_next_value)
return_value = fixcons(ulong_arg_value);
_sntprintf(buf, STACK_STRBUF_LEN, _T("0x%02x"), (uint32_t) ulong_arg_value);
write_text(port, buf, _tcslen(buf));
break;
default:
panic(_T("Invalid C object format character in scwritef"));
break;
};
break;
default:
panic(_T("Invalid format character in scwritef"));
break;
}
return_next_value = false;
}
va_end(arglist);
if (!NULLP(unprintable_object))
scwritef(">", port);
return return_value;
}
