/* depth is # of black nodes. */
static int check_traverse(Node *node, int depth, int *count)
{
int ld, rd;
(*count)++; /* entry count */
if (BLACKP(node)) depth++;
if (node->left) {
if (REDP(node) && REDP(node->left)) {
Scm_Error("[internal] tree map has adjacent red nodes");
}
ld = check_traverse(node->left, depth, count);
} else {
ld = depth;
}
if (node->right) {
if (REDP(node) && REDP(node->right)) {
Scm_Error("[internal] tree map has adjacent red nodes");
}
rd = check_traverse(node->right, depth, count);
} else {
rd = depth;
}
if (ld != rd) {
Scm_Error("[internal] tree map has different black-node depth (L:%d vs R:%d)", ld, rd);
}
return ld;
}
/*
* Reader extension
*/
static ScmObj read_uvector(ScmPort *port, const char *tag,
ScmReadContext *ctx)
{
ScmChar c;
ScmObj uv = SCM_UNDEFINED;
SCM_GETC(c, port);
if (c != '(') Scm_Error("bad uniform vector syntax for %s", tag);
ScmObj list = Scm_ReadList(SCM_OBJ(port), ')');
if (strcmp(tag, "s8") == 0) uv = Scm_ListToS8Vector(list, 0);
else if (strcmp(tag, "u8") == 0) uv = Scm_ListToU8Vector(list, 0);
else if (strcmp(tag, "s16") == 0) uv = Scm_ListToS16Vector(list, 0);
else if (strcmp(tag, "u16") == 0) uv = Scm_ListToU16Vector(list, 0);
else if (strcmp(tag, "s32") == 0) uv = Scm_ListToS32Vector(list, 0);
else if (strcmp(tag, "u32") == 0) uv = Scm_ListToU32Vector(list, 0);
else if (strcmp(tag, "s64") == 0) uv = Scm_ListToS64Vector(list, 0);
else if (strcmp(tag, "u64") == 0) uv = Scm_ListToU64Vector(list, 0);
else if (strcmp(tag, "f16") == 0) uv = Scm_ListToF16Vector(list, 0);
else if (strcmp(tag, "f32") == 0) uv = Scm_ListToF32Vector(list, 0);
else if (strcmp(tag, "f64") == 0) uv = Scm_ListToF64Vector(list, 0);
else Scm_Error("invalid unform vector tag: %s", tag);
/* If we are reading source file, let literal uvectors be immutable. */
if (Scm_ReadContextLiteralImmutable(ctx)) {
SCM_UVECTOR_IMMUTABLE_P(uv) = TRUE;
}
return uv;
}
ScmChar Scm_UcsToChar(int n)
{
if (n < 0) Scm_Error("bad character code: %d", n);
#if defined(GAUCHE_CHAR_ENCODING_UTF_8)
return (ScmChar)n;
#elif defined(GAUCHE_CHAR_ENCODING_EUC_JP) || defined(GAUCHE_CHAR_ENCODING_SJIS)
if (n < 0x80) return (ScmChar)n; /*ASCII range*/
if (ucs2char_hook == NULL) {
/* NB: we don't need mutex here, for the loading of gauche.charconv
is serialized in Scm_Require. */
Scm_Require(SCM_MAKE_STR("gauche/charconv"),
SCM_LOAD_PROPAGATE_ERROR, NULL);
if (ucs2char_hook == NULL) {
Scm_Error("couldn't autoload gauche.charconv");
}
}
return ucs2char_hook(n);
#else
/* Encoding == 'none'. It would be safer to reject anything beyond
0xff, but it prevents 'none' gosh from reading any source files that
have escaped characters in that range, even the section is cond-expanded.
That's awfully incovenient, so we use a substitution character '?' here,
relying the programmer to properly conditionalize the code.
We plan to drop 'none' encoding support in 1.0, so this kludge is
just a temporary measure.
*/
if (n < 0x100) return (ScmChar)n; /* ISO8859-1 */
else return (ScmChar)'?';
#endif
}
static ScmBignum *make_bignum(int size)
{
if (size < 0) Scm_Error("invalid bignum size (internal error): %d", size);
if (size > (int)SCM_BIGNUM_MAX_DIGITS) Scm_Error("too large bignum");
ScmBignum *b = SCM_NEW_ATOMIC2(ScmBignum*, BIGNUM_SIZE(size));
SCM_SET_CLASS(b, SCM_CLASS_INTEGER);
b->size = size;
b->sign = 1;
return bignum_clear(b);
}
void Scm_TreeCoreCheckConsistency(ScmTreeCore *tc)
{
Node *r = ROOT(tc);
int cnt = 0;
if (!BLACKP(r)) Scm_Error("[internal] tree map root node is not black.");
if (r) check_traverse(r, 1, &cnt);
if (cnt != tc->num_entries) {
Scm_Error("[internal] tree map node count mismatch: record %d vs actual %d", tc->num_entries, cnt);
}
}
static void termios_c_cc_set(ScmSysTermios* t, ScmObj val)
{
if (!SCM_U8VECTORP(val)) {
Scm_Error("cc type must be a u8vector, but got %S", val);
}
if (SCM_U8VECTOR_SIZE(val) != NCCS) {
Scm_Error("size of cc must be %u, but got %u",
NCCS, SCM_U8VECTOR_SIZE(val));
}
memcpy(t->term.c_cc, SCM_U8VECTOR_ELEMENTS(val), NCCS);
}
ScmObj Scm_GetKeyword(ScmObj key, ScmObj list, ScmObj fallback)
{
ScmObj cp;
SCM_FOR_EACH(cp, list) {
if (!SCM_PAIRP(SCM_CDR(cp))) {
Scm_Error("incomplete key list: %S", list);
}
if (key == SCM_CAR(cp)) return SCM_CADR(cp);
cp = SCM_CDR(cp);
}
if (SCM_UNBOUNDP(fallback)) {
Scm_Error("value for key %S is not provided: %S", key, list);
}
return fallback;
}
static void porterror_port_set(ScmPortError *obj, ScmObj val)
{
if (!SCM_PORTP(val) && !SCM_FALSEP(val)) {
Scm_Error("port or #f required, but got %S", val);
}
obj->port = SCM_FALSEP(val)? NULL : SCM_PORT(val);
}
static void readerror_line_set(ScmReadError *obj, ScmObj val)
{
if (!SCM_INTP(val)){
Scm_Error("small integer required, but got %S", val);
}
obj->line = SCM_INT_VALUE(val);
}
static void sigerror_signal_set(ScmUnhandledSignalError *obj, ScmObj val)
{
if (!SCM_INTP(val)) {
Scm_Error("small integer required, but got %S", val);
}
obj->signal = SCM_INT_VALUE(val);
}
static void syserror_number_set(ScmSystemError *obj, ScmObj val)
{
if (!SCM_INTP(val)) {
Scm_Error("small integer required, but got %S", val);
}
obj->error_number = SCM_INT_VALUE(val);
}
ScmObj Scm_MakeBignumFromDouble(double val)
{
if (LONG_MIN <= val
#if SIZEOF_LONG == 4
&& val <= LONG_MAX
#else
&& val <= nextafter((double)LONG_MAX, 0.0)
#endif
)
return Scm_MakeBignumFromSI((long)val);
int exponent, sign;
ScmObj mantissa = Scm_DecodeFlonum(val, &exponent, &sign);
if (!SCM_NUMBERP(mantissa)) {
Scm_Error("can't convert %lf to an integer", val);
}
ScmObj b = Scm_Ash(mantissa, exponent);
if (sign < 0) b = Scm_Negate(b);
/* always returns bignum */
if (SCM_INTP(b)) {
return Scm_MakeBignumFromSI(SCM_INT_VALUE(b));
} else {
return b;
}
}
/* b must be normalized. */
long Scm_BignumToSI(const ScmBignum *b, int clamp, int *oor)
{
if (clamp == SCM_CLAMP_NONE && oor != NULL) *oor = FALSE;
if (b->sign >= 0) {
if (b->values[0] > LONG_MAX || b->size >= 2) {
if (clamp & SCM_CLAMP_HI) return LONG_MAX;
else goto err;
} else {
return (long)b->values[0];
}
} else {
if (b->values[0] > (u_long)LONG_MAX+1 || b->size >= 2) {
if (clamp & SCM_CLAMP_LO) return LONG_MIN;
else goto err;
} else {
return -(long)b->values[0];
}
}
err:
if (clamp == SCM_CLAMP_NONE && oor != NULL) {
*oor = TRUE;
} else {
Scm_Error("argument out of range: %S", SCM_OBJ(b));
}
return 0;
}
static ScmChar ucstochar(int ucs4)
{
#if defined(GAUCHE_CHAR_ENCODING_UTF_8)
return (ScmChar)ucs4;
#else /*!GAUCHE_CHAR_ENCODING_UTF_8*/
char inbuf[6], outbuf[6];
const char *inb = inbuf;
char *outb = outbuf;
if (ucsconv.ucs2char == NULL) return SCM_CHAR_INVALID;
size_t inroom = UCS2UTF_NBYTES(ucs4);
size_t outroom = 6;
jconv_ucs4_to_utf8(ucs4, inbuf);
(void)SCM_INTERNAL_MUTEX_LOCK(ucsconv.mutex);
size_t r = jconv(ucsconv.ucs2char, &inb, &inroom, &outb, &outroom);
(void)SCM_INTERNAL_MUTEX_UNLOCK(ucsconv.mutex);
if (r == INPUT_NOT_ENOUGH || r == OUTPUT_NOT_ENOUGH) {
Scm_Error("can't convert UCS4 code %d to a character: implementation problem?", ucs4);
}
if (r == ILLEGAL_SEQUENCE) {
return SCM_CHAR_INVALID;
} else {
ScmChar out;
SCM_CHAR_GET(outbuf, out);
return out;
}
#endif /*!GAUCHE_CHAR_ENCODING_UTF_8*/
}
/*------------------------------------------------------------
* Direct interface for code guessing
*/
const char *Scm_GuessCES(const char *code, const char *buf, int buflen)
{
conv_guess *guess = findGuessingProc(code);
if (guess == NULL)
Scm_Error("unknown code guessing scheme: %s", code);
return guess->proc(buf, buflen, guess->data);
}
int Scm_CharReadyUnsafe(ScmPort *p)
#endif
{
int r = 0;
VMDECL;
SHORTCUT(p, return Scm_CharReadyUnsafe(p));
if (!SCM_IPORTP(p)) Scm_Error("input port required, but got %S", p);
LOCK(p);
if (p->ungotten != SCM_CHAR_INVALID) r = TRUE;
else {
switch (SCM_PORT_TYPE(p)) {
case SCM_PORT_FILE:
if (p->src.buf.current < p->src.buf.end) r = TRUE;
else if (p->src.buf.ready == NULL) r = TRUE;
else {
SAFE_CALL(p, r = (p->src.buf.ready(p) != SCM_FD_WOULDBLOCK));
}
break;
case SCM_PORT_PROC:
SAFE_CALL(p, r = p->src.vt.Ready(p, TRUE));
break;
default:
r = TRUE;
}
}
UNLOCK(p);
return r;
}
static void conv_output_closer(ScmPort *port)
{
ScmConvInfo *info = (ScmConvInfo*)port->src.buf.data;
/* if there's remaining bytes in buf, send them to the remote port. */
if (info->ptr > info->buf) {
Scm_Putz(info->buf, (int)(info->ptr - info->buf), info->remote);
info->ptr = info->buf;
}
/* sends out the closing sequence, if any */
int r = (int)jconv_reset(info, info->buf, info->bufsiz);
#ifdef JCONV_DEBUG
fprintf(stderr, "<= r=%d(reset), buf(%p)\n",
r, info->buf);
#endif
if (r < 0) {
Scm_Error("something wrong in resetting output character encoding conversion (%s -> %s). possibly an implementation error.",
info->fromCode, info->toCode);
}
if (r > 0) {
Scm_Putz(info->buf, r, info->remote);
}
/* flush remove port */
Scm_Flush(info->remote);
if (info->ownerp) {
Scm_ClosePort(info->remote);
info->remoteClosed = TRUE;
}
jconv_close(info);
}
/*
* Scm_Write - Standard Write.
*/
void Scm_Write(ScmObj obj, ScmObj p, int mode)
{
if (!SCM_OPORTP(p)) Scm_Error("output port required, but got %S", p);
ScmPort *port = SCM_PORT(p);
ScmWriteContext ctx;
write_context_init(&ctx, mode, 0, 0);
ScmVM *vm = Scm_VM();
if (PORT_LOCK_OWNER_P(port, vm) && PORT_RECURSIVE_P(port)) {
/* Special treatment - if we're "display"-ing a string, we'll bypass
walk path even if we're in the middle of write/ss. Using srfi-38
notation to show displayed strings doesn't make sense at all.
*/
if (PORT_WALKER_P(port) &&
!((mode == SCM_WRITE_DISPLAY) && SCM_STRINGP(obj))) {
write_walk(obj, port);
} else {
write_rec(obj, port, &ctx);
}
return;
}
PORT_LOCK(port, vm);
if (WRITER_NEED_2PASS(&ctx)) {
PORT_SAFE_CALL(port, write_ss(obj, port, &ctx),
cleanup_port_write_state(port));
} else {
PORT_SAFE_CALL(port, write_rec(obj, port, &ctx), /*no cleanup*/);
}
PORT_UNLOCK(port);
}
static int chartoucs(ScmChar ch)
{
#if defined(GAUCHE_CHAR_ENCODING_UTF_8)
if (ch == SCM_CHAR_INVALID) return -1;
return (int)ch;
#else /*!GAUCHE_CHAR_ENCODING_UTF_8*/
char inbuf[6], outbuf[6];
const char *inb = inbuf;
char *outb = outbuf;
if (ch == SCM_CHAR_INVALID) return -1;
if (ucsconv.char2ucs == NULL) return -1;
size_t inroom = SCM_CHAR_NBYTES(ch);
size_t outroom = 6;
SCM_CHAR_PUT(inbuf, ch);
(void)SCM_INTERNAL_MUTEX_LOCK(ucsconv.mutex);
size_t r = jconv(ucsconv.char2ucs, &inb, &inroom, &outb, &outroom);
(void)SCM_INTERNAL_MUTEX_UNLOCK(ucsconv.mutex);
if (r == INPUT_NOT_ENOUGH || r == OUTPUT_NOT_ENOUGH) {
Scm_Error("can't convert character %u to UCS4 code: implementation problem?", ch);
}
if (r == ILLEGAL_SEQUENCE) {
return -1;
} else {
unsigned char *ucp = (unsigned char*)outbuf;
if (ucp[0] < 0x80) return (int)ucp[0];
if (ucp[0] < 0xe0) {
return ((ucp[0]&0x1f)<<6) + (ucp[1]&0x3f);
}
if (ucp[0] < 0xf0) {
return ((ucp[0]&0x0f)<<12)
+ ((ucp[1]&0x3f)<<6)
+ (ucp[2]&0x3f);
}
if (ucp[0] < 0xf8) {
return ((ucp[0]&0x07)<<18)
+ ((ucp[1]&0x3f)<<12)
+ ((ucp[2]&0x3f)<<6)
+ (ucp[3]&0x3f);
}
if (ucp[0] < 0xfc) {
return ((ucp[0]&0x03)<<24)
+ ((ucp[1]&0x3f)<<18)
+ ((ucp[2]&0x3f)<<12)
+ ((ucp[3]&0x3f)<<6)
+ (ucp[4]&0x3f);
}
if (ucp[0] < 0xfe) {
return ((ucp[0]&0x01)<<30)
+ ((ucp[1]&0x3f)<<24)
+ ((ucp[2]&0x3f)<<18)
+ ((ucp[3]&0x3f)<<12)
+ ((ucp[4]&0x3f)<<6)
+ (ucp[5]&0x3f);
}
return -1;
}
#endif /*!GAUCHE_CHAR_ENCODING_UTF_8*/
}
static char *get_message_buffer(ScmUVector *v, u_int *size)
{
if (SCM_UVECTOR_IMMUTABLE_P(v)) {
Scm_Error("attempted to use an immutable uniform vector as a buffer");
}
*size = Scm_UVectorSizeInBytes(v);
return (char *)SCM_UVECTOR_ELEMENTS(v);
}
GLboolean
glgdGraphConnect3(glgdGraph *graph, GtkWidget *gtkWindow, ScmObj glDrawArea)
{
if (!SCM_GTK_WIDGET_P(glDrawArea)) {
Scm_Error("<gtk-widget> required, but got %S", glDrawArea);
}
return glgdGraphConnectInt(graph, gtkWindow, SCM_GTK_WIDGET(glDrawArea));
}
/* we need special routines for int64 */
ScmInt64 Scm_BignumToSI64(const ScmBignum *b, int clamp, int *oor)
{
#if SCM_EMULATE_INT64
ScmInt64 r = {0, 0};
if (clamp == SCM_CLAMP_NONE && oor != NULL) *oor = FALSE;
if (b->sign > 0) {
if (b->size > 2 || b->values[1] > LONG_MAX) {
if (!(clamp & SCM_CLAMP_HI)) goto err;
SCM_SET_INT64_MAX(r);
} else {
r.lo = b->values[0];
if (b->size == 2) r.hi = b->values[1];
}
} else if (b->sign < 0) {
if (b->size > 2 || b->values[1] > (u_long)LONG_MAX + 1) {
if (!(clamp&SCM_CLAMP_LO)) goto err;
SCM_SET_INT64_MIN(r);
} else {
b = SCM_BIGNUM(Scm_BignumComplement(b));
r.lo = b->values[0];
if (b->size == 2) r.hi = b->values[1];
else r.hi = -1;
}
}
return r;
#else /*!SCM_EMULATE_INT64*/
int64_t r = 0;
if (clamp == SCM_CLAMP_NONE && oor != NULL) *oor = FALSE;
if (b->sign > 0) {
if (b->size == 1) {
r = b->values[0];
} else if (b->size > 2 || b->values[1] > LONG_MAX) {
if (!(clamp & SCM_CLAMP_HI)) goto err;
SCM_SET_INT64_MAX(r);
} else {
r = ((int64_t)b->values[1] << 32) + (uint64_t)b->values[0];
}
} else { /* b->sign < 0 */
if (b->size == 1) {
r = -(int64_t)b->values[0];
} else if (b->size > 2 || (b->values[1] > LONG_MAX && b->values[0] > 0)) {
if (!(clamp&SCM_CLAMP_LO)) goto err;
SCM_SET_INT64_MIN(r);
} else {
r = -(int64_t)(((int64_t)b->values[1] << 32) + (uint64_t)b->values[0]);
}
}
return r;
#endif /*!SCM_EMULATE_INT64*/
err:
if (clamp == SCM_CLAMP_NONE && oor != NULL) {
*oor = TRUE;
} else {
Scm_Error("argument out of range: %S", SCM_OBJ(b));
}
return r;
}
/* Force a lazy pair.
NB: When an error occurs during forcing, we release the lock of the
pair, so that the pair can be forced again. However, the generator
has already caused some side-effect before the error, so the next
forcing may not yield a correct next value. Another plausible option
is to mark the pair 'unforcible' permanently, by lp->owner == (AO_t)2,
and let subsequent attempt of forcing the pair fail.
*/
ScmObj Scm_ForceLazyPair(volatile ScmLazyPair *lp)
{
static const struct timespec req = {0, 1000000};
struct timespec rem;
ScmVM *vm = Scm_VM();
do {
if (AO_compare_and_swap_full(&lp->owner, 0, SCM_WORD(vm))) {
/* Here we own the lazy pair. */
ScmObj item = lp->item;
/* Calling generator might change VM state, so we protect
incomplete stack frame if there's any. */
int extra_frame_pushed = Scm__VMProtectStack(vm);
SCM_UNWIND_PROTECT {
ScmObj val = Scm_ApplyRec0(lp->generator);
ScmObj newgen = (vm->numVals == 1)? lp->generator : vm->vals[0];
vm->numVals = 1; /* make sure the extra val won't leak out */
if (SCM_EOFP(val)) {
lp->item = SCM_NIL;
lp->generator = SCM_NIL;
} else {
ScmObj newlp = Scm_MakeLazyPair(val, newgen);
lp->item = newlp;
lp->generator = SCM_NIL;
}
AO_nop_full();
SCM_SET_CAR(lp, item);
/* We don't need barrier here. */
lp->owner = (AO_t)1;
} SCM_WHEN_ERROR {
lp->owner = (AO_t)0; /*NB: See above about error handling*/
SCM_NEXT_HANDLER;
} SCM_END_PROTECT;
if (extra_frame_pushed) {
Scm__VMUnprotectStack(vm);
}
return SCM_OBJ(lp); /* lp is now an (extended) pair */
}
/* Check if we're already working on forcing this pair. Unlike
force/delay, We don't allow recursive forcing of lazy pair.
Since generators are supposed to be called every time to yield
a new value, so it is ambiguous what value should be returned
if a generator calls itself recursively. */
if (lp->owner == SCM_WORD(vm)) {
/* NB: lp->owner will be reset by the original caller of
the generator. */
Scm_Error("Attempt to recursively force a lazy pair.");
}
/* Somebody's already working on forcing. Let's wait for it
to finish, or to abort. */
while (SCM_HTAG(lp) == 7 && lp->owner != 0) {
nanosleep(&req, &rem);
}
} while (lp->owner == 0); /* we retry if the previous owner abandoned. */
/* START can be NULL; in which case, if next call is TreeIterNext,
it iterates from the minimum node; if next call is TreeIterPrev,
it iterates from the maximum node. */
void Scm_TreeIterInit(ScmTreeIter *iter,
ScmTreeCore *tc,
ScmDictEntry *start)
{
if (start && Scm_TreeCoreSearch(tc, start->key, SCM_DICT_GET) != start) {
Scm_Error("Scm_TreeIterInit: iteration start point is not a part of the tree.");
}
iter->t = tc;
iter->e = start;
iter->at_end = FALSE;
}
static void readerror_port_set(ScmReadError *obj, ScmObj val)
{
if (SCM_IPORTP(val)) {
obj->port = SCM_PORT(val);
}
else if (SCM_FALSEP(val)) {
obj->port = NULL;
}
else {
Scm_Error("input port or #f required, but got %S", val);
}
}
int Scm_CharToUcs(ScmChar ch)
{
if (ch == SCM_CHAR_INVALID) Scm_Error("bad character");
#if defined(GAUCHE_CHAR_ENCODING_UTF_8)
return (int)ch;
#elif defined(GAUCHE_CHAR_ENCODING_EUC_JP) || defined(GAUCHE_CHAR_ENCODING_SJIS)
if (ch < 0x80) return (int)ch; /*ASCII range*/
if (char2ucs_hook == NULL) {
/* NB: we don't need mutex here, for the loading of gauche.charconv
is serialized in Scm_Require. */
Scm_Require(SCM_MAKE_STR("gauche/charconv"),
SCM_LOAD_PROPAGATE_ERROR, NULL);
if (char2ucs_hook == NULL) {
Scm_Error("couldn't autoload gauche.charconv");
}
}
return char2ucs_hook(ch);
#else
return (int)ch; /* ISO8859-1 */
#endif /*!GAUCHE_CHAR_ENCODING_UTF_8*/
}
ScmObj Scm_MakeOutputConversionPort(ScmPort *toPort,
const char *toCode,
const char *fromCode,
int bufsiz, int ownerp)
{
if (!SCM_OPORTP(toPort))
Scm_Error("output port required, but got %S", toPort);
if (bufsiz <= 0) bufsiz = DEFAULT_CONVERSION_BUFFER_SIZE;
if (bufsiz <= MINIMUM_CONVERSION_BUFFER_SIZE) {
bufsiz = MINIMUM_CONVERSION_BUFFER_SIZE;
}
ScmConvInfo *cinfo = jconv_open(toCode, fromCode);
if (cinfo == NULL) {
Scm_Error("conversion from code %s to code %s is not supported",
fromCode, toCode);
}
cinfo->remote = toPort;
cinfo->ownerp = ownerp;
cinfo->bufsiz = (bufsiz > 0)? bufsiz : DEFAULT_CONVERSION_BUFFER_SIZE;
cinfo->remoteClosed = FALSE;
cinfo->buf = SCM_NEW_ATOMIC2(char *, cinfo->bufsiz);
cinfo->ptr = cinfo->buf;
ScmPortBuffer bufrec;
memset(&bufrec, 0, sizeof(bufrec));
bufrec.size = cinfo->bufsiz;
bufrec.buffer = SCM_NEW_ATOMIC2(char *, cinfo->bufsiz);
bufrec.mode = SCM_PORT_BUFFER_FULL;
bufrec.filler = NULL;
bufrec.flusher = conv_output_flusher;
bufrec.closer = conv_output_closer;
bufrec.ready = conv_ready;
bufrec.filenum = conv_fileno;
bufrec.data = (void*)cinfo;
ScmObj name = conv_name(SCM_PORT_OUTPUT, toPort, fromCode, toCode);
return Scm_MakeBufferedPort(SCM_CLASS_PORT, name, SCM_PORT_OUTPUT, TRUE, &bufrec);
}
ScmObj *Scm_ListToArray(ScmObj list, int *nelts, ScmObj *store, int alloc)
{
ScmObj *array, lp;
int len = Scm_Length(list), i;
if (len < 0) Scm_Error("proper list required, but got %S", list);
if (store == NULL) {
array = SCM_NEW_ARRAY(ScmObj, len);
} else {
if (*nelts < len) {
if (!alloc)
Scm_Error("ListToArray: storage too small");
array = SCM_NEW_ARRAY(ScmObj, len);
} else {
array = store;
}
}
for (i=0, lp=list; i<len; i++, lp=SCM_CDR(lp)) {
array[i] = SCM_CAR(lp);
}
*nelts = len;
return array;
}
void write_clipboard(const char* str)
{
HGLOBAL hText;
WCHAR *pText;
int nc = MultiByteToWideChar(CP_UTF8, 0, str, -1, NULL, 0);
if (nc == 0) {
Scm_Error("Windows error %d on MultiByteToWideChar", GetLastError());
}
hText = GlobalAlloc(GMEM_DDESHARE | GMEM_MOVEABLE, 2*nc);
pText = GlobalLock(hText);
if(MultiByteToWideChar(CP_UTF8, 0, str, -1, pText, nc) == 0) {
GlobalUnlock(hText);
Scm_Error("Windows error %d on MultiByteToWideChar", GetLastError());
}
GlobalUnlock(hText);
OpenClipboard(NULL);
EmptyClipboard();
SetClipboardData(CF_UNICODETEXT, hText);
CloseClipboard();
}
/* Default method for write-object */
static ScmObj write_object_fallback(ScmObj *args, int nargs, ScmGeneric *gf)
{
if (nargs != 2 || (nargs == 2 && !SCM_OPORTP(args[1]))) {
Scm_Error("No applicable method for write-object with %S",
Scm_ArrayToList(args, nargs));
}
ScmClass *klass = Scm_ClassOf(args[0]);
Scm_Printf(SCM_PORT(args[1]), "#<%A%s%p>",
klass->name,
(SCM_FALSEP(klass->redefined)? " " : ":redefined "),
args[0]);
return SCM_TRUE;
}
