/* 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)); } } } }