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; } }