/* Cleanup */
void cleanup_main(void *data)
{
ScmVM *vm = Scm_VM();
if (profiling_mode) {
Scm_ProfilerStop();
Scm_EvalCString("(profiler-show)",
SCM_OBJ(Scm_GaucheModule()),
NULL); /* ignore errors */
}
/* EXPERIMENTAL */
if (stats_mode) {
fprintf(stderr, "\n;; Statistics (*: main thread only):\n");
fprintf(stderr,
";; GC: %zubytes heap, %zubytes allocated\n",
GC_get_heap_size(), GC_get_total_bytes());
fprintf(stderr,
";; stack overflow*: %ldtimes, %.2fms total/%.2fms avg\n",
vm->stat.sovCount,
vm->stat.sovTime/1000.0,
(vm->stat.sovCount > 0?
(double)(vm->stat.sovTime/vm->stat.sovCount)/1000.0 :
0.0));
}
/* EXPERIMENTAL */
if (SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_COLLECT_LOAD_STATS)) {
Scm_Eval(SCM_LIST2(SCM_INTERN("profiler-show-load-stats"),
SCM_LIST2(SCM_INTERN("quote"),
vm->stat.loadStat)),
SCM_OBJ(Scm_GaucheModule()),
NULL); /* ignore errors */
}
}
ScmObj Scm_SocketOutputPort(ScmSocket *sock, int buffering)
{
if (sock->outPort == NULL) {
int outfd;
if (sock->type != SOCK_DGRAM &&
sock->status < SCM_SOCKET_STATUS_CONNECTED) {
sockport_err(sock, "output");
}
#ifndef GAUCHE_WINDOWS
outfd = sock->fd;
#else /*GAUCHE_WINDOWS*/
/* cfd will be closed when this socket is closed. */
if (sock->cfd < 0) {
sock->cfd = _open_osfhandle(sock->fd, 0);
}
outfd = sock->cfd;
#endif /*GAUCHE_WINDOWS*/
if (outfd == INVALID_SOCKET) sockport_err(sock, "output");
/* NB: I keep the socket itself in the port name, in order to avoid
the socket from GCed prematurely if application doesn't keep
pointer to the socket. */
ScmObj sockname = SCM_LIST2(SCM_MAKE_STR("socket output"),
SCM_OBJ(sock));
sock->outPort = SCM_PORT(Scm_MakePortWithFd(sockname, SCM_PORT_OUTPUT,
outfd, buffering, FALSE));
}
return SCM_OBJ(sock->outPort);
}
static int cmp_scm(ScmObj x, ScmObj y, ScmObj fn)
{
ScmObj r = Scm_ApplyRec(fn, SCM_LIST2(x, y));
if (SCM_TRUEP(r) || (SCM_INTP(r) && SCM_INT_VALUE(r) < 0))
return -1;
else
return 1;
}
static void message_prefix_set(ScmMessageCondition *obj, ScmObj val)
{
ScmObj msglist = obj->message;
if (SCM_PAIRP(msglist) && SCM_PAIRP(SCM_CDR(msglist))) {
SCM_SET_CAR(SCM_CDR(msglist), val);
} else {
obj->message = SCM_LIST2(msglist, val);
}
}
/*------------------------------------------------------------
* Bport seek
*/
static off_t bport_seek(ScmPort *p, off_t off, int whence)
{
bport *data = (bport*)p->src.buf.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->seek_proc)) {
ScmObj r = Scm_ApplyRec(data->seek_proc,
SCM_LIST2(Scm_OffsetToInteger(off),
Scm_MakeInteger(whence)));
if (SCM_INTEGERP(r)) {
return Scm_IntegerToOffset(r);
}
}
return (off_t)-1;
}
void invoke_other_version(const char *version, int argc, char **argv)
{
static ScmObj invoke_other_version = SCM_UNDEFINED;
SCM_BIND_PROC(invoke_other_version, "%invoke-other-version",
Scm_GaucheInternalModule());
ScmEvalPacket epkt;
Scm_Apply(invoke_other_version,
SCM_LIST2(SCM_MAKE_STR_COPYING(version),
Scm_CStringArrayToList((const char**)argv, argc, 0)),
&epkt);
/* %invoke-other-version won't return. If we're here,
we even failed to call it. */
Scm_Panic("Failed to call %%invoke-other-version. Installation problem?");
}
/*------------------------------------------------------------
* Bport flush
*/
static int bport_flush(ScmPort *p, int cnt, int forcep)
{
bport *data = (bport*)p->src.buf.data;
ScmObj vec, r;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->flush_proc)) {
return cnt; /* blackhole */
}
vec = Scm_MakeU8VectorFromArrayShared(cnt,
(unsigned char*)p->src.buf.buffer);
r = Scm_ApplyRec(data->flush_proc, SCM_LIST2(vec, SCM_MAKE_BOOL(forcep)));
if (SCM_INTP(r)) return SCM_INT_VALUE(r);
else if (SCM_EOFP(r)) return 0;
else return -1;
}
/* Default object printer delegates print action to generic function
write-object. We can't use VMApply here since this function can be
called deep in the recursive stack of Scm_Write, so the control
may not return to VM immediately. */
static void write_object(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
Scm_ApplyRec(SCM_OBJ(&Scm_GenericWriteObject),
SCM_LIST2(obj, SCM_OBJ(port)));
}
static void message_set(ScmMessageCondition *obj, ScmObj val)
{
ScmObj msglist = obj->message;
if (SCM_PAIRP(msglist)) SCM_SET_CAR(msglist, val);
else SCM_MESSAGE_CONDITION(obj)->message = SCM_LIST2(val, val);
}