/*------------------------------------------------------------
* 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);
}
}
/* If OBJ is a primitive object (roughly, immediate or number), write it to
PORT. Assumes the caller locks the PORT.
Returns the # of characters written, or #f if OBJ is not a primitive object.
*/
ScmObj Scm__WritePrimitive(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
#define CASE_ITAG_RET(obj, str) \
case SCM_ITAG(obj): \
Scm_PutzUnsafe(str, -1, port); \
return SCM_MAKE_INT(sizeof(str)-1);
if (SCM_IMMEDIATEP(obj)) {
switch (SCM_ITAG(obj)) {
CASE_ITAG_RET(SCM_FALSE, "#f");
CASE_ITAG_RET(SCM_TRUE, "#t");
CASE_ITAG_RET(SCM_NIL, "()");
CASE_ITAG_RET(SCM_EOF, "#<eof>");
CASE_ITAG_RET(SCM_UNDEFINED, "#<undef>");
CASE_ITAG_RET(SCM_UNBOUND, "#<unbound>");
default:
Scm_Panic("write: unknown itag object: %08x", SCM_WORD(obj));
}
}
else if (SCM_INTP(obj)) {
char buf[SPBUFSIZ];
int k = snprintf(buf, SPBUFSIZ, "%ld", SCM_INT_VALUE(obj));
Scm_PutzUnsafe(buf, -1, port);
return SCM_MAKE_INT(k);
}
else if (SCM_CHARP(obj)) {
size_t k = write_char(SCM_CHAR_VALUE(obj), port, ctx);
return SCM_MAKE_INT(k);
}
else if (SCM_NUMBERP(obj)) {
return SCM_MAKE_INT(Scm_PrintNumber(port, obj, NULL));
}
return SCM_FALSE;
}
/*------------------------------------------------------------
* 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
write_char(ScmObj port, ScmObj obj, enum ScmOutputType otype)
{
const ScmSpecialCharInfo *info;
scm_ichar_t c;
c = SCM_CHAR_VALUE(obj);
switch (otype) {
case AS_WRITE:
scm_port_puts(port, "#\\");
/* special chars */
for (info = scm_special_char_table; info->esc_seq; info++) {
if (c == info->code) {
scm_port_puts(port, info->lex_rep);
return;
}
}
/* other control chars are printed in hexadecimal form */
if (ICHAR_CONTROLP(c)) {
scm_format(port, SCM_FMT_RAW_C, "x~02MX", (scm_int_t)c);
return;
}
/* FALLTHROUGH */
case AS_DISPLAY:
scm_port_put_char(port, c);
break;
default:
SCM_NOTREACHED;
}
}
SCM_EXPORT ScmObj
scm_p_eqvp(ScmObj obj1, ScmObj obj2)
{
#if SCM_HAS_EQVP
#define scm_p_eqvp error_eqvp_recursed__ /* Safety measure. */
return EQVP(obj1, obj2);
#undef scm_p_eqvp
#else /* don't have inlined EQVP() */
#if (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY))
enum ScmObjType type;
#endif
DECLARE_FUNCTION("eqv?", procedure_fixed_2);
if (EQ(obj1, obj2))
return SCM_TRUE;
#if (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY))
type = SCM_TYPE(obj1);
/* different type */
if (type != SCM_TYPE(obj2))
return SCM_FALSE;
/* same type */
switch (type) {
#if (SCM_USE_INT && !SCM_HAS_IMMEDIATE_INT_ONLY)
case ScmInt:
return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
#endif
#if (SCM_USE_CHAR && !SCM_HAS_IMMEDIATE_CHAR_ONLY)
case ScmChar:
return MAKE_BOOL(SCM_CHAR_VALUE(obj1) == SCM_CHAR_VALUE(obj2));
#endif
default:
break;
}
#endif /* (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)) */
return SCM_FALSE;
#endif /* don't have inlined EQVP() */
}
int Scm_Compare(ScmObj x, ScmObj y)
{
/* Shortcut for typical case */
if (SCM_NUMBERP(x) && SCM_NUMBERP(y))
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;
ScmClass *cx = Scm_ClassOf(x);
ScmClass *cy = Scm_ClassOf(y);
if (Scm_SubtypeP(cx, cy)) {
if (cy->compare) return cy->compare(x, y, FALSE);
} else {
if (cx->compare) return cx->compare(x, y, FALSE);
}
Scm_Error("can't compare %S and %S", x, y);
return 0; /* dummy */
}
/* If OBJ is a primitive object (roughly, immediate or number), write it to
PORT. Assumes the caller locks the PORT.
Returns the # of characters written, or #f if OBJ is not a primitive object.
*/
ScmObj Scm__WritePrimitive(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
const ScmWriteControls *wp = Scm_GetWriteControls(ctx, port->writeState);
#define CASE_ITAG_RET(obj, str) \
case SCM_ITAG(obj): \
Scm_PutzUnsafe(str, -1, port); \
return SCM_MAKE_INT(sizeof(str)-1);
if (SCM_IMMEDIATEP(obj)) {
switch (SCM_ITAG(obj)) {
CASE_ITAG_RET(SCM_FALSE, "#f");
CASE_ITAG_RET(SCM_TRUE, "#t");
CASE_ITAG_RET(SCM_NIL, "()");
CASE_ITAG_RET(SCM_EOF, "#<eof>");
CASE_ITAG_RET(SCM_UNDEFINED, "#<undef>");
CASE_ITAG_RET(SCM_UNBOUND, "#<unbound>");
default:
Scm_Panic("write: unknown itag object: %08x", SCM_WORD(obj));
}
}
else if (SCM_INTP(obj) && wp->printBase == 10 && !wp->printRadix) {
/* Shortcut to avoid allocation */
char buf[SPBUFSIZ];
int k = snprintf(buf, SPBUFSIZ, "%ld", SCM_INT_VALUE(obj));
Scm_PutzUnsafe(buf, -1, port);
return SCM_MAKE_INT(k);
}
else if (SCM_CHARP(obj)) {
size_t k = write_char(SCM_CHAR_VALUE(obj), port, ctx);
return SCM_MAKE_INT(k);
}
else if (SCM_NUMBERP(obj)) {
ScmNumberFormat fmt;
Scm_NumberFormatInit(&fmt);
fmt.radix = wp->printBase;
if (wp->printRadix) fmt.flags |= SCM_NUMBER_FORMAT_ALT_RADIX;
return SCM_MAKE_INT(Scm_PrintNumber(port, obj, &fmt));
}
/* PVREF only appears in pattern temlate in the current macro expander.
It will be go away once we rewrite the expander. */
else if (SCM_PVREF_P(obj)) {
char buf[SPBUFSIZ];
int k = snprintf(buf, SPBUFSIZ, "#<pvar %ld.%ld>",
SCM_PVREF_LEVEL(obj), SCM_PVREF_COUNT(obj));
Scm_PutzUnsafe(buf, -1, port);
return SCM_MAKE_INT(k);
}
return SCM_FALSE;
}
SCM_EXPORT ScmObj
scm_p_equalp(ScmObj obj1, ScmObj obj2)
{
enum ScmObjType type;
ScmObj elm1, elm2;
#if SCM_USE_VECTOR
ScmObj *v1, *v2;
scm_int_t i, len;
#endif
DECLARE_FUNCTION("equal?", procedure_fixed_2);
if (EQ(obj1, obj2))
return SCM_TRUE;
type = SCM_TYPE(obj1);
/* different type */
if (type != SCM_TYPE(obj2))
return SCM_FALSE;
/* same type */
switch (type) {
#if (SCM_USE_INT && !SCM_HAS_IMMEDIATE_INT_ONLY)
case ScmInt:
return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
#endif
#if (SCM_USE_CHAR && !SCM_HAS_IMMEDIATE_CHAR_ONLY)
case ScmChar:
return MAKE_BOOL(SCM_CHAR_VALUE(obj1) == SCM_CHAR_VALUE(obj2));
#endif
#if SCM_USE_STRING
case ScmString:
return MAKE_BOOL(STRING_EQUALP(obj1, obj2));
#endif
case ScmCons:
for (; CONSP(obj1) && CONSP(obj2); obj1 = CDR(obj1), obj2 = CDR(obj2))
{
elm1 = CAR(obj1);
elm2 = CAR(obj2);
if (!EQ(elm1, elm2)
&& (SCM_TYPE(elm1) != SCM_TYPE(elm2)
|| !EQUALP(elm1, elm2)))
return SCM_FALSE;
}
/* compare last cdr */
return (EQ(obj1, obj2)) ? SCM_TRUE : scm_p_equalp(obj1, obj2);
#if SCM_USE_VECTOR
case ScmVector:
len = SCM_VECTOR_LEN(obj1);
if (len != SCM_VECTOR_LEN(obj2))
return SCM_FALSE;
v1 = SCM_VECTOR_VEC(obj1);
v2 = SCM_VECTOR_VEC(obj2);
for (i = 0; i < len; i++) {
elm1 = v1[i];
elm2 = v2[i];
if (!EQ(elm1, elm2)
&& (SCM_TYPE(elm1) != SCM_TYPE(elm2)
|| !EQUALP(elm1, elm2)))
return SCM_FALSE;
}
return SCM_TRUE;
#endif
#if SCM_USE_SSCM_EXTENSIONS
case ScmCPointer:
return MAKE_BOOL(SCM_C_POINTER_VALUE(obj1)
== SCM_C_POINTER_VALUE(obj2));
case ScmCFuncPointer:
return MAKE_BOOL(SCM_C_FUNCPOINTER_VALUE(obj1)
== SCM_C_FUNCPOINTER_VALUE(obj2));
#endif
default:
break;
}
return SCM_FALSE;
}
/* Process command-line options that needs to run after Scheme runtime
is initialized. CMD_ARGS is an list of (OPTION-CHAR . OPTION-ARG) */
static void process_command_args(ScmObj cmd_args)
{
ScmEvalPacket epak;
ScmLoadPacket lpak;
int standard_given = FALSE;
ScmObj cp;
SCM_FOR_EACH(cp, cmd_args) {
ScmObj p = SCM_CAR(cp);
ScmObj v = SCM_CDR(p);
switch (SCM_CHAR_VALUE(SCM_CAR(p))) {
case 'I':
Scm_AddLoadPath(Scm_GetStringConst(SCM_STRING(v)), FALSE);
break;
case 'A':
Scm_AddLoadPath(Scm_GetStringConst(SCM_STRING(v)), TRUE);
break;
case 'l':
if (Scm_Load(Scm_GetStringConst(SCM_STRING(v)), 0, &lpak) < 0)
error_exit(lpak.exception);
break;
case 'L':
if (Scm_Load(Scm_GetStringConst(SCM_STRING(v)), SCM_LOAD_QUIET_NOFILE, &lpak) < 0)
error_exit(lpak.exception);
break;
case 'u':
if (Scm_Require(Scm_StringJoin(Scm_StringSplitByChar(SCM_STRING(v),
'.'),
SCM_STRING(SCM_MAKE_STR("/")),
SCM_STRING_JOIN_INFIX),
0, &lpak) < 0) {
error_exit(lpak.exception);
}
Scm_ImportModule(SCM_CURRENT_MODULE(), Scm_Intern(SCM_STRING(v)),
SCM_FALSE, 0);
break;
case 'e':
if (Scm_EvalCString(Scm_GetStringConst(SCM_STRING(v)),
SCM_OBJ(Scm_UserModule()),
&epak) < 0) {
error_exit(epak.exception);
}
break;
case 'E':
v = Scm_StringAppend(SCM_LIST3(SCM_MAKE_STR("("),
v,
SCM_MAKE_STR(")")));
if (Scm_EvalCString(Scm_GetStringConst(SCM_STRING(v)),
SCM_OBJ(Scm_UserModule()),
&epak) < 0) {
error_exit(epak.exception);
}
break;
case 'r':
if (standard_given) {
Scm_Error("Multiple -r option is specified.");
} else {
/* R7RS mode. Preload r7rs module, set the default toplevel
to r7rs.user, and define *r7rs-mode* in user module
so that gauche.interactive can do proper setup. */
const char *std = Scm_GetStringConst(SCM_STRING(v));
if (strcmp(std, "7") == 0) {
if (Scm_Require(SCM_MAKE_STR("r7rs"), 0, &lpak) < 0) {
error_exit(lpak.exception);
}
SCM_DEFINE(Scm_UserModule(), "*r7rs-mode*", SCM_TRUE);
default_toplevel_module = SCM_FIND_MODULE("r7rs.user", 0);
standard_given = TRUE;
} else {
Scm_Error("Unsupported standard for -r option: %s", std);
}
}
}
}
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;
}
