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; }
ScmObj Scm_MutexLock(ScmMutex *mutex, ScmObj timeout, ScmVM *owner) { #ifdef GAUCHE_HAS_THREADS ScmTimeSpec ts; ScmObj r = SCM_TRUE; ScmVM *abandoned = NULL; int intr = FALSE; ScmTimeSpec *pts = Scm_GetTimeSpec(timeout, &ts); SCM_INTERNAL_MUTEX_SAFE_LOCK_BEGIN(mutex->mutex); while (mutex->locked) { if (mutex->owner && mutex->owner->state == SCM_VM_TERMINATED) { abandoned = mutex->owner; mutex->locked = FALSE; break; } if (pts) { int tr = SCM_INTERNAL_COND_TIMEDWAIT(mutex->cv, mutex->mutex, pts); if (tr == SCM_INTERNAL_COND_TIMEDOUT) { r = SCM_FALSE; break; } else if (tr == SCM_INTERNAL_COND_INTR) { intr = TRUE; break; } } else { SCM_INTERNAL_COND_WAIT(mutex->cv, mutex->mutex); } } if (SCM_TRUEP(r)) { mutex->locked = TRUE; mutex->owner = owner; } SCM_INTERNAL_MUTEX_SAFE_LOCK_END(); if (intr) Scm_SigCheck(Scm_VM()); if (abandoned) { ScmObj exc = Scm_MakeThreadException(SCM_CLASS_ABANDONED_MUTEX_EXCEPTION, abandoned); SCM_THREAD_EXCEPTION(exc)->data = SCM_OBJ(mutex); r = Scm_Raise(exc); } return r; #else /* !GAUCHE_HAS_THREADS */ return SCM_TRUE; /* dummy */ #endif /* !GAUCHE_HAS_THREADS */ }
/* multifunction on sigset if delp == FALSE, signals are added to set. else, signals are removed from set. signals is a list of either integer or #t (all signals), or other sigset. */ ScmObj Scm_SysSigsetOp(ScmSysSigset *set, ScmObj signals, int delp) { if (!SCM_PAIRP(signals)) { Scm_Error("list of signals required, but got %S", signals); } ScmObj cp; SCM_FOR_EACH(cp, signals) { ScmObj s = SCM_CAR(cp); if (SCM_TRUEP(s)) { if (!delp) sigfillset(&set->set); else sigemptyset(&set->set); break; } if (SCM_SYS_SIGSET_P(s)) { sigset_op(&set->set, &SCM_SYS_SIGSET(s)->set, delp); continue; } if (!SCM_INTP(s) || !validsigp(SCM_INT_VALUE(s))) { Scm_Error("bad signal number %S", s); } if (!delp) sigaddset(&set->set, SCM_INT_VALUE(s)); else sigdelset(&set->set, SCM_INT_VALUE(s)); }
int Scm_Compare(ScmObj x, ScmObj y) { /* Shortcut for typical case */ if (SCM_NUMBERP(x) && SCM_NUMBERP(y)) { if (SCM_COMPNUMP(x) || SCM_COMPNUMP(y)) { /* Scm_NumCmp can't compare complex numbers---it doesn't make mathematical sense. But Scm_Compare is used just to order items, it doesn't need to carry meaning. So here it goes. We follow srfi-114 spec. */ /* TODO: If we ever introduce exact compnums, we should use exact number first to compare, for Scm_GetDouble may lose precision. */ /* TODO: Handle NaN. */ double xr = Scm_RealPart(x); double yr = Scm_RealPart(y); if (xr < yr) return -1; if (xr > yr) return 1; double xi = Scm_ImagPart(x); double yi = Scm_ImagPart(y); if (xi < yi) return -1; if (xi > yi) return 1; return 0; } else { return Scm_NumCmp(x, y); } } if (SCM_STRINGP(x) && SCM_STRINGP(y)) return Scm_StringCmp(SCM_STRING(x), SCM_STRING(y)); if (SCM_CHARP(x) && SCM_CHARP(y)) return SCM_CHAR_VALUE(x) == SCM_CHAR_VALUE(y)? 0 : SCM_CHAR_VALUE(x) < SCM_CHAR_VALUE(y)? -1 : 1; /* Set cx, cy here, for we may jump to distinct_types later. */ ScmClass *cx = Scm_ClassOf(x); ScmClass *cy = Scm_ClassOf(y); /* srfi-114 default comparator behaviors*/ /* () is the smallest of all */ if (SCM_NULLP(x)) return (SCM_NULLP(y)? 0 : -1); if (SCM_NULLP(y)) return (SCM_NULLP(x)? 0 : 1); if (SCM_PAIRP(x)) { if (SCM_PAIRP(y)) { ScmObj px = x; ScmObj py = y; while (SCM_PAIRP(px) && SCM_PAIRP(py)) { int r = Scm_Compare(SCM_CAR(px), SCM_CAR(py)); if (r != 0) return r; px = SCM_CDR(px); py = SCM_CDR(py); } return Scm_Compare(px, py); } goto distinct_types; } if (SCM_FALSEP(x)) { if (SCM_FALSEP(y)) return 0; if (SCM_TRUEP(y)) return -1; goto distinct_types; } if (SCM_TRUEP(x)) { if (SCM_FALSEP(y)) return 1; if (SCM_TRUEP(y)) return 0; goto distinct_types; } if (Scm_SubtypeP(cx, cy)) { if (cy->compare) return cy->compare(x, y, FALSE); } else if (Scm_SubtypeP(cy, cx)) { if (cx->compare) return cx->compare(x, y, FALSE); } if (cx == cy) { /* x and y are of the same type, and they can't be ordered. */ Scm_Error("can't compare %S and %S", x, y); } distinct_types: /* x and y are of distinct types. Follow the srfi-114 rule: () < pairs < booleans < chars < strings < symbols < numbers < vectors < bytevectors < others Note that we already eliminated NULL. */ #define ELIMINATE(pred) \ do { \ if pred(x) return -1; \ if pred(y) return 1; \ } while (0) ELIMINATE(SCM_PAIRP); ELIMINATE(SCM_BOOLP); ELIMINATE(SCM_CHARP); ELIMINATE(SCM_STRINGP); ELIMINATE(SCM_SYMBOLP); ELIMINATE(SCM_NUMBERP); ELIMINATE(SCM_VECTORP); /* To conform srfi-114, we must order u8vector first. For the consistency, we use this order: u8 < s8 < u16 < s16 < u32 < s32 < u64 < s64 < f16 < f32 < f64 Unfortunately this doesn't match the order of ScmUVectorType, so we need some tweak. */ if (SCM_UVECTORP(x)) { if (SCM_UVECTORP(y)) { int tx = Scm_UVectorType(Scm_ClassOf(x)); int ty = Scm_UVectorType(Scm_ClassOf(y)); if (tx/2 < ty/2) return -1; if (tx/2 > ty/2) return 1; if (tx < SCM_UVECTOR_F16) { /* x and y are either sNvector and uNvector with the same N. The odd one is uNvector. */ return (tx%2)? -1:1; } else { return (tx<ty)? -1:1; } } return -1; /* y is other, so x comes first. */ } else if (SCM_UVECTORP(y)) { return 1; /* x is other, so y comes first. */ } /* Now we have two objects of different types, both are not the types defined the order in srfi-114. To achieve better stability, we first compare the name of the classes and the names of their defining modules; if they are still the same, we fall back to compare addresses. Note: Addresses and defining modules may be changed when the class is redefined. */ ScmObj nx = cx->name; ScmObj ny = cy->name; int nr = Scm_Compare(nx, ny); if (nr != 0) return nr; ScmObj mx = cx->modules; ScmObj my = cy->modules; while (SCM_PAIRP(mx) && SCM_PAIRP(my)) { SCM_ASSERT(SCM_MODULEP(SCM_CAR(mx)) && SCM_MODULEP(SCM_CAR(my))); int r = Scm_Compare(SCM_MODULE(SCM_CAR(mx))->name, SCM_MODULE(SCM_CAR(my))->name); if (r != 0) return r; mx = SCM_CDR(mx); my = SCM_CDR(my); } if (SCM_PAIRP(mx)) return -1; if (SCM_PAIRP(my)) return 1; if (cx < cy) return -1; else return 1; }