static void cv_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
ScmConditionVariable *cv = SCM_CONDITION_VARIABLE(obj);
ScmObj name = cv->name;
if (SCM_FALSEP(name)) Scm_Printf(port, "#<condition-variable %p>", cv);
else Scm_Printf(port, "#<condition-variable %S>", name);
}
static void tls_print(ScmObj obj, ScmPort* port, ScmWriteContext* ctx)
{
Scm_Printf(port, "#<TLS");
/* at the moment there's not much to print, so we leave this hole
for future development. */
Scm_Printf(port, ">");
}
static void promise_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
ScmPromise *p = (ScmPromise*)obj;
const char *forced = p->content->forced? " (forced)" : "";
if (SCM_FALSEP(p->kind)) {
Scm_Printf(port, "#<promise %p%s>", p, forced);
} else {
Scm_Printf(port, "#<promise(%S) %p%s>", p->kind, p, forced);
}
}
/* Error handling */
void error_exit(ScmObj c)
{
ScmObj m = Scm_ConditionMessage(c);
if (SCM_FALSEP(m)) {
Scm_Printf(SCM_CURERR, "gosh: Thrown unknown condition: %S\n", c);
} else {
Scm_Printf(SCM_CURERR, "gosh: %S: %A\n", Scm_ConditionTypeName(c), m);
}
Scm_Exit(1);
}
static void synrule_print(ScmObj obj, ScmPort *port, ScmWriteContext *mode)
{
ScmSyntaxRules *r = SCM_SYNTAX_RULES(obj);
Scm_Printf(port, "#<syntax-rules(%d)\n", r->numRules);
for (int i = 0; i < r->numRules; i++) {
Scm_Printf(port, "%2d: (numPvars=%d, maxLevel=%d)\n",
i, r->rules[i].numPvars, r->rules[i].maxLevel);
Scm_Printf(port, " pattern = %S\n", r->rules[i].pattern);
Scm_Printf(port, " template = %S\n", r->rules[i].template);
/* for debug */
static void dump_traverse(Node *node, int depth, ScmPort *out, int scmobj)
{
if (node->left) dump_traverse(node->left, depth+1, out, scmobj);
for (int i=0; i<depth; i++) Scm_Printf(out, " ");
if (scmobj) {
Scm_Printf(out, "%c:%S => %S\n", BLACKP(node)?'B':'R',
SCM_OBJ(node->key), SCM_OBJ(node->value));
} else {
Scm_Printf(out, "%c:%08x => %08x\n", BLACKP(node)?'B':'R',
node->key, node->value);
}
if (node->right) dump_traverse(node->right, depth+1, out, scmobj);
}
static void socket_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
ScmSocket *sock = SCM_SOCKET(obj);
Scm_Printf(port, "#<socket");
switch (sock->status) {
case SCM_SOCKET_STATUS_NONE:
break;
case SCM_SOCKET_STATUS_BOUND:
Scm_Printf(port, " (bound %S)", Scm_SockAddrName(sock->address));
break;
case SCM_SOCKET_STATUS_LISTENING:
Scm_Printf(port, " (listen %S)", Scm_SockAddrName(sock->address));
break;
case SCM_SOCKET_STATUS_CONNECTED:
Scm_Printf(port, " (connect %S)", Scm_SockAddrName(sock->address));
break;
case SCM_SOCKET_STATUS_SHUTDOWN:
Scm_Printf(port, " (shutdown)");
break;
case SCM_SOCKET_STATUS_CLOSED:
Scm_Printf(port, " (closed)");
break;
default:
Scm_Printf(port, " (unknown status)");
break;
}
Scm_Printf(port, ">");
}
void Scm_CharSetDump(ScmCharSet *cs, ScmPort *port)
{
Scm_Printf(port, "CharSet %p\nmask:", cs);
for (int i=0; i<SCM_BITS_NUM_WORDS(SCM_CHAR_SET_SMALL_CHARS); i++) {
#if SIZEOF_LONG == 4
Scm_Printf(port, "[%08lx]", cs->small[i]);
#else
Scm_Printf(port, "[%016lx]", cs->small[i]);
#endif
}
Scm_Printf(port, "\nranges:");
Scm_TreeCoreDump(&cs->large, port);
Scm_Printf(port, "\n");
}
static void message_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
ScmClass *k = Scm_ClassOf(obj);
Scm_Printf(port, "#<%A \"%30.1A\">",
Scm__InternalClassName(k),
SCM_ERROR_MESSAGE(obj));
}
static ScmObj conv_name(int dir, ScmPort *remote, const char *from, const char *to)
{
ScmObj out = Scm_MakeOutputStringPort(TRUE);
Scm_Printf(SCM_PORT(out), "[conv(%s->%s) %s %S]",
from, to, (dir == SCM_PORT_INPUT? "from" : "to"),
Scm_PortName(remote));
return Scm_GetOutputStringUnsafe(SCM_PORT(out), 0);
}
void Scm_TreeCoreDump(ScmTreeCore *tc, ScmPort *out)
{
Node *r = ROOT(tc);
Scm_Printf(out, "Entries=%d\n", tc->num_entries);
if (r) {
dump_traverse(r, 0, out, FALSE);
}
}
static void vport_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
Scm_Printf(port, "#<%A%s %A %p>",
Scm__InternalClassName(Scm_ClassOf(obj)),
SCM_PORT_CLOSED_P(obj)? "(closed)" : "",
Scm_PortName(SCM_PORT(obj)),
obj);
}
static void pattern_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
Scm_Printf(port, "#<pattern:%d%S %S%s>",
SCM_SYNTAX_PATTERN(obj)->level,
SCM_SYNTAX_PATTERN(obj)->vars,
SCM_SYNTAX_PATTERN(obj)->pattern,
SCM_SYNTAX_PATTERN(obj)->numFollowingItems? " ..." : "");
}
void Scm_TreeMapDump(ScmTreeMap *tm, ScmPort *out)
{
ScmTreeCore *tc = SCM_TREE_MAP_CORE(tm);
Node *r = ROOT(tc);
Scm_Printf(out, "Entries=%d\n", tc->num_entries);
if (r) {
dump_traverse(r, 0, out, TRUE);
}
}
static void csint_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx)
{
CSint *vint = CSINT_UNBOX(obj);
char *vname = cs_getName(vint);
int min, max;
min = cs_getMin(vint);
max = cs_getMax(vint);
if (vname) {
if (min == max) {
Scm_Printf(out, "#<csint \"%s\" {%d}>", vname, min);
} else {
Scm_Printf(out, "#<csint \"%s\" {%d..%d}>", vname, min, max);
}
} else {
if (min == max) {
Scm_Printf(out, "#<csint {%d}>", min);
} else {
Scm_Printf(out, "#<csint {%d..%d}>", min, max);
}
}
}
static void mutex_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
ScmMutex *mutex = SCM_MUTEX(obj);
(void)SCM_INTERNAL_MUTEX_LOCK(mutex->mutex);
int locked = mutex->locked;
ScmVM *vm = mutex->owner;
ScmObj name = mutex->name;
(void)SCM_INTERNAL_MUTEX_UNLOCK(mutex->mutex);
if (SCM_FALSEP(name)) Scm_Printf(port, "#<mutex %p ", mutex);
else Scm_Printf(port, "#<mutex %S ", name);
if (locked) {
if (vm) {
if (vm->state == SCM_VM_TERMINATED) {
Scm_Printf(port, "unlocked/abandoned>");
} else {
Scm_Printf(port, "locked/owned by %S>", vm);
}
} else {
Scm_Printf(port, "locked/not-owned>");
}
} else {
Scm_Printf(port, "unlocked/not-abandoned>");
}
}
static void gloc_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
ScmGloc *g = SCM_GLOC(obj);
Scm_Printf(port, "#<gloc %S#%S%s>", g->module->name,
g->name,
(Scm_GlocConstP(g)
? " const"
: (Scm_GlocInlinableP(g)
? " inlinable"
: (SCM_GLOC_PHANTOM_BINDING_P(g)
? " phantom"
: ""))));
}
/* Default method for write-object */
static ScmObj write_object_fallback(ScmObj *args, int nargs, ScmGeneric *gf)
{
if (nargs != 2 || (nargs == 2 && !SCM_OPORTP(args[1]))) {
Scm_Error("No applicable method for write-object with %S",
Scm_ArrayToList(args, nargs));
}
ScmClass *klass = Scm_ClassOf(args[0]);
Scm_Printf(SCM_PORT(args[1]), "#<%A%s%p>",
klass->name,
(SCM_FALSEP(klass->redefined)? " " : ":redefined "),
args[0]);
return SCM_TRUE;
}
static void charset_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx)
{
int prev, code, first = TRUE;
ScmCharSet *cs = SCM_CHAR_SET(obj);
Scm_Printf(out, "#[");
for (prev = -1, code = 0; code < SCM_CHAR_SET_SMALL_CHARS; code++) {
if (MASK_ISSET(cs, code) && prev < 0) {
charset_print_ch(out, code, first);
prev = code;
first = FALSE;
}
else if (!MASK_ISSET(cs, code) && prev >= 0) {
if (code - prev > 1) {
if (code - prev > 2) Scm_Printf(out, "-");
charset_print_ch(out, code-1, FALSE);
}
prev = -1;
}
}
if (prev >= 0) {
if (code - prev > 1) {
if (prev < 0x7e) Scm_Printf(out, "-");
charset_print_ch(out, code-1, FALSE);
}
}
ScmTreeIter iter;
ScmDictEntry *e;
Scm_TreeIterInit(&iter, &cs->large, NULL);
while ((e = Scm_TreeIterNext(&iter)) != NULL) {
charset_print_ch(out, (int)e->key, FALSE);
if (e->value != e->key) {
if (e->value - e->key > 2) Scm_Printf(out, "-");
charset_print_ch(out, (int)e->value, FALSE);
}
}
Scm_Printf(out, "]");
}
static void charset_print_ch(ScmPort *out, ScmChar ch, int firstp)
{
if (ch != 0 && ch < 0x80
&& (strchr("[]-\\", ch) != NULL || (ch == '^' && firstp))) {
Scm_Printf(out, "\\%C", ch);
} else {
switch (Scm_CharGeneralCategory(ch)) {
case SCM_CHAR_CATEGORY_Mn:
case SCM_CHAR_CATEGORY_Mc:
case SCM_CHAR_CATEGORY_Me:
case SCM_CHAR_CATEGORY_Cc:
case SCM_CHAR_CATEGORY_Cf:
case SCM_CHAR_CATEGORY_Cs:
case SCM_CHAR_CATEGORY_Co:
case SCM_CHAR_CATEGORY_Cn:
if (ch < 0x10000) Scm_Printf(out, "\\u%04lx", ch);
else Scm_Printf(out, "\\U%08lx", ch);
break;
default:
Scm_Putc(ch, out);
}
}
}
static void treemap_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
ScmTreeMap *tm = SCM_TREE_MAP(obj);
Scm_Printf(port, "#<tree-map %p (%d entries)>", tm,
Scm_TreeCoreNumEntries(SCM_TREE_MAP_CORE(tm)));
}
void sigset_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx)
{
Scm_Printf(out, "#<sys-sigset [");
display_sigset(&SCM_SYS_SIGSET(obj)->set, out);
Scm_Printf(out, "]>");
}
static void objc_error_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
Scm_Printf(port, "#<objc-error %A (%A)>"
, SCM_OBJC_ERROR(obj)->name, SCM_OBJC_ERROR(obj)->reason);
}
void sockaddr_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
Scm_Printf(port, "#<sockaddr %S %S>",
Scm_SockAddrFamily(SCM_SOCKADDR(obj)),
Scm_SockAddrName(SCM_SOCKADDR(obj)));
}
static void dump_insn_frequency(void *data)
{
Scm_Printf(SCM_CUROUT, "(:instruction-frequencies (");
for (int i=0; i<SCM_VM_NUM_INSNS; i++) {
Scm_Printf(SCM_CUROUT, "(%s %d", Scm_VMInsnName(i), insn1_freq[i]);
for (int j=0; j<SCM_VM_NUM_INSNS; j++) {
Scm_Printf(SCM_CUROUT, " %d", insn2_freq[i][j]);
}
Scm_Printf(SCM_CUROUT, ")\n");
}
Scm_Printf(SCM_CUROUT, ")\n :lref-frequencies (");
for (int i=0; i<LREF_FREQ_COUNT_MAX; i++) {
Scm_Printf(SCM_CUROUT, "(");
for (int j=0; j<LREF_FREQ_COUNT_MAX; j++) {
Scm_Printf(SCM_CUROUT, "%d ", lref_freq[i][j]);
}
Scm_Printf(SCM_CUROUT, ")\n");
}
Scm_Printf(SCM_CUROUT, ")\n :lset-frequencies (");
for (int i=0; i<LREF_FREQ_COUNT_MAX; i++) {
Scm_Printf(SCM_CUROUT, "(");
for (int j=0; j<LREF_FREQ_COUNT_MAX; j++) {
Scm_Printf(SCM_CUROUT, "%d ", lset_freq[i][j]);
}
Scm_Printf(SCM_CUROUT, ")\n");
}
Scm_Printf(SCM_CUROUT, ")\n");
Scm_Printf(SCM_CUROUT, ")\n");
}
static void syntax_print(ScmObj obj, ScmPort *port, ScmWriteContext *mode)
{
Scm_Printf(port, "#<syntax %A>", SCM_SYNTAX(obj)->name);
}
static void macro_print(ScmObj obj, ScmPort *port, ScmWriteContext *mode)
{
ScmSymbol *name = SCM_MACRO(obj)->name;
Scm_Printf(port, "#<macro %A>", (name ? SCM_OBJ(name) : SCM_FALSE));
}
static void macro_print(ScmObj obj, ScmPort *port, ScmWriteContext *mode)
{
Scm_Printf(port, "#<macro %A>", SCM_MACRO(obj)->name);
}
/*
* Useful routine for debugging, to check if an object is inadvertently
* collected.
*/
static void gc_sentinel(ScmObj obj, void *data)
{
Scm_Printf(SCM_CURERR, "WARNING: object %s(%p) is inadvertently collected\n", (char *)data, obj);
}
static void syntax_print(ScmObj obj, ScmPort *port, ScmWriteContext *mode)
{
ScmSymbol *name = SCM_SYNTAX(obj)->name;
Scm_Printf(port, "#<syntax %A>", (name ? SCM_OBJ(name) : SCM_FALSE));
}
