/* 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 */ }