/*
* External entry to manage registering callbacks
* 'xtra1' and 'xtra2' are ignored by most callbacks; only the two callbacks
* use them:
* glutTimerFunc: xtra1 for millliseconds, xtra2 for value
* glutJoystickFunc: xtra1 for interval
*/
void Scm_GlutRegisterCallback(int type, ScmObj closure, int xtra1, int xtra2)
{
SCM_ASSERT(type >= 0 && type < SCM_GLUT_NUM_CBS);
if (type < SCM_GLUT_NUM_WINDOW_CBS) {
int win = glutGetWindow();
ScmObj entry = Scm_HashTableRef(SCM_HASH_TABLE(ScmGlutCallbackTable),
SCM_MAKE_INT(win), SCM_FALSE);
if (SCM_EQ(entry, SCM_FALSE)) {
entry = Scm_MakeVector(SCM_GLUT_NUM_WINDOW_CBS, SCM_FALSE);
Scm_HashTableSet(SCM_HASH_TABLE(ScmGlutCallbackTable),
SCM_MAKE_INT(win), entry, 0);
}
SCM_VECTOR_ELEMENT(entry, type) = closure;
registrars[type](!SCM_FALSEP(closure), xtra1);
} else if (type == SCM_GLUT_CB_IDLE) {
idle_closure = closure;
if (SCM_FALSEP(closure)) {
glutIdleFunc(NULL);
} else {
glutIdleFunc(idle_cb);
}
} else {
timer_closure = closure;
if (!SCM_FALSEP(closure)) {
glutTimerFunc(xtra1, timer_cb, xtra2);
}
}
}
/*------------------------------------------------------------
* Vport Getb
*/
static int vport_getb(ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->getb_proc)) {
/* If the port doesn't have get-byte method, use get-char
if possible. */
ScmObj ch;
ScmChar c;
char buf[SCM_CHAR_MAX_BYTES];
int nb, i;
if (SCM_FALSEP(data->getc_proc)) return EOF;
ch = Scm_ApplyRec(data->getc_proc, SCM_NIL);
if (!SCM_CHARP(ch)) return EOF;
c = SCM_CHAR_VALUE(ch);
nb = SCM_CHAR_NBYTES(c);
SCM_CHAR_PUT(buf, c);
for (i=1; i<nb; i++) {
/* pushback for later use. this isn't very efficient;
if efficiency becomes a problem, we need another API
to pushback multiple bytes. */
Scm_UngetbUnsafe(buf[i], p);
}
return buf[0];
} else {
ScmObj b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
if (!SCM_INTP(b)) return EOF;
return (SCM_INT_VALUE(b) & 0xff);
}
}
/*------------------------------------------------------------
* Vport Getc
*/
static int vport_getc(ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->getc_proc)) {
/* If the port doesn't have get-char method, try get-byte */
ScmObj b;
int n, i;
ScmChar ch;
char buf[SCM_CHAR_MAX_BYTES];
if (SCM_FALSEP(data->getb_proc)) return EOF;
b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
if (!SCM_INTP(b)) return EOF;
buf[0] = (char)SCM_INT_VALUE(b);
n = SCM_CHAR_NFOLLOWS(p->scratch[0]);
for (i=0; i<n; i++) {
b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
if (!SCM_INTP(b)) {
/* TODO: should raise an exception? */
return EOF;
}
buf[i+1] = (char)SCM_INT_VALUE(b);
}
SCM_CHAR_GET(buf, ch);
return ch;
} else {
ScmObj ch = Scm_ApplyRec(data->getc_proc, SCM_NIL);
if (!SCM_CHARP(ch)) return EOF;
return SCM_CHAR_VALUE(ch);
}
}
static void porterror_port_set(ScmPortError *obj, ScmObj val)
{
if (!SCM_PORTP(val) && !SCM_FALSEP(val)) {
Scm_Error("port or #f required, but got %S", val);
}
obj->port = SCM_FALSEP(val)? NULL : SCM_PORT(val);
}
/*------------------------------------------------------------
* 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);
}
}
/*------------------------------------------------------------
* Bport Ready
*/
static int bport_ready(ScmPort *p)
{
bport *data = (bport*)p->src.buf.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->ready_proc)) {
ScmObj s = Scm_ApplyRec(data->ready_proc, SCM_NIL);
return SCM_FALSEP(s)? SCM_FD_WOULDBLOCK:SCM_FD_READY;
} else {
/* if no method is given, always return #t */
return SCM_FD_READY;
}
}
/*------------------------------------------------------------
* Vport Ready
*/
static int vport_ready(ScmPort *p, int charp)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->ready_proc)) {
ScmObj s = Scm_ApplyRec(data->ready_proc,
SCM_LIST1(SCM_MAKE_BOOL(charp)));
return !SCM_FALSEP(s);
} else {
/* if no method is given, always return #t */
return TRUE;
}
}
/*------------------------------------------------------------
* Vport Gets
*/
static int vport_getz(char *buf, int buflen, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->gets_proc)) {
u_int size;
const char *start;
ScmObj s = Scm_ApplyRec(data->gets_proc,
SCM_LIST1(SCM_MAKE_INT(buflen)));
if (!SCM_STRINGP(s)) return EOF;
start = Scm_GetStringContent(SCM_STRING(s), &size, NULL, NULL);
if ((int)size > buflen) {
/* NB: should raise an exception? */
memcpy(buf, start, buflen);
return buflen;
} else {
memcpy(buf, start, size);
return size;
}
} else {
int byte, i;
for (i=0; i<buflen; i++) {
byte = vport_getb(p);
if (byte == EOF) break;
buf[i] = byte;
}
if (i==0) return EOF;
else return i;
}
}
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 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);
}
/* 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);
}
}
int
graphicsGdImageDestroyedP(ScmObj obj)
{
SCM_ASSERT(SCM_FOREIGN_POINTER_P(obj));
return !SCM_FALSEP(Scm_ForeignPointerAttrGet(SCM_FOREIGN_POINTER(obj),
sym_destroyed, SCM_FALSE));
}
/*------------------------------------------------------------
* Vport flush
*/
static void vport_flush(ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->flush_proc)) {
Scm_ApplyRec(data->flush_proc, SCM_NIL);
}
}
/*------------------------------------------------------------
* Bport close
*/
static void bport_close(ScmPort *p)
{
bport *data = (bport*)p->src.buf.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->close_proc)) {
Scm_ApplyRec(data->close_proc, SCM_NIL);
}
}
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);
}
}
ScmObj Scm_MutexUnlocker(ScmMutex *mutex)
{
ScmObj p = mutex->unlocker_proc;
if (SCM_FALSEP(p)) {
/* safe; race is ok here */
p = Scm_MakeSubr(mutex_unlocker, (void*)mutex, 0, 0, SCM_FALSE);
mutex->unlocker_proc = p;
}
return p;
}
/* 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);
}
/*------------------------------------------------------------
* Vport putz
*/
static void vport_putz(const char *buf, int size, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->puts_proc)) {
Scm_ApplyRec(data->puts_proc,
SCM_LIST1(Scm_MakeString(buf, size, -1,
SCM_STRING_COPYING)));
} else if (!SCM_FALSEP(data->putb_proc)) {
for (int i=0; i<size; i++) {
unsigned char b = buf[i];
Scm_ApplyRec(data->putb_proc, SCM_LIST1(SCM_MAKE_INT(b)));
}
} else {
Scm_PortError(p, SCM_PORT_ERROR_UNIT,
"cannot perform binary output to the port %S", p);
}
}
ScmObj Scm_ComparatorOrderingPredicate(ScmComparator *cmpr)
{
if (SCM_FALSEP(cmpr->orderFn)) {
static ScmObj p = SCM_UNDEFINED;
SCM_BIND_PROC(p, "comparator-ordering-predicate",
Scm_GaucheModule());
return Scm_ApplyRec1(p, SCM_OBJ(cmpr)); /* this fills orderFn */
} else {
return cmpr->orderFn;
}
}
/* C-level accessors, that take care of on-demand filling of slots. */
ScmObj Scm_ComparatorComparisonProcedure(ScmComparator *cmpr)
{
if (SCM_FALSEP(cmpr->compareFn)) {
static ScmObj p = SCM_UNDEFINED;
SCM_BIND_PROC(p, "comparator-comparison-procedure",
Scm_GaucheModule());
return Scm_ApplyRec1(p, SCM_OBJ(cmpr)); /* this fills compareFn */
} else {
return cmpr->compareFn;
}
}
ScmObj Scm_ComparatorHashFunction(ScmComparator *cmpr)
{
if (SCM_FALSEP(cmpr->hashFn)) {
static ScmObj p = SCM_UNDEFINED;
SCM_BIND_PROC(p, "comparator-hash-function",
Scm_GaucheModule());
return Scm_ApplyRec1(p, SCM_OBJ(cmpr)); /* this fills hashFn */
} else {
return cmpr->hashFn;
}
}
/*------------------------------------------------------------
* Vport putb
*/
static void vport_putb(ScmByte b, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->putb_proc)) {
if (!SCM_FALSEP(data->putc_proc)
&& SCM_CHAR_NFOLLOWS(b) == 0) {
/* This byte is a single-byte character, so we can use putc. */
Scm_ApplyRec(data->putc_proc, SCM_LIST1(SCM_MAKE_CHAR(b)));
} else {
/* Given byte is a part of multibyte sequence. We don't
handle it for the time being. */
Scm_PortError(p, SCM_PORT_ERROR_UNIT,
"cannot perform binary output to the port %S", p);
}
} else {
Scm_ApplyRec(data->putb_proc, SCM_LIST1(SCM_MAKE_INT(b)));
}
}
/*------------------------------------------------------------
* Vport putc
*/
static void vport_putc(ScmChar c, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->putc_proc)) {
if (SCM_FALSEP(data->putb_proc)) {
Scm_PortError(p, SCM_PORT_ERROR_OTHER,
"cannot perform output to the port %S", p);
} else {
unsigned char buf[SCM_CHAR_MAX_BYTES];
int i, n=SCM_CHAR_NBYTES(c);
SCM_CHAR_PUT(buf, c);
for (i=0; i<n; i++) {
Scm_ApplyRec(data->putb_proc, SCM_LIST1(SCM_MAKE_INT(buf[i])));
}
}
} else {
Scm_ApplyRec(data->putc_proc, SCM_LIST1(SCM_MAKE_CHAR(c)));
}
}
static void readerror_port_set(ScmReadError *obj, ScmObj val)
{
if (SCM_IPORTP(val)) {
obj->port = SCM_PORT(val);
}
else if (SCM_FALSEP(val)) {
obj->port = NULL;
}
else {
Scm_Error("input port or #f required, but got %S", val);
}
}
/* 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;
}
/*------------------------------------------------------------
* Bport filenum
*/
static int bport_filenum(ScmPort *p)
{
bport *data = (bport*)p->src.buf.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->filenum_proc)) {
return -1;
} else {
ScmObj s = Scm_ApplyRec(data->filenum_proc, SCM_NIL);
if (SCM_INTP(s)) return SCM_INT_VALUE(s);
else return -1;
}
}
/*------------------------------------------------------------
* 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;
}
/*------------------------------------------------------------
* Bport fill
*/
static int bport_fill(ScmPort *p, int cnt)
{
bport *data = (bport*)p->src.buf.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->fill_proc)) {
return 0; /* indicates EOF */
}
ScmObj vec = Scm_MakeU8VectorFromArrayShared(
cnt, (unsigned char*)p->src.buf.buffer);
ScmObj r = Scm_ApplyRec(data->fill_proc, SCM_LIST1(vec));
if (SCM_INTP(r)) return SCM_INT_VALUE(r);
else if (SCM_EOFP(r)) return 0;
else return -1;
}
/*------------------------------------------------------------
* 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;
}
/* 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;
}