lref_t lnewline(lref_t port)
{
if (NULLP(port))
port = CURRENT_OUTPUT_PORT();
if (!TEXT_PORTP(port))
vmerror_wrong_type_n(1, port);
if (PORT_INPUTP(port))
vmerror_unsupported(_T("cannot newline to input ports"));
write_char(port, _T('\n'));
return port;
}
lref_t lfresh_line(lref_t port)
{
if (NULLP(port))
port = CURRENT_OUTPUT_PORT();
if (!TEXT_PORTP(port))
vmerror_wrong_type_n(1, port);
if (PORT_INPUTP(port))
vmerror_unsupported(_T("cannot fresh-line to input ports"));
if ((PORT_TEXT_INFO(port)->col != 0) && !PORT_TEXT_INFO(port)->needs_lf) {
lnewline(port);
return boolcons(true);
}
return boolcons(false);
}
lref_t lwrite_char(lref_t ch, lref_t port)
{
if (NULLP(port))
port = CURRENT_OUTPUT_PORT();
if (!TEXT_PORTP(port))
vmerror_wrong_type_n(2, port);
if (PORT_INPUTP(port))
vmerror_unsupported(_T("cannot write-char to input ports"));
if (!CHARP(ch))
vmerror_wrong_type_n(1, ch);
write_char(port, CHARV(ch));
return port;
}
lref_t lrich_write(lref_t obj, lref_t machine_readable, lref_t port)
{
if (NULLP(port))
port = CURRENT_OUTPUT_PORT();
if (!PORTP(port))
vmerror_wrong_type_n(3, port);
if (PORT_INPUTP(port))
vmerror_unsupported(_T("cannot rich-write to input ports"));
if (PORT_CLASS(port)->rich_write == NULL)
return boolcons(false);
if (PORT_CLASS(port)->rich_write(port, obj, TRUEP(machine_readable)))
return port;
return boolcons(false);
}
/* 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;
}
