int Scm_EqvP(ScmObj x, ScmObj y)
{
/* For our implementation, only numbers need different treatment
than SCM_EQ. We first check flonums, or we'd have to FLONUM_ENSURE_MEM
before we pass them to Scm_NumEq.
*/
if (SCM_NUMBERP(x)) {
if (SCM_NUMBERP(y)) {
/* Since flonums are the only "inexact real" type in Gauche,
we can safely reject the cases where either one is flonum and
another is not. */
if (SCM_FLONUMP(x)) {
if (SCM_FLONUMP(y)) {
return (SCM_FLONUM_VALUE(x) == SCM_FLONUM_VALUE(y));
} else {
return FALSE;
}
} else if (SCM_FLONUMP(y)) {
return FALSE;
}
/* More generic case. */
if ((SCM_EXACTP(x) && SCM_EXACTP(y))
|| (SCM_INEXACTP(x) && SCM_INEXACTP(y))) {
return Scm_NumEq(x, y);
}
}
return FALSE;
}
return SCM_EQ(x, y);
}
int Scm_EqualP(ScmObj x, ScmObj y)
{
ScmClass *cx, *cy;
if (SCM_EQ(x, y)) return TRUE;
if (SCM_PAIRP(x)) {
if (!SCM_PAIRP(y)) return FALSE;
do {
if (!Scm_EqualP(SCM_CAR(x), SCM_CAR(y))) return FALSE;
x = SCM_CDR(x);
y = SCM_CDR(y);
} while (SCM_PAIRP(x)&&SCM_PAIRP(y));
return Scm_EqualP(x, y);
}
if (SCM_STRINGP(x)) {
if (SCM_STRINGP(y)) {
return Scm_StringEqual(SCM_STRING(x), SCM_STRING(y));
}
return FALSE;
}
if (SCM_NUMBERP(x)) {
if (SCM_NUMBERP(y)) {
if ((SCM_EXACTP(x) && SCM_EXACTP(y))
|| (SCM_INEXACTP(x) && SCM_INEXACTP(y))) {
return Scm_NumEq(x, y);
}
}
return FALSE;
}
if (SCM_VECTORP(x)) {
if (SCM_VECTORP(y)) {
int sizx = SCM_VECTOR_SIZE(x);
int sizy = SCM_VECTOR_SIZE(y);
if (sizx == sizy) {
while (sizx--) {
if (!Scm_EqualP(SCM_VECTOR_ELEMENT(x, sizx),
SCM_VECTOR_ELEMENT(y, sizx)))
break;
}
if (sizx < 0) return TRUE;
}
}
return FALSE;
}
/* EXPERIMENTAL: when identifier is compared by equal?,
we use its symbolic name to compare. This allows
comparing macro output with equal?, and also less confusing
when R5RS macro and legacy macro are mixed.
For "proper" comparison of identifiers keeping their semantics,
we need such procedures as free-identifier=? and bound-identifier=?
anyway, so this change of equal? won't have a negative impact, I hope.
NB: this operation come here instead of the beginning of this
procedure, since comparing identifiers are relatively rare so
we don't want to check idnetifier-ness every time.
*/
if (SCM_IDENTIFIERP(x) || SCM_IDENTIFIERP(y)) {
if (SCM_IDENTIFIERP(x)) x = SCM_OBJ(SCM_IDENTIFIER(x)->name);
if (SCM_IDENTIFIERP(y)) y = SCM_OBJ(SCM_IDENTIFIER(y)->name);
return SCM_EQ(x, y);
}
/* End of EXPERIMENTAL code */
if (!SCM_HPTRP(x)) return (x == y);
cx = Scm_ClassOf(x);
cy = Scm_ClassOf(y);
if (cx == cy && cx->compare) {
return (cx->compare(x, y, TRUE) == 0);
}
return FALSE;
}
ScmObj Scm_SysFcntl(ScmObj port_or_fd, int op, ScmObj arg)
{
#if !defined(GAUCHE_WINDOWS)
int fd = Scm_GetPortFd(port_or_fd, TRUE), r;
switch (op) {
case F_GETFD:; case F_GETFL:;
#if defined(F_GETOWN) /* BSD and Linux specific */
case F_GETOWN:;
#endif /*F_GETOWN*/
#if defined(F_GETSIG) /* Linux specific */
case F_GETSIG:;
#endif /*F_GETSIG */
#if defined(F_GETLEASE) /* Linux specific */
case F_GETLEASE:;
#endif /*F_GETLEASE */
SCM_SYSCALL(r, fcntl(fd, op));
if (r == -1) { /*NB: F_GETOWN may return a negative value on success*/
Scm_SysError("fcntl(%s) failed", flag_name(op));
}
return Scm_MakeInteger(r);
case F_SETFD:; case F_SETFL:; case F_DUPFD:;
#if defined(F_SETOWN) /* BSD and Linux specific */
case F_SETOWN:;
#endif /*F_SETOWN*/
#if defined(F_SETSIG) /* Linux specific */
case F_SETSIG:;
#endif /*F_SETSIG */
#if defined(F_SETLEASE) /* Linux specific */
case F_SETLEASE:;
#endif /*F_SETLEASE */
#if defined(F_NOTIFY) /* Linux specific */
case F_NOTIFY:;
#endif /*F_NOTIFY */
if (!SCM_EXACTP(arg)) {
Scm_Error("exact integer required for fcntl(%s), but got %S",
flag_name(op), arg);
}
SCM_SYSCALL(r, fcntl(fd, op, Scm_GetInteger(arg)));
if (r < 0) {
Scm_SysError("fcntl(%s) failed", flag_name(op));
}
return Scm_MakeInteger(r);
case F_GETLK:; case F_SETLK:; case F_SETLKW:;
if (!SCM_SYS_FLOCK_P(arg)) {
Scm_Error("flock object required for fcntl(%s), but got %S",
flag_name(op), arg);
}
ScmSysFlock *fl = SCM_SYS_FLOCK(arg);
SCM_SYSCALL(r, fcntl(fd, op, &fl->lock));
if (op == F_SETLK) {
if (r >= 0) return SCM_TRUE;
if (errno == EAGAIN) return SCM_FALSE;
}
if (r < 0) Scm_SysError("fcntl(%s) failed", flag_name(op));
return SCM_TRUE;
default:
Scm_Error("unknown operation code (%d) for fcntl", op);
return SCM_UNDEFINED; /* dummy */
}
#else /*GAUCHE_WINDOWS*/
Scm_Error("fcntl not supported on MinGW port");
return SCM_UNDEFINED; /*dummy*/
#endif /*GAUCHE_WINDOWS*/
}
