/* 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);
}
}
/* 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);
}
/* 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 ScmChar ucstochar(int ucs4)
{
#if defined(GAUCHE_CHAR_ENCODING_UTF_8)
return (ScmChar)ucs4;
#else /*!GAUCHE_CHAR_ENCODING_UTF_8*/
char inbuf[6], outbuf[6];
const char *inb = inbuf;
char *outb = outbuf;
if (ucsconv.ucs2char == NULL) return SCM_CHAR_INVALID;
size_t inroom = UCS2UTF_NBYTES(ucs4);
size_t outroom = 6;
jconv_ucs4_to_utf8(ucs4, inbuf);
(void)SCM_INTERNAL_MUTEX_LOCK(ucsconv.mutex);
size_t r = jconv(ucsconv.ucs2char, &inb, &inroom, &outb, &outroom);
(void)SCM_INTERNAL_MUTEX_UNLOCK(ucsconv.mutex);
if (r == INPUT_NOT_ENOUGH || r == OUTPUT_NOT_ENOUGH) {
Scm_Error("can't convert UCS4 code %d to a character: implementation problem?", ucs4);
}
if (r == ILLEGAL_SEQUENCE) {
return SCM_CHAR_INVALID;
} else {
ScmChar out;
SCM_CHAR_GET(outbuf, out);
return out;
}
#endif /*!GAUCHE_CHAR_ENCODING_UTF_8*/
}
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 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 release_promise(ScmObj *args, int nargs, void *data)
{
ScmPromise *p = SCM_PROMISE(data);
p->content->owner = NULL;
SCM_INTERNAL_MUTEX_UNLOCK(p->content->mutex);
return SCM_UNDEFINED;
}
void Scm_CompileFinish(ScmCompiledCode *cc)
{
if (cc->code == NULL) {
SCM_INTERNAL_MUTEX_LOCK(compile_finish_mutex);
SCM_UNWIND_PROTECT {
if (cc->code == NULL) {
Scm_ApplyRec1(SCM_GLOC_GET(compile_finish_gloc), SCM_OBJ(cc));
}
}
SCM_WHEN_ERROR {
SCM_INTERNAL_MUTEX_UNLOCK(compile_finish_mutex);
SCM_NEXT_HANDLER;
}
SCM_END_PROTECT;
SCM_INTERNAL_MUTEX_UNLOCK(compile_finish_mutex);
}
static int chartoucs(ScmChar ch)
{
#if defined(GAUCHE_CHAR_ENCODING_UTF_8)
if (ch == SCM_CHAR_INVALID) return -1;
return (int)ch;
#else /*!GAUCHE_CHAR_ENCODING_UTF_8*/
char inbuf[6], outbuf[6];
const char *inb = inbuf;
char *outb = outbuf;
if (ch == SCM_CHAR_INVALID) return -1;
if (ucsconv.char2ucs == NULL) return -1;
size_t inroom = SCM_CHAR_NBYTES(ch);
size_t outroom = 6;
SCM_CHAR_PUT(inbuf, ch);
(void)SCM_INTERNAL_MUTEX_LOCK(ucsconv.mutex);
size_t r = jconv(ucsconv.char2ucs, &inb, &inroom, &outb, &outroom);
(void)SCM_INTERNAL_MUTEX_UNLOCK(ucsconv.mutex);
if (r == INPUT_NOT_ENOUGH || r == OUTPUT_NOT_ENOUGH) {
Scm_Error("can't convert character %u to UCS4 code: implementation problem?", ch);
}
if (r == ILLEGAL_SEQUENCE) {
return -1;
} else {
unsigned char *ucp = (unsigned char*)outbuf;
if (ucp[0] < 0x80) return (int)ucp[0];
if (ucp[0] < 0xe0) {
return ((ucp[0]&0x1f)<<6) + (ucp[1]&0x3f);
}
if (ucp[0] < 0xf0) {
return ((ucp[0]&0x0f)<<12)
+ ((ucp[1]&0x3f)<<6)
+ (ucp[2]&0x3f);
}
if (ucp[0] < 0xf8) {
return ((ucp[0]&0x07)<<18)
+ ((ucp[1]&0x3f)<<12)
+ ((ucp[2]&0x3f)<<6)
+ (ucp[3]&0x3f);
}
if (ucp[0] < 0xfc) {
return ((ucp[0]&0x03)<<24)
+ ((ucp[1]&0x3f)<<18)
+ ((ucp[2]&0x3f)<<12)
+ ((ucp[3]&0x3f)<<6)
+ (ucp[4]&0x3f);
}
if (ucp[0] < 0xfe) {
return ((ucp[0]&0x01)<<30)
+ ((ucp[1]&0x3f)<<24)
+ ((ucp[2]&0x3f)<<18)
+ ((ucp[3]&0x3f)<<12)
+ ((ucp[4]&0x3f)<<6)
+ (ucp[5]&0x3f);
}
return -1;
}
#endif /*!GAUCHE_CHAR_ENCODING_UTF_8*/
}
static conv_guess *findGuessingProc(const char *code)
{
conv_guess *rec;
(void)SCM_INTERNAL_MUTEX_LOCK(guess.mutex);
for (rec = guess.procs; rec; rec = rec->next) {
if (strcasecmp(rec->codeName, code) == 0) break;
}
(void)SCM_INTERNAL_MUTEX_UNLOCK(guess.mutex);
return rec;
}
/* Returns a keyword whose name is NAME. Note that preceding ':' is not
* a part of the keyword name.
*/
ScmObj Scm_MakeKeyword(ScmString *name)
{
ScmObj r;
ScmKeyword *k;
(void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
r = Scm_HashTableRef(keywords.table, SCM_OBJ(name), SCM_FALSE);
(void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
if (SCM_KEYWORDP(r)) return r;
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;
}
void Scm_RegisterCodeGuessingProc(const char *code,
ScmCodeGuessingProc proc,
void *data)
{
conv_guess *rec = SCM_NEW(conv_guess);
rec->codeName = code;
rec->proc = proc;
rec->data = data;
(void)SCM_INTERNAL_MUTEX_LOCK(guess.mutex);
rec->next = guess.procs;
guess.procs = rec;
(void)SCM_INTERNAL_MUTEX_UNLOCK(guess.mutex);
}
static ScmObj mutex_state_get(ScmMutex *mutex)
{
ScmObj r;
(void)SCM_INTERNAL_MUTEX_LOCK(mutex->mutex);
if (mutex->locked) {
if (mutex->owner) {
if (mutex->owner->state == SCM_VM_TERMINATED) r = sym_abandoned;
else r = SCM_OBJ(mutex->owner);
} else {
r = sym_not_owned;
}
} else {
r = sym_not_abandoned;
}
(void)SCM_INTERNAL_MUTEX_UNLOCK(mutex->mutex);
return r;
}
ScmObj Scm_Force(ScmObj obj)
{
if (!SCM_PROMISEP(obj)) {
SCM_RETURN(obj);
} else {
ScmPromiseContent *c = SCM_PROMISE(obj)->content;
if (c->forced) SCM_RETURN(c->code);
else {
ScmVM *vm = Scm_VM();
void *data[2];
data[0] = obj;
data[1] = vm->handlers;
if (c->owner == vm) {
/* we already have the lock and evaluating this promise. */
c->count++;
Scm_VMPushCC(force_cc, data, 2);
SCM_RETURN(Scm_VMApply0(c->code));
} else {
/* TODO: check if the executing thread terminates
prematurely */
SCM_INTERNAL_MUTEX_LOCK(c->mutex);
if (c->forced) {
SCM_INTERNAL_MUTEX_UNLOCK(c->mutex);
SCM_RETURN(c->code);
}
SCM_ASSERT(c->owner == NULL);
c->owner = vm;
install_release_thunk(vm, obj);
c->count++;
/* mutex is unlocked by force_cc. */
Scm_VMPushCC(force_cc, data, 2);
SCM_RETURN(Scm_VMApply0(c->code));
}
}
}
}
