/* Symbol printer.
NB: Uninterned symbols are treated as sharable objects (can be written
with #n= syntax). It is handled by upper layer (write.c) so we don't
worry about it in this routine.
*/
static void symbol_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
if (Scm_WriteContextMode(ctx) == SCM_WRITE_DISPLAY) {
SCM_PUTS(SCM_SYMBOL_NAME(obj), port);
} else {
#if !GAUCHE_UNIFY_SYMBOL_KEYWORD
if (SCM_KEYWORDP(obj)) {
SCM_PUTC(':', port);
/* We basically print keyword names in the same way as symbols
(i.e. using |-escape if necessary). However, as a convention,
two things are different from the default symbol writer.
(1) We don't check the noninitials; :1 is unambiguously a
keyword, so we don't need to print :|1|.
(2) A keyword with an empty name can be printed just as :,
instead of :||.
These conventions are useful if we pass the S-expression with
these keywords to other Scheme implementations that don't support
CL-style keywords; they would just read those ones as symbols.
*/
Scm_WriteSymbolName(SCM_KEYWORD(obj)->name, port, ctx,
(SCM_SYMBOL_WRITER_NOESCAPE_INITIAL
|SCM_SYMBOL_WRITER_NOESCAPE_EMPTY));
return;
}
#endif /*!GAUCHE_UNIFY_SYMBOL_KEYWORD*/
if (!SCM_SYMBOL_INTERNED(obj)) SCM_PUTZ("#:", -1, port);
Scm_WriteSymbolName(SCM_SYMBOL_NAME(obj), port, ctx, 0);
}
}
/* Symbol printer.
NB: Uninterned symbols are treated as sharable objects (can be written
with #n= syntax). It is handled by upper layer (write.c) so we don't
worry about it in this routine.
*/
static void symbol_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
if (Scm_WriteContextMode(ctx) == SCM_WRITE_DISPLAY) {
SCM_PUTS(SCM_SYMBOL_NAME(obj), port);
} else {
if (!SCM_SYMBOL_INTERNED(obj)) SCM_PUTZ("#:", -1, port);
Scm_WriteSymbolName(SCM_SYMBOL_NAME(obj), port, ctx, 0);
}
}
/* If symbol S has a prefix P, returns a symbol without the prefix.
Otherwise, returns #f. */
ScmObj Scm_SymbolSansPrefix(ScmSymbol *s, ScmSymbol *p)
{
const ScmStringBody *bp = SCM_STRING_BODY(SCM_SYMBOL_NAME(p));
const ScmStringBody *bs = SCM_STRING_BODY(SCM_SYMBOL_NAME(s));
int zp = SCM_STRING_BODY_SIZE(bp);
int zs = SCM_STRING_BODY_SIZE(bs);
const char *cp = SCM_STRING_BODY_START(bp);
const char *cs = SCM_STRING_BODY_START(bs);
if (zp > zs || memcmp(cp, cs, zp) != 0) return SCM_FALSE;
return Scm_Intern(SCM_STRING(Scm_MakeString(cs + zp, zs - zp, -1,
SCM_STRING_IMMUTABLE)));
}
/* Symbol comparison procedure.
Will be used via 'compare' procedure. Following srfi-114, we compare
by name, but takes extra care of intern/unintern distinction; if the
names are the same, interned symbol is less, and if both are
uninterned, we compare addresses.
*/
static int symbol_compare(ScmObj x, ScmObj y, int equalp)
{
if (equalp) {
/* Symbol equality test is handled in Scm_Eq* and will never come
here, but just in case. */
return SCM_EQ(x, y)? 0:1;
} else if (SCM_EQ(x, y)) {
return 0;
} else {
int r = Scm_StringCmp(SCM_SYMBOL_NAME(x), SCM_SYMBOL_NAME(y));
if (r != 0) return r;
if (SCM_SYMBOL_INTERNED(x)) return -1; /* y must be uninterned */
if (SCM_SYMBOL_INTERNED(y)) return 1; /* x must be uninterned */
return (x < y)? -1 : 1; /* both are uninterned */
}
}
SCM_EXPORT ScmObj
scm_p_symbol2string(ScmObj sym)
{
DECLARE_FUNCTION("symbol->string", procedure_fixed_1);
ENSURE_SYMBOL(sym);
return CONST_STRING(SCM_SYMBOL_NAME(sym));
}
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);
}
}
/* Auxiliary function */
const char* Scm_GetCESName(ScmObj code, const char *argname)
{
const char *c = NULL;
if (SCM_UNBOUNDP(code) || SCM_FALSEP(code)) {
c = Scm_SupportedCharacterEncodings()[0];
} else if (SCM_STRINGP(code)) {
c = Scm_GetStringConst(SCM_STRING(code));
} else if (SCM_SYMBOLP(code)) {
c = Scm_GetStringConst(SCM_SYMBOL_NAME(code));
} else {
Scm_Error("string, symbol or #f is required for %s, but got %S",
argname, code);
}
return c;
}
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;
}
}
static void
free_cell(ScmCell *cell)
{
#if SCM_USE_STORAGE_COMPACT
if (SCM_CELL_MISCP(*cell)) {
if (SCM_CELL_SYMBOLP(*cell))
SCM_CELL_SYMBOL_FIN(*cell);
#if SCM_USE_STRING
else if (SCM_CELL_STRINGP(*cell))
SCM_CELL_STRING_FIN(*cell);
#endif
#if SCM_USE_VECTOR
else if (SCM_CELL_VECTORP(*cell))
SCM_CELL_VECTOR_FIN(*cell);
#endif
#if SCM_USE_PORT
else if (SCM_CELL_PORTP(*cell))
SCM_CELL_PORT_FIN(*cell);
#endif
#if SCM_USE_CONTINUATION
else if (SCM_CELL_CONTINUATIONP(*cell))
SCM_CELL_CONTINUATION_FIN(*cell);
#endif
}
#else /* SCM_USE_STORAGE_COMPACT */
switch (SCM_TYPE(cell)) {
case ScmCons:
#if SCM_USE_INT
case ScmInt:
#endif
#if SCM_USE_CHAR
case ScmChar:
#endif
break;
case ScmSymbol:
free(SCM_SYMBOL_NAME(cell));
break;
#if SCM_USE_STRING
case ScmString:
free(SCM_STRING_STR(cell));
break;
#endif
case ScmFreeCell:
case ScmConstant:
break;
#if SCM_USE_VECTOR
case ScmVector:
free(SCM_VECTOR_VEC(cell));
break;
#endif
/* rarely swept objects */
#if SCM_USE_PORT
case ScmPort:
if (SCM_PORT_IMPL(cell))
scm_port_close(cell);
break;
#endif
#if SCM_USE_CONTINUATION
case ScmContinuation:
/*
* Since continuation object is not so many, destructing the object by
* function call will not cost high. This function interface makes
* continuation module substitution easy without preparing
* module-specific header file which contains the module-specific
* destruction macro.
*/
scm_destruct_continuation(cell);
break;
#endif
case ScmClosure:
case ScmFunc:
case ScmMacro:
case ScmFarsymbol:
case ScmSubpat:
case ScmCFuncPointer:
case ScmCPointer:
case ScmValuePacket:
break;
#if SCM_DEBUG
case ScmRational:
case ScmReal:
case ScmComplex:
#endif
default:
SCM_NOTREACHED;
}
#endif /* SCM_USE_STORAGE_COMPACT */
}
