/*------------------------------------------------------------
* 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);
}
}
/*------------------------------------------------------------
* 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;
}
/* places a single char in the input buffer. */
static int
sf_fill_input (SCM port)
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM ans;
scm_t_port *pt;
ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */
if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
return EOF;
SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
pt = SCM_PTAB_ENTRY (port);
if (pt->encoding == NULL)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
*pt->read_buf = SCM_CHAR (ans);
pt->read_pos = pt->read_buf;
pt->read_end = pt->read_buf + 1;
return *pt->read_buf;
}
else
scm_ungetc_unlocked (SCM_CHAR (ans), port);
return SCM_CHAR (ans);
}
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;
}
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;
}
