static void
write_char(ScmObj port, ScmObj obj, enum ScmOutputType otype)
{
const ScmSpecialCharInfo *info;
scm_ichar_t c;
c = SCM_CHAR_VALUE(obj);
switch (otype) {
case AS_WRITE:
scm_port_puts(port, "#\\");
/* special chars */
for (info = scm_special_char_table; info->esc_seq; info++) {
if (c == info->code) {
scm_port_puts(port, info->lex_rep);
return;
}
}
/* other control chars are printed in hexadecimal form */
if (ICHAR_CONTROLP(c)) {
scm_format(port, SCM_FMT_RAW_C, "x~02MX", (scm_int_t)c);
return;
}
/* FALLTHROUGH */
case AS_DISPLAY:
scm_port_put_char(port, c);
break;
default:
SCM_NOTREACHED;
}
}
static void
scm_error_internal(const char *func_name, ScmObj obj,
const char *msg, va_list args)
{
ScmObj reason, err_obj;
if (l_error_looped)
scm_fatal_error("bug: double error on preparing error object");
/* It is supposed that no continuation switching occurs on this guarded
* duration. So the global variable based guard works properly. */
l_error_looped = scm_true;
#if (SCM_USE_FORMAT && SCM_USE_SRFI6)
reason = scm_vformat(SCM_FALSE, SCM_FMT_INTERNAL, msg, args);
if (func_name) {
reason = scm_format(SCM_FALSE, SCM_FMT_RAW_C,
"in ~S: ~S~S",
func_name, SCM_STRING_STR(reason),
(EQ(obj, NO_ERR_OBJ) ? "" : ":"));
}
#else
reason = CONST_STRING(msg);
#endif
err_obj = scm_make_error_obj(reason,
(EQ(obj, NO_ERR_OBJ)) ? SCM_NULL : LIST_1(obj));
l_error_looped = scm_false;
scm_raise_error(err_obj);
/* NOTREACHED */
}
static void
show_arg(ScmObj arg, ScmObj env)
{
if (SYMBOLP(arg) && !UNBOUNDP(arg, env)) {
scm_format(scm_err, SCM_FMT_RAW_C, " - [~S]: ", SCM_SYMBOL_NAME(arg));
SCM_WRITE_SS(scm_err, scm_symbol_value(arg, env));
scm_port_newline(scm_err);
}
}
SCM_EXPORT void
scm_die(const char *msg, const char *filename, int line)
{
#if SCM_DEBUG
ScmObj reason;
/* reason will implicitly be freed via the object on GC */
reason = scm_format(SCM_FALSE, SCM_FMT_RAW_C,
"~S: (file: ~S, line: ~D)", msg, filename, line);
scm_fatal_error(SCM_STRING_STR(reason));
#else
scm_fatal_error(msg);
#endif
/* NOTREACHED */
}
TEST(format, format)
{
ScmObj actual = SCM_OBJ_INIT, expected = SCM_OBJ_INIT;
ScmObj format = SCM_OBJ_INIT, arg[2] = { SCM_OBJ_INIT, SCM_OBJ_INIT };
SCM_REFSTK_INIT_REG(&actual, &expected, &format);
SCM_REFSTK_REG_ARY(arg, 2);
format = ut_read_cstr("\"[~a] [~s] [~~] [~%]\"");
arg[0] = arg[1] = ut_read_cstr("\"foo\"");
expected = ut_read_cstr("\"[foo] [\\\"foo\\\"] [~] [\\n]\"");
actual = scm_format(format, arg[0], arg[1], SCM_OBJ_NULL);
TEST_ASSERT_SCM_TRUE(scm_string_eq_P(expected, actual));
}
static void
write_string(ScmObj port, ScmObj obj, enum ScmOutputType otype)
{
#if SCM_USE_MULTIBYTE_CHAR
ScmCharCodec *codec;
ScmMultibyteString mbs;
size_t len;
#else
scm_int_t i, len;
#endif
const ScmSpecialCharInfo *info;
const char *str;
scm_ichar_t c;
DECLARE_INTERNAL_FUNCTION("write");
str = SCM_STRING_STR(obj);
switch (otype) {
case AS_WRITE:
scm_port_put_char(port, '\"'); /* opening doublequote */
#if SCM_USE_MULTIBYTE_CHAR
if (scm_current_char_codec != scm_port_codec(port)) {
/* Since the str does not have its encoding information, here
* assumes that scm_current_char_codec is that. And then SigScheme
* does not have an encoding conversion mechanism, puts it
* as-is. */
scm_port_puts(port, str);
} else {
len = strlen(str);
codec = scm_port_codec(port);
SCM_MBS_INIT2(mbs, str, len);
while (SCM_MBS_GET_SIZE(mbs)) {
c = SCM_CHARCODEC_READ_CHAR(codec, mbs);
#else /* SCM_USE_MULTIBYTE_CHAR */
len = SCM_STRING_LEN(obj);
for (i = 0; i < len; i++) {
c = str[i];
#endif /* SCM_USE_MULTIBYTE_CHAR */
for (info = scm_special_char_table; info->esc_seq; info++) {
if (c == info->code) {
scm_port_puts(port, info->esc_seq);
goto continue2;
}
}
scm_port_put_char(port, c);
continue2:
;
}
#if SCM_USE_MULTIBYTE_CHAR
}
#endif
scm_port_put_char(port, '\"'); /* closing doublequote */
break;
case AS_DISPLAY:
scm_port_puts(port, str);
break;
default:
SCM_NOTREACHED;
}
}
#endif /* SCM_USE_STRING */
static void
write_list(ScmObj port, ScmObj lst, enum ScmOutputType otype)
{
ScmObj car;
#if SCM_USE_SRFI38
size_t necessary_close_parens;
scm_intobj_t index;
#endif
DECLARE_INTERNAL_FUNCTION("write");
#if SCM_USE_SRFI38
necessary_close_parens = 1;
cheap_recursion:
#endif
SCM_ASSERT(CONSP(lst));
scm_port_put_char(port, '(');
FOR_EACH (car, lst) {
write_obj(port, car, otype);
if (!CONSP(lst))
break;
scm_port_put_char(port, ' ');
#if SCM_USE_SRFI38
/* See if the next pair is shared. Note that the case
* where the first pair is shared is handled in
* write_obj(). */
index = get_shared_index(lst);
if (index > 0) {
/* defined datum */
scm_format(port, SCM_FMT_RAW_C, ". #~ZU#", (size_t)index);
goto close_parens_and_return;
}
if (index < 0) {
/* defining datum, with the new index negated */
scm_format(port, SCM_FMT_RAW_C, ". #~ZU=", (size_t)-index);
necessary_close_parens++;
goto cheap_recursion;
}
#endif
}
static void
write_obj(ScmObj port, ScmObj obj, enum ScmOutputType otype)
{
ScmObj sym;
#if SCM_USE_SRFI38
if (INTERESTINGP(obj)) {
scm_intobj_t index = get_shared_index(obj);
if (index > 0) {
/* defined datum */
scm_format(port, SCM_FMT_RAW_C, "#~ZU#", (size_t)index);
return;
}
if (index < 0) {
/* defining datum, with the new index negated */
scm_format(port, SCM_FMT_RAW_C, "#~ZU=", (size_t)-index);
/* Print it; the next time it'll be defined. */
}
}
#endif
switch (SCM_TYPE(obj)) {
#if SCM_USE_INT
case ScmInt:
scm_format(port, SCM_FMT_RAW_C, "~MD", SCM_INT_VALUE(obj));
break;
#endif
case ScmCons:
if (ERROBJP(obj))
write_errobj(port, obj, otype);
else
write_list(port, obj, otype);
break;
case ScmSymbol:
scm_port_puts(port, SCM_SYMBOL_NAME(obj));
break;
#if SCM_USE_CHAR
case ScmChar:
write_char(port, obj, otype);
break;
#endif
#if SCM_USE_STRING
case ScmString:
write_string(port, obj, otype);
break;
#endif
case ScmFunc:
scm_port_puts(port, (SCM_SYNTAXP(obj)) ? "#<syntax " : "#<subr ");
sym = scm_symbol_bound_to(obj);
if (TRUEP(sym))
scm_display(port, sym);
else
scm_format(port, SCM_FMT_RAW_C, "~P", (void *)obj);
scm_port_put_char(port, '>');
break;
#if SCM_USE_HYGIENIC_MACRO
case ScmMacro:
scm_port_puts(port, "#<macro ");
write_obj(port, SCM_HMACRO_RULES(obj), otype);
scm_port_puts(port, ">");
break;
case ScmFarsymbol:
write_farsymbol(port, obj, otype);
break;
case ScmSubpat:
if (SCM_SUBPAT_PVARP(obj)) {
#if SCM_DEBUG_MACRO
scm_port_puts(port, "#<pvar ");
write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
scm_format(port, SCM_FMT_RAW_C, " ~MD>",
SCM_SUBPAT_PVAR_INDEX(obj));
#else /* not SCM_DEBUG_MACRO */
write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
#endif /* not SCM_DEBUG_MACRO */
} else {
SCM_ASSERT(SCM_SUBPAT_REPPATP(obj));
write_obj(port, SCM_SUBPAT_REPPAT_PAT(obj), otype);
#if SCM_DEBUG_MACRO
scm_format(port, SCM_FMT_RAW_C, " ..[~MD]..",
SCM_SUBPAT_REPPAT_PVCOUNT(obj));
#else
scm_port_puts(port, " ...");
#endif
}
break;
#endif /* SCM_USE_HYGIENIC_MACRO */
case ScmClosure:
#if SCM_USE_LEGACY_MACRO
if (SYNTACTIC_CLOSUREP(obj))
scm_port_puts(port, "#<syntactic closure ");
else
#endif
scm_port_puts(port, "#<closure ");
write_obj(port, SCM_CLOSURE_EXP(obj), otype);
scm_port_put_char(port, '>');
break;
#if SCM_USE_VECTOR
case ScmVector:
write_vector(port, obj, otype);
break;
#endif
case ScmPort:
write_port(port, obj, otype);
break;
#if SCM_USE_CONTINUATION
case ScmContinuation:
scm_format(port, SCM_FMT_RAW_C, "#<continuation ~P>", (void *)obj);
break;
#endif
case ScmValuePacket:
scm_port_puts(port, "#<values ");
write_obj(port, SCM_VALUEPACKET_VALUES(obj), otype);
#if SCM_USE_VALUECONS
#if SCM_USE_STORAGE_FATTY
/* SCM_VALUEPACKET_VALUES() changes the type destructively */
SCM_ENTYPE(obj, ScmValuePacket);
#else /* SCM_USE_STORAGE_FATTY */
#error "valuecons is not supported on this storage implementation"
#endif /* SCM_USE_STORAGE_FATTY */
#endif /* SCM_USE_VALUECONS */
scm_port_put_char(port, '>');
break;
case ScmConstant:
write_constant(port, obj, otype);
break;
#if SCM_USE_SSCM_EXTENSIONS
case ScmCPointer:
scm_format(port, SCM_FMT_RAW_C,
"#<c_pointer ~P>", SCM_C_POINTER_VALUE(obj));
break;
case ScmCFuncPointer:
scm_format(port, SCM_FMT_RAW_C,
"#<c_func_pointer ~P>",
(void *)(uintptr_t)SCM_C_FUNCPOINTER_VALUE(obj));
break;
#endif
case ScmRational:
case ScmReal:
case ScmComplex:
default:
SCM_NOTREACHED;
}
}
