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