/* internal constructor. NAME must be an immutable string. */
static ScmSymbol *make_sym(ScmClass *klass, ScmString *name, int interned)
{
if (interned) {
/* fast path */
SCM_INTERNAL_MUTEX_LOCK(obtable_mutex);
ScmObj e = Scm_HashTableRef(obtable, SCM_OBJ(name), SCM_FALSE);
SCM_INTERNAL_MUTEX_UNLOCK(obtable_mutex);
if (!SCM_FALSEP(e)) return SCM_SYMBOL(e);
}
ScmSymbol *sym = SCM_NEW(ScmSymbol);
SCM_SET_CLASS(sym, klass);
sym->name = name;
sym->flags = interned? SCM_SYMBOL_FLAG_INTERNED : 0;
if (!interned) {
return sym;
} else {
/* Using SCM_DICT_NO_OVERWRITE ensures that if another thread interns
the same name symbol between above HashTableRef and here, we'll
get the already interned symbol. */
SCM_INTERNAL_MUTEX_LOCK(obtable_mutex);
ScmObj e = Scm_HashTableSet(obtable, SCM_OBJ(name), SCM_OBJ(sym),
SCM_DICT_NO_OVERWRITE);
SCM_INTERNAL_MUTEX_UNLOCK(obtable_mutex);
return SCM_SYMBOL(e);
}
}
/* 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_SocketAccept(ScmSocket *sock)
{
Socket newfd;
struct sockaddr_storage addrbuf;
socklen_t addrlen = sizeof(addrbuf);
ScmSocket *newsock;
ScmClass *addrClass = Scm_ClassOf(SCM_OBJ(sock->address));
CLOSE_CHECK(sock->fd, "accept from", sock);
SCM_SYSCALL(newfd, accept(sock->fd, (struct sockaddr*)&addrbuf, &addrlen));
if (SOCKET_INVALID(newfd)) {
if (errno == EAGAIN) {
return SCM_FALSE;
} else {
Scm_SysError("accept(2) failed");
}
}
newsock = make_socket(newfd, sock->type);
newsock->address =
SCM_SOCKADDR(Scm_MakeSockAddr(addrClass,
(struct sockaddr*)&addrbuf,
addrlen));
newsock->status = SCM_SOCKET_STATUS_CONNECTED;
return SCM_OBJ(newsock);
}
/* In unified keyword, we include preceding ':' to the name. */
ScmObj Scm_MakeKeyword(ScmString *name)
{
#if GAUCHE_KEEP_DISJOINT_KEYWORD_OPTION
if (keyword_disjoint_p) {
(void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
ScmObj r = Scm_HashTableRef(keywords.table, SCM_OBJ(name), SCM_FALSE);
(void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
if (SCM_KEYWORDP(r)) return r;
ScmKeyword *k = SCM_NEW(ScmKeyword);
SCM_SET_CLASS(k, SCM_CLASS_KEYWORD);
k->name = SCM_STRING(Scm_CopyString(name));
(void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
r = Scm_HashTableSet(keywords.table, SCM_OBJ(name), SCM_OBJ(k),
SCM_DICT_NO_OVERWRITE);
(void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
return r;
}
#endif /*GAUCHE_KEEP_DISJOINT_KEYWORD_OPTION*/
ScmObj sname = Scm_StringAppend2(&keyword_prefix, name);
ScmSymbol *s = make_sym(SCM_CLASS_KEYWORD, SCM_STRING(sname), TRUE);
Scm_DefineConst(Scm__GaucheKeywordModule(), s, SCM_OBJ(s));
return SCM_OBJ(s);
}
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);
}
/* In unified keyword, we include preceding ':' to the name. */
ScmObj Scm_MakeKeyword(ScmString *name)
{
#if GAUCHE_UNIFY_SYMBOL_KEYWORD
/* We could optimize this later. */
ScmObj prefix = Scm_MakeString(":", 1, 1, SCM_STRING_IMMUTABLE);
ScmObj sname = Scm_StringAppend2(SCM_STRING(prefix), name);
ScmSymbol *s = make_sym(SCM_CLASS_KEYWORD, SCM_STRING(sname), TRUE);
Scm_DefineConst(Scm_KeywordModule(), s, SCM_OBJ(s));
return SCM_OBJ(s);
#else /*!GAUCHE_UNIFY_SYMBOL_KEYWORD*/
(void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
ScmObj r = Scm_HashTableRef(keywords.table, SCM_OBJ(name), SCM_FALSE);
(void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
if (SCM_KEYWORDP(r)) return r;
ScmKeyword *k = SCM_NEW(ScmKeyword);
SCM_SET_CLASS(k, SCM_CLASS_KEYWORD);
k->name = SCM_STRING(Scm_CopyString(name));
(void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
r = Scm_HashTableSet(keywords.table, SCM_OBJ(name), SCM_OBJ(k),
SCM_DICT_NO_OVERWRITE);
(void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
return r;
#endif /*!GAUCHE_UNIFY_SYMBOL_KEYWORD*/
}
static ScmObj cv_allocate(ScmClass *klass, ScmObj initargs)
{
ScmConditionVariable *cv = SCM_NEW_INSTANCE(ScmConditionVariable, klass);
SCM_INTERNAL_COND_INIT(cv->cv);
Scm_RegisterFinalizer(SCM_OBJ(cv), cv_finalize, NULL);
cv->name = SCM_FALSE;
cv->specific = SCM_UNDEFINED;
return SCM_OBJ(cv);
}
/* Implemented in Scheme */
static void write_walk(ScmObj obj, ScmPort *port)
{
static ScmObj proc = SCM_UNDEFINED;
SCM_ASSERT(port->writeState);
ScmHashTable *ht = port->writeState->sharedTable;
SCM_ASSERT(ht != NULL);
SCM_BIND_PROC(proc, "%write-walk-rec", Scm_GaucheInternalModule());
Scm_ApplyRec3(proc, obj, SCM_OBJ(port), SCM_OBJ(ht));
}
/* In unified keyword, we include preceding ':' to the name. */
ScmObj Scm_MakeKeyword(ScmString *name)
{
/* We could optimize this later. */
ScmObj prefix = Scm_MakeString(":", 1, 1, SCM_STRING_IMMUTABLE);
ScmObj sname = Scm_StringAppend2(SCM_STRING(prefix), name);
ScmSymbol *s = make_sym(SCM_CLASS_KEYWORD, SCM_STRING(sname), TRUE);
Scm_DefineConst(Scm_KeywordModule(), s, SCM_OBJ(s));
return SCM_OBJ(s);
}
ScmObj Scm_Acons(ScmObj caar, ScmObj cdar, ScmObj cdr)
{
ScmPair *y = SCM_NEW(ScmPair);
ScmPair *z = SCM_NEW(ScmPair);
SCM_SET_CAR(y, caar);
SCM_SET_CDR(y, cdar);
SCM_SET_CAR(z, SCM_OBJ(y));
SCM_SET_CDR(z, cdr);
return SCM_OBJ(z);
}
ScmObj Scm_MakeTLS(uint32_t options, int num_sessions)
{
ScmTLS* t = SCM_NEW(ScmTLS);
SCM_SET_CLASS(t, SCM_CLASS_TLS);
#if defined(GAUCHE_USE_AXTLS)
t->ctx = ssl_ctx_new(options, num_sessions);
t->conn = NULL;
t->in_port = t->out_port = 0;
#endif /*GAUCHE_USE_AXTLS*/
Scm_RegisterFinalizer(SCM_OBJ(t), tls_finalize, NULL);
return SCM_OBJ(t);
}
/* 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 ScmObj mutex_allocate(ScmClass *klass, ScmObj initargs)
{
ScmMutex *mutex = SCM_NEW_INSTANCE(ScmMutex, klass);
SCM_INTERNAL_MUTEX_INIT(mutex->mutex);
SCM_INTERNAL_COND_INIT(mutex->cv);
Scm_RegisterFinalizer(SCM_OBJ(mutex), mutex_finalize, NULL);
mutex->name = SCM_FALSE;
mutex->specific = SCM_UNDEFINED;
mutex->locked = FALSE;
mutex->owner = NULL;
mutex->locker_proc = mutex->unlocker_proc = SCM_FALSE;
return SCM_OBJ(mutex);
}
static gboolean
glgdGraphKeyCB(GtkWidget *widget, GdkEventKey *event, gpointer data)
{
glgdGraph *graph;
ScmObj keyFn;
graph = (glgdGraph *)data;
if (graph == NULL)
{
return FALSE;
}
switch (event->keyval)
{
case GDK_Control_L:
case GDK_Control_R:
if (event->type == GDK_KEY_PRESS)
{
graph->flags |= GLGDGRAPH_FLAG_CTRLHELD;
}
else if (event->type == GDK_KEY_RELEASE)
{
graph->flags &= ~GLGDGRAPH_FLAG_CTRLHELD;
}
break;
case GDK_Escape:
if (event->type == GDK_KEY_PRESS)
{
graph->flags |= GLGDGRAPH_FLAG_ESCPRESSED;
}
break;
default:
return FALSE;
}
gdk_window_invalidate_rect(widget->window, &widget->allocation, FALSE);
keyFn = graph->fn[GLGDGRAPH_FN_KEY];
if (keyFn != NULL)
{
Scm_ApplyRec4(keyFn,
SCM_OBJ(SCM_MAKE_GLGD_GRAPH(graph)),
SCM_OBJ(SCM_MAKE_GLGD_NODE(graph->hoverNode)),
SCM_OBJ(SCM_MAKE_GLGD_LINK(graph->hoverLink)),
SCM_OBJ(Scm_MakeGdkEventKey(event)));
}
return TRUE;
}
ScmObj Scm_CharSetAdd(ScmCharSet *dst, ScmCharSet *src)
{
if (dst == src) return SCM_OBJ(dst); /* precaution */
ScmTreeIter iter;
ScmDictEntry *e;
Scm_BitsOperate(dst->small, SCM_BIT_IOR, dst->small, src->small,
0, SCM_CHAR_SET_SMALL_CHARS);
Scm_TreeIterInit(&iter, &src->large, NULL);
while ((e = Scm_TreeIterNext(&iter)) != NULL) {
Scm_CharSetAddRange(dst, SCM_CHAR(e->key), SCM_CHAR(e->value));
}
return SCM_OBJ(dst);
}
static ScmObj message_allocate(ScmClass *klass, ScmObj initargs)
{
ScmError *e = SCM_ALLOCATE(ScmError, klass);
SCM_SET_CLASS(e, klass);
e->message = SCM_FALSE; /* would be set by initialize */
return SCM_OBJ(e);
}
ScmObj Scm_TreeMapCopy(const ScmTreeMap *src)
{
ScmTreeMap *tm = SCM_NEW(ScmTreeMap);
SCM_SET_CLASS(tm, SCM_CLASS_TREE_MAP);
Scm_TreeCoreCopy(SCM_TREE_MAP_CORE(tm), SCM_TREE_MAP_CORE(src));
return SCM_OBJ(tm);
}
static ScmObj termios_allocate(ScmClass *klass, ScmObj initargs)
{
ScmSysTermios *t = SCM_NEW(ScmSysTermios);
SCM_SET_CLASS(t, SCM_CLASS_SYS_TERMIOS);
memset(&t->term, 0, sizeof(t->term));
return SCM_OBJ(t);
}
/*------------------------------------------------------------
* Vport puts
*/
static void vport_puts(ScmString *s, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
const ScmStringBody *b = SCM_STRING_BODY(s);
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->puts_proc)) {
Scm_ApplyRec(data->puts_proc, SCM_LIST1(SCM_OBJ(s)));
} else if (SCM_STRING_BODY_INCOMPLETE_P(b)
|| (SCM_FALSEP(data->putc_proc)
&& !SCM_FALSEP(data->putb_proc))) {
/* we perform binary output */
vport_putz(SCM_STRING_BODY_START(b), SCM_STRING_BODY_SIZE(b), p);
} else if (!SCM_FALSEP(data->putc_proc)) {
ScmChar c;
int i;
const char *cp = SCM_STRING_BODY_START(b);
for (i=0; i < (int)SCM_STRING_BODY_LENGTH(b); i++) {
SCM_CHAR_GET(cp, c);
cp += SCM_CHAR_NFOLLOWS(*cp)+1;
Scm_ApplyRec(data->putc_proc, SCM_LIST1(SCM_MAKE_CHAR(c)));
}
} else {
Scm_PortError(p, SCM_PORT_ERROR_OTHER,
"cannot perform output to the port %S", p);
}
}
/*
* Reader extension
*/
static ScmObj read_uvector(ScmPort *port, const char *tag,
ScmReadContext *ctx)
{
ScmChar c;
ScmObj uv = SCM_UNDEFINED;
SCM_GETC(c, port);
if (c != '(') Scm_Error("bad uniform vector syntax for %s", tag);
ScmObj list = Scm_ReadList(SCM_OBJ(port), ')');
if (strcmp(tag, "s8") == 0) uv = Scm_ListToS8Vector(list, 0);
else if (strcmp(tag, "u8") == 0) uv = Scm_ListToU8Vector(list, 0);
else if (strcmp(tag, "s16") == 0) uv = Scm_ListToS16Vector(list, 0);
else if (strcmp(tag, "u16") == 0) uv = Scm_ListToU16Vector(list, 0);
else if (strcmp(tag, "s32") == 0) uv = Scm_ListToS32Vector(list, 0);
else if (strcmp(tag, "u32") == 0) uv = Scm_ListToU32Vector(list, 0);
else if (strcmp(tag, "s64") == 0) uv = Scm_ListToS64Vector(list, 0);
else if (strcmp(tag, "u64") == 0) uv = Scm_ListToU64Vector(list, 0);
else if (strcmp(tag, "f16") == 0) uv = Scm_ListToF16Vector(list, 0);
else if (strcmp(tag, "f32") == 0) uv = Scm_ListToF32Vector(list, 0);
else if (strcmp(tag, "f64") == 0) uv = Scm_ListToF64Vector(list, 0);
else Scm_Error("invalid unform vector tag: %s", tag);
/* If we are reading source file, let literal uvectors be immutable. */
if (Scm_ReadContextLiteralImmutable(ctx)) {
SCM_UVECTOR_IMMUTABLE_P(uv) = TRUE;
}
return uv;
}
static ScmObj makeGlutFont(void *ptr)
{
ScmGlutFont *gf = SCM_NEW(ScmGlutFont);
SCM_SET_CLASS(gf, SCM_CLASS_GLUT_FONT);
gf->font = ptr;
return SCM_OBJ(gf);
}
ScmObj Scm_CharSetCopy(ScmCharSet *src)
{
ScmCharSet *dst = make_charset();
Scm_BitsCopyX(dst->small, 0, src->small, 0, SCM_CHAR_SET_SMALL_CHARS);
Scm_TreeCoreCopy(&dst->large, &src->large);
return SCM_OBJ(dst);
}
/* signal handler */
static void sampler_sample(int sig)
{
ScmVM *vm = Scm_VM();
if (vm->prof == NULL) return;
if (vm->prof->state != SCM_PROFILER_RUNNING) return;
if (vm->prof->currentSample >= SCM_PROF_SAMPLES_IN_BUFFER) {
ITIMER_STOP();
sampler_flush(vm);
ITIMER_START();
}
int i = vm->prof->currentSample++;
if (vm->base) {
/* If vm->pc is RET and val0 is a subr, it is pretty likely that
we're actually executing that subr. */
if (vm->pc && SCM_VM_INSN_CODE(*vm->pc) == SCM_VM_RET
&& SCM_SUBRP(vm->val0)) {
vm->prof->samples[i].func = vm->val0;
vm->prof->samples[i].pc = NULL;
} else {
vm->prof->samples[i].func = SCM_OBJ(vm->base);
vm->prof->samples[i].pc = vm->pc;
}
} else {
vm->prof->samples[i].func = SCM_FALSE;
vm->prof->samples[i].pc = NULL;
}
vm->prof->totalSamples++;
}
static ScmObj force_cc(ScmObj result, void **data)
{
ScmPromise *p = (ScmPromise*)data[0];
ScmObj handlers = (ScmObj)data[1];
/* Check if the original promise is forced by evaluating
the delayed expr to detect recursive force situation */
if (!p->content->forced) {
if (SCM_PROMISEP(result)) {
/* Deal with a recursive promise introduced by lazy operation.
See srfi-45 for the details. */
p->content->forced = SCM_PROMISE(result)->content->forced;
p->content->code = SCM_PROMISE(result)->content->code;
SCM_PROMISE(result)->content = p->content;
} else {
/* This isn't supposed to happen if 'lazy' is used properly
on the promise-yielding procedure, but we can't prevent
one from writing (lazy 3). So play safe. */
p->content->forced = TRUE;
p->content->code = result;
}
}
if (--p->content->count == 0) {
p->content->owner = NULL;
SCM_INTERNAL_MUTEX_UNLOCK(p->content->mutex);
}
Scm_VM()->handlers = handlers;
SCM_RETURN(Scm_Force(SCM_OBJ(p)));
}
static ScmObj compound_allocate(ScmClass *klass, ScmObj initargs)
{
ScmCompoundCondition *e = SCM_ALLOCATE(ScmCompoundCondition, klass);
SCM_SET_CLASS(e, klass);
e->conditions = SCM_NIL;
return SCM_OBJ(e);
}
/* b must be normalized. */
long Scm_BignumToSI(const ScmBignum *b, int clamp, int *oor)
{
if (clamp == SCM_CLAMP_NONE && oor != NULL) *oor = FALSE;
if (b->sign >= 0) {
if (b->values[0] > LONG_MAX || b->size >= 2) {
if (clamp & SCM_CLAMP_HI) return LONG_MAX;
else goto err;
} else {
return (long)b->values[0];
}
} else {
if (b->values[0] > (u_long)LONG_MAX+1 || b->size >= 2) {
if (clamp & SCM_CLAMP_LO) return LONG_MIN;
else goto err;
} else {
return -(long)b->values[0];
}
}
err:
if (clamp == SCM_CLAMP_NONE && oor != NULL) {
*oor = TRUE;
} else {
Scm_Error("argument out of range: %S", SCM_OBJ(b));
}
return 0;
}
ScmObj Scm_MakeBignumFromUI(u_long val)
{
ScmBignum *b = make_bignum(1);
b->sign = 1;
b->values[0] = val;
return SCM_OBJ(b);
}
static ScmObj flock_allocate(ScmClass *klass, ScmObj initargs)
{
ScmSysFlock *f = SCM_NEW(ScmSysFlock);
SCM_SET_CLASS(f, SCM_CLASS_SYS_FLOCK);
memset(&f->lock, 0, sizeof(f->lock));
return SCM_OBJ(f);
}
ScmObj sigset_allocate(ScmClass *klass, ScmObj initargs)
{
ScmSysSigset *s = SCM_ALLOCATE(ScmSysSigset, klass);
SCM_SET_CLASS(s, klass);
sigemptyset(&s->set);
return SCM_OBJ(s);
}
ScmObj Scm_BignumCopy(const ScmBignum *b)
{
ScmBignum *c = make_bignum(b->size);
c->sign = b->sign;
for (u_int i=0; i<b->size; i++) c->values[i] = b->values[i];
return SCM_OBJ(c);
}
