/*------------------------------------------------------------ * 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); } }
SCM_EXPORT ScmObj scm_p_srfi60_logtest(ScmObj j, ScmObj k) { DECLARE_FUNCTION("logtest", procedure_fixed_2); ENSURE_INT(j); ENSURE_INT(k); return MAKE_BOOL(SCM_INT_VALUE(j) & SCM_INT_VALUE(k)); }
SCM_EXPORT ScmObj scm_p_prealloc_heaps(ScmObj n) { DECLARE_FUNCTION("%%prealloc-heaps", procedure_fixed_1); ENSURE_INT(n); if (SCM_INT_VALUE(n) < 0) ERR_OBJ("non-negative number required but got", n); scm_prealloc_heaps((size_t)SCM_INT_VALUE(n)); return n; }
SCM_EXPORT ScmObj scm_p_srfi60_bitwise_if(ScmObj mask, ScmObj n0, ScmObj n1) { scm_int_t result, c_mask; DECLARE_FUNCTION("bitwise-if", procedure_fixed_3); ENSURE_INT(mask); ENSURE_INT(n0); ENSURE_INT(n1); c_mask = SCM_INT_VALUE(mask); result = (c_mask & SCM_INT_VALUE(n0)) | (~c_mask & SCM_INT_VALUE(n1)); return MAKE_INT(result); }
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; } }
/*------------------------------------------------------------ * 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); } }
u_long Scm_EqvHash(ScmObj obj) { u_long hashval; if (SCM_NUMBERP(obj)) { if (SCM_INTP(obj)) { SMALL_INT_HASH(hashval, SCM_INT_VALUE(obj)); } else if (SCM_BIGNUMP(obj)) { u_int i; u_long u = 0; for (i=0; i<SCM_BIGNUM_SIZE(obj); i++) { u += SCM_BIGNUM(obj)->values[i]; } SMALL_INT_HASH(hashval, u); } else if (SCM_FLONUMP(obj)) { /* TODO: I'm not sure this is a good hash. */ hashval = (u_long)(SCM_FLONUM_VALUE(obj)*2654435761UL); } else if (SCM_RATNUMP(obj)) { /* Ratnum must be normalized, so we can simply combine hashvals of numerator and denominator. */ u_long h1 = Scm_EqvHash(SCM_RATNUM_NUMER(obj)); u_long h2 = Scm_EqvHash(SCM_RATNUM_DENOM(obj)); hashval = COMBINE(h1, h2); } else { /* TODO: I'm not sure this is a good hash. */ hashval = (u_long)((SCM_COMPNUM_REAL(obj)+SCM_COMPNUM_IMAG(obj))*2654435761UL); } } else { ADDRESS_HASH(hashval, obj); } return hashval&HASHMASK; }
static int prepare_radix(const char *funcname, ScmObj args) { ScmObj radix; int r; DECLARE_INTERNAL_FUNCTION("(internal)"); ASSERT_PROPER_ARG_LIST(args); /* dirty hack to replace internal function name */ SCM_MANGLE(name) = funcname; if (NULLP(args)) { r = 10; } else { radix = POP(args); ASSERT_NO_MORE_ARG(args); ENSURE_INT(radix); r = SCM_INT_VALUE(radix); if (!VALID_RADIXP(r)) ERR_OBJ("invalid radix", radix); } return r; }
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 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 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); }
/* 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; }
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() */ }
static ScmObj scm_p_set_macro_debug_flagsx(ScmObj new_mode) { SCM_ASSERT(INTP(new_mode)); l_debug_mode = SCM_INT_VALUE(new_mode); return SCM_UNDEF; }
static int cmp_scm(ScmObj x, ScmObj y, ScmObj fn) { ScmObj r = Scm_ApplyRec(fn, SCM_LIST2(x, y)); if (SCM_TRUEP(r) || (SCM_INTP(r) && SCM_INT_VALUE(r) < 0)) return -1; else return 1; }
/*------------------------------------------------------------ * Bport filenum */ static int bport_filenum(ScmPort *p) { bport *data = (bport*)p->src.buf.data; SCM_ASSERT(data != NULL); if (SCM_FALSEP(data->filenum_proc)) { return -1; } else { ScmObj s = Scm_ApplyRec(data->filenum_proc, SCM_NIL); if (SCM_INTP(s)) return SCM_INT_VALUE(s); else return -1; } }
/* 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; }
/*------------------------------------------------------------ * Bport fill */ static int bport_fill(ScmPort *p, int cnt) { bport *data = (bport*)p->src.buf.data; SCM_ASSERT(data != NULL); if (SCM_FALSEP(data->fill_proc)) { return 0; /* indicates EOF */ } ScmObj vec = Scm_MakeU8VectorFromArrayShared( cnt, (unsigned char*)p->src.buf.buffer); ScmObj r = Scm_ApplyRec(data->fill_proc, SCM_LIST1(vec)); if (SCM_INTP(r)) return SCM_INT_VALUE(r); else if (SCM_EOFP(r)) return 0; else return -1; }
/* multifunction on sigset if delp == FALSE, signals are added to set. else, signals are removed from set. signals is a list of either integer or #t (all signals), or other sigset. */ ScmObj Scm_SysSigsetOp(ScmSysSigset *set, ScmObj signals, int delp) { if (!SCM_PAIRP(signals)) { Scm_Error("list of signals required, but got %S", signals); } ScmObj cp; SCM_FOR_EACH(cp, signals) { ScmObj s = SCM_CAR(cp); if (SCM_TRUEP(s)) { if (!delp) sigfillset(&set->set); else sigemptyset(&set->set); break; } if (SCM_SYS_SIGSET_P(s)) { sigset_op(&set->set, &SCM_SYS_SIGSET(s)->set, delp); continue; } if (!SCM_INTP(s) || !validsigp(SCM_INT_VALUE(s))) { Scm_Error("bad signal number %S", s); } if (!delp) sigaddset(&set->set, SCM_INT_VALUE(s)); else sigdelset(&set->set, SCM_INT_VALUE(s)); }
/*------------------------------------------------------------ * Bport flush */ static int bport_flush(ScmPort *p, int cnt, int forcep) { bport *data = (bport*)p->src.buf.data; ScmObj vec, r; SCM_ASSERT(data != NULL); if (SCM_FALSEP(data->flush_proc)) { return cnt; /* blackhole */ } vec = Scm_MakeU8VectorFromArrayShared(cnt, (unsigned char*)p->src.buf.buffer); r = Scm_ApplyRec(data->flush_proc, SCM_LIST2(vec, SCM_MAKE_BOOL(forcep))); if (SCM_INTP(r)) return SCM_INT_VALUE(r); else if (SCM_EOFP(r)) return 0; else return -1; }
void Scm_ProfilerCountBufferFlush(ScmVM *vm) { if (vm->prof == NULL) return; /* for safety */ if (vm->prof->currentCount == 0) return; /* suspend itimer during hash table operation */ #if !defined(GAUCHE_WINDOWS) sigset_t set; sigemptyset(&set); sigaddset(&set, SIGPROF); SIGPROCMASK(SIG_BLOCK, &set, NULL); #endif /* !GAUCHE_WINDOWS */ int ncounts = vm->prof->currentCount; for (int i=0; i<ncounts; i++) { ScmObj e; int cnt; ScmObj func = vm->prof->counts[i].func; if (SCM_METHODP(func) && SCM_METHOD(func)->func == NULL) { /* func is Scheme-defined method. Record the code of method body, so that we can match it with sampling profiler later. */ func = SCM_OBJ(SCM_METHOD(func)->data); } e = Scm_HashTableSet(vm->prof->statHash, vm->prof->counts[i].func, SCM_FALSE, SCM_DICT_NO_OVERWRITE); if (SCM_FALSEP(e)) { e = Scm_HashTableSet(vm->prof->statHash, vm->prof->counts[i].func, Scm_Cons(SCM_MAKE_INT(0), SCM_MAKE_INT(0)), 0); } SCM_ASSERT(SCM_PAIRP(e)); cnt = SCM_INT_VALUE(SCM_CAR(e)) + 1; SCM_SET_CAR(e, SCM_MAKE_INT(cnt)); } vm->prof->currentCount = 0; /* resume itimer */ #if !defined(GAUCHE_WINDOWS) SIGPROCMASK(SIG_UNBLOCK, &set, NULL); #endif /* !GAUCHE_WINDOWS */ }
/* register samples into the stat table. Called from Scm_ProfilerResult */ void collect_samples(ScmVMProfiler *prof) { for (int i=0; i<prof->currentSample; i++) { ScmObj e = Scm_HashTableRef(prof->statHash, prof->samples[i].func, SCM_UNBOUND); if (SCM_UNBOUNDP(e)) { /* NB: just for now */ Scm_Warn("profiler: uncounted object appeared in a sample: %p (%S)\n", prof->samples[i].func, prof->samples[i].func); } else { SCM_ASSERT(SCM_PAIRP(e)); int cnt = SCM_INT_VALUE(SCM_CDR(e)) + 1; SCM_SET_CDR(e, SCM_MAKE_INT(cnt)); } } }
void graphicsGdImageSetStyle(gdImage *im, ScmObj style, int styleLength) { ScmObj head; int *p, *q, i = 0; CHECK_LIST_AND_LENGTH(style, styleLength); p = q = calloc(styleLength, sizeof(int)); if (p == NULL) { graphicsGdRaiseCondition("calloc failed: %s", "graphicsGdImageSetStyle"); return; } SCM_FOR_EACH (head, style) { if (i++ == styleLength) break; *q++ = SCM_INT_VALUE(SCM_CAR(head)); } gdImageSetStyle(im, p, styleLength); free(p); }
SCM_EXPORT ScmObj scm_p_number2string(ScmObj num, ScmObj args) { char *str; intmax_t n; int r; ScmValueFormat vfmt; DECLARE_FUNCTION("number->string", procedure_variadic_1); ENSURE_INT(num); n = (intmax_t)SCM_INT_VALUE(num); r = prepare_radix(SCM_MANGLE(name), args); SCM_VALUE_FORMAT_INIT(vfmt); str = scm_int2string(vfmt, (uintmax_t)n, r); return MAKE_STRING(str, SCM_STRLEN_UNKNOWN); }
SCM_EXPORT ScmObj scm_p_exit(ScmObj args) { ScmObj explicit_status; int status; DECLARE_FUNCTION("exit", procedure_variadic_0); if (NULLP(args)) { status = EXIT_SUCCESS; } else { explicit_status = POP(args); ASSERT_NO_MORE_ARG(args); ENSURE_INT(explicit_status); status = SCM_INT_VALUE(explicit_status); } scm_finalize(); exit(status); }
ScmObj Scm_MakeBignumFromDouble(double val) { int exponent, sign; ScmObj mantissa, b; if (val >= LONG_MIN && val <= LONG_MAX) { return Scm_MakeBignumFromSI((long)val); } mantissa = Scm_DecodeFlonum(val, &exponent, &sign); if (!SCM_NUMBERP(mantissa)) { Scm_Error("can't convert %lf to an integer", val); } 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; } }
static void write_obj(ScmObj port, ScmObj obj, enum ScmOutputType otype) { ScmObj sym; #if SCM_USE_SRFI38 if (INTERESTINGP(obj)) { scm_intobj_t index = get_shared_index(obj); if (index > 0) { /* defined datum */ scm_format(port, SCM_FMT_RAW_C, "#~ZU#", (size_t)index); return; } if (index < 0) { /* defining datum, with the new index negated */ scm_format(port, SCM_FMT_RAW_C, "#~ZU=", (size_t)-index); /* Print it; the next time it'll be defined. */ } } #endif switch (SCM_TYPE(obj)) { #if SCM_USE_INT case ScmInt: scm_format(port, SCM_FMT_RAW_C, "~MD", SCM_INT_VALUE(obj)); break; #endif case ScmCons: if (ERROBJP(obj)) write_errobj(port, obj, otype); else write_list(port, obj, otype); break; case ScmSymbol: scm_port_puts(port, SCM_SYMBOL_NAME(obj)); break; #if SCM_USE_CHAR case ScmChar: write_char(port, obj, otype); break; #endif #if SCM_USE_STRING case ScmString: write_string(port, obj, otype); break; #endif case ScmFunc: scm_port_puts(port, (SCM_SYNTAXP(obj)) ? "#<syntax " : "#<subr "); sym = scm_symbol_bound_to(obj); if (TRUEP(sym)) scm_display(port, sym); else scm_format(port, SCM_FMT_RAW_C, "~P", (void *)obj); scm_port_put_char(port, '>'); break; #if SCM_USE_HYGIENIC_MACRO case ScmMacro: scm_port_puts(port, "#<macro "); write_obj(port, SCM_HMACRO_RULES(obj), otype); scm_port_puts(port, ">"); break; case ScmFarsymbol: write_farsymbol(port, obj, otype); break; case ScmSubpat: if (SCM_SUBPAT_PVARP(obj)) { #if SCM_DEBUG_MACRO scm_port_puts(port, "#<pvar "); write_obj(port, SCM_SUBPAT_OBJ(obj), otype); scm_format(port, SCM_FMT_RAW_C, " ~MD>", SCM_SUBPAT_PVAR_INDEX(obj)); #else /* not SCM_DEBUG_MACRO */ write_obj(port, SCM_SUBPAT_OBJ(obj), otype); #endif /* not SCM_DEBUG_MACRO */ } else { SCM_ASSERT(SCM_SUBPAT_REPPATP(obj)); write_obj(port, SCM_SUBPAT_REPPAT_PAT(obj), otype); #if SCM_DEBUG_MACRO scm_format(port, SCM_FMT_RAW_C, " ..[~MD]..", SCM_SUBPAT_REPPAT_PVCOUNT(obj)); #else scm_port_puts(port, " ..."); #endif } break; #endif /* SCM_USE_HYGIENIC_MACRO */ case ScmClosure: #if SCM_USE_LEGACY_MACRO if (SYNTACTIC_CLOSUREP(obj)) scm_port_puts(port, "#<syntactic closure "); else #endif scm_port_puts(port, "#<closure "); write_obj(port, SCM_CLOSURE_EXP(obj), otype); scm_port_put_char(port, '>'); break; #if SCM_USE_VECTOR case ScmVector: write_vector(port, obj, otype); break; #endif case ScmPort: write_port(port, obj, otype); break; #if SCM_USE_CONTINUATION case ScmContinuation: scm_format(port, SCM_FMT_RAW_C, "#<continuation ~P>", (void *)obj); break; #endif case ScmValuePacket: scm_port_puts(port, "#<values "); write_obj(port, SCM_VALUEPACKET_VALUES(obj), otype); #if SCM_USE_VALUECONS #if SCM_USE_STORAGE_FATTY /* SCM_VALUEPACKET_VALUES() changes the type destructively */ SCM_ENTYPE(obj, ScmValuePacket); #else /* SCM_USE_STORAGE_FATTY */ #error "valuecons is not supported on this storage implementation" #endif /* SCM_USE_STORAGE_FATTY */ #endif /* SCM_USE_VALUECONS */ scm_port_put_char(port, '>'); break; case ScmConstant: write_constant(port, obj, otype); break; #if SCM_USE_SSCM_EXTENSIONS case ScmCPointer: scm_format(port, SCM_FMT_RAW_C, "#<c_pointer ~P>", SCM_C_POINTER_VALUE(obj)); break; case ScmCFuncPointer: scm_format(port, SCM_FMT_RAW_C, "#<c_func_pointer ~P>", (void *)(uintptr_t)SCM_C_FUNCPOINTER_VALUE(obj)); break; #endif case ScmRational: case ScmReal: case ScmComplex: default: SCM_NOTREACHED; } }
/* Trick: The hashtable contains positive integer after the walk pass. If we emit a reference tag N, we replace the entry's value to -N, so that we can distinguish whether we've already emitted the object or not. */ static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx) { char numbuf[50]; /* enough to contain long number */ ScmObj stack = SCM_NIL; ScmWriteState *st = port->writeState; ScmHashTable *ht = (st? st->sharedTable : NULL); int stack_depth = 0; #define PUSH(elt) \ do { \ stack = Scm_Cons(elt, stack); \ if (!ht && ++stack_depth > STACK_LIMIT) { \ Scm_Error("write recursed too deeply; " \ "maybe a circular structure?"); \ } \ } while (0) #define POP() \ do { \ stack = SCM_CDR(stack); \ if (ht) stack_depth--; \ } while (0) for (;;) { write1: if (ctx->flags & WRITE_LIMITED) { if (port->src.ostr.length >= ctx->limit) return; } /* number may be heap allocated, but we don't use srfi-38 notation. */ if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) { if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) { Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj)); } goto next; } if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0) || (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) { /* we don't put a reference tag for these */ write_general(obj, port, ctx); goto next; } if (ht) { ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1)); long k = SCM_INT_VALUE(e); if (k <= 0) { /* This object is already printed. */ snprintf(numbuf, 50, "#%ld#", -k); Scm_PutzUnsafe(numbuf, -1, port); goto next; } else if (k > 1) { /* This object will be seen again. Put a reference tag. */ ScmWriteState *s = port->writeState; snprintf(numbuf, 50, "#%d=", s->sharedCounter); Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0); s->sharedCounter++; Scm_PutzUnsafe(numbuf, -1, port); } } /* Writes aggregates */ if (SCM_PAIRP(obj)) { /* special case for quote etc. NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll get infinite recursion for the case like (cdr '#1='#1#). */ if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj)) && (!ht || SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){ const char *prefix = NULL; if (SCM_CAR(obj) == SCM_SYM_QUOTE) { prefix = "'"; } else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) { prefix = "`"; } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) { prefix = ","; } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) { prefix = ",@"; } if (prefix) { Scm_PutzUnsafe(prefix, -1, port); obj = SCM_CADR(obj); goto write1; } } /* normal case */ Scm_PutcUnsafe('(', port); PUSH(Scm_Cons(SCM_TRUE, SCM_CDR(obj))); obj = SCM_CAR(obj); goto write1; } else if (SCM_VECTORP(obj)) { Scm_PutzUnsafe("#(", -1, port); PUSH(Scm_Cons(SCM_MAKE_INT(1), obj)); obj = SCM_VECTOR_ELEMENT(obj, 0); goto write1; } else { /* string or user-defined object */ write_general(obj, port, ctx); goto next; } next: while (SCM_PAIRP(stack)) { ScmObj top = SCM_CAR(stack); SCM_ASSERT(SCM_PAIRP(top)); if (SCM_INTP(SCM_CAR(top))) { /* we're processing a vector */ ScmObj v = SCM_CDR(top); int i = SCM_INT_VALUE(SCM_CAR(top)); int len = SCM_VECTOR_SIZE(v); if (i == len) { /* we've done this vector */ Scm_PutcUnsafe(')', port); POP(); } else { Scm_PutcUnsafe(' ', port); obj = SCM_VECTOR_ELEMENT(v, i); SCM_SET_CAR(top, SCM_MAKE_INT(i+1)); goto write1; } } else { /* we're processing a list */ ScmObj v = SCM_CDR(top); if (SCM_NULLP(v)) { /* we've done with this list */ Scm_PutcUnsafe(')', port); POP(); } else if (!SCM_PAIRP(v)) { Scm_PutzUnsafe(" . ", -1, port); obj = v; SCM_SET_CDR(top, SCM_NIL); goto write1; } else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1))) { /* cdr part is shared */ Scm_PutzUnsafe(" . ", -1, port); obj = v; SCM_SET_CDR(top, SCM_NIL); goto write1; } else { Scm_PutcUnsafe(' ', port); obj = SCM_CAR(v); SCM_SET_CDR(top, SCM_CDR(v)); goto write1; } } } break; } #undef PUSH #undef POP }
/* Trick: The hashtable contains positive integer after the walk pass. If we emit a reference tag N, we replace the entry's value to -N, so that we can distinguish whether we've already emitted the object or not. */ static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx) { char numbuf[50]; /* enough to contain long number */ ScmObj stack = SCM_NIL; ScmWriteState *st = port->writeState; ScmHashTable *ht = (st? st->sharedTable : NULL); const ScmWriteControls *wp = Scm_GetWriteControls(ctx, st); int stack_depth = 0; /* only used when !ht */ #define PUSH(elt) \ do { \ stack = Scm_Cons(elt, stack); \ if (!ht && ++stack_depth > STACK_LIMIT) { \ Scm_Error("write recursed too deeply; " \ "maybe a circular structure?"); \ } \ } while (0) #define POP() \ do { \ stack = SCM_CDR(stack); \ if (!ht) stack_depth--; \ } while (0) #define CHECK_LEVEL() \ do { \ if (st) { \ if (wp->printLevel >= 0 && st->currentLevel >= wp->printLevel) { \ Scm_PutcUnsafe('#', port); \ goto next; \ } else { \ if (st) st->currentLevel++; \ } \ } \ } while (0) for (;;) { write1: if (ctx->flags & WRITE_LIMITED) { if (port->src.ostr.length >= ctx->limit) return; } /* number may be heap allocated, but we don't use srfi-38 notation. */ if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) { if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) { Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj)); } goto next; } if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0) || (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) { /* we don't put a reference tag for these */ write_general(obj, port, ctx); goto next; } /* obj is heap allocated and we may use label notation. */ if (ht) { ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1)); long k = SCM_INT_VALUE(e); if (k <= 0) { /* This object is already printed. */ snprintf(numbuf, 50, "#%ld#", -k); Scm_PutzUnsafe(numbuf, -1, port); goto next; } else if (k > 1) { /* This object will be seen again. Put a reference tag. */ ScmWriteState *s = port->writeState; snprintf(numbuf, 50, "#%d=", s->sharedCounter); Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0); s->sharedCounter++; Scm_PutzUnsafe(numbuf, -1, port); } } /* Writes aggregates */ if (SCM_PAIRP(obj)) { CHECK_LEVEL(); /* special case for quote etc. NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll get infinite recursion for the case like (cdr '#1='#1#). */ if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj)) && (!ht || SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){ const char *prefix = NULL; if (SCM_CAR(obj) == SCM_SYM_QUOTE) { prefix = "'"; } else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) { prefix = "`"; } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) { prefix = ","; } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) { prefix = ",@"; } if (prefix) { Scm_PutzUnsafe(prefix, -1, port); obj = SCM_CADR(obj); goto write1; } } if (wp->printLength == 0) { /* in this case we don't print the elements at all, so we need to treat this specially. */ Scm_PutzUnsafe("(...)", -1, port); if (st) st->currentLevel--; goto next; } /* normal case */ Scm_PutcUnsafe('(', port); PUSH(Scm_Cons(SCM_TRUE, Scm_Cons(SCM_MAKE_INT(1), SCM_CDR(obj)))); obj = SCM_CAR(obj); goto write1; } else if (SCM_VECTORP(obj)) { CHECK_LEVEL(); if (wp->printLength == 0) { /* in this case we don't print the elements at all, so we need to treat this specially. */ Scm_PutzUnsafe("#(...)", -1, port); if (st) st->currentLevel--; goto next; } Scm_PutzUnsafe("#(", -1, port); PUSH(Scm_Cons(SCM_MAKE_INT(1), obj)); obj = SCM_VECTOR_ELEMENT(obj, 0); goto write1; } else if (Scm_ClassOf(obj)->flags & SCM_CLASS_AGGREGATE) { CHECK_LEVEL(); write_general(obj, port, ctx); if (st) st->currentLevel--; goto next; } else { write_general(obj, port, ctx); goto next; } next: while (SCM_PAIRP(stack)) { ScmObj top = SCM_CAR(stack); SCM_ASSERT(SCM_PAIRP(top)); if (SCM_INTP(SCM_CAR(top))) { /* we're processing a vector */ ScmObj v = SCM_CDR(top); int i = SCM_INT_VALUE(SCM_CAR(top)); int len = SCM_VECTOR_SIZE(v); if (i == len) { /* we've done this vector */ Scm_PutcUnsafe(')', port); POP(); } else if (wp->printLength >= 0 && wp->printLength <= i) { Scm_PutzUnsafe(" ...)", -1, port); POP(); } else { Scm_PutcUnsafe(' ', port); obj = SCM_VECTOR_ELEMENT(v, i); SCM_SET_CAR(top, SCM_MAKE_INT(i+1)); goto write1; } } else { /* we're processing a list */ SCM_ASSERT(SCM_PAIRP(SCM_CDR(top))); long count = SCM_INT_VALUE(SCM_CADR(top)); ScmObj v = SCM_CDDR(top); if (SCM_NULLP(v)) { /* we've done with this list */ Scm_PutcUnsafe(')', port); POP(); } else if (!SCM_PAIRP(v)) { /* Improper list. We treat aggregate types specially, since such object at this position shouldn't increment "level" - its content is regarded as the same level of the current list. */ Scm_PutzUnsafe(" . ", -1, port); if (Scm_ClassOf(v)->flags & SCM_CLASS_AGGREGATE) { if (st) st->currentLevel--; write_rec(v, port, ctx); if (st) st->currentLevel++; Scm_PutcUnsafe(')', port); POP(); } else { obj = v; SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1)); SCM_SET_CDR(SCM_CDR(top), SCM_NIL); goto write1; } } else if (wp->printLength >= 0 && wp->printLength <= count) { /* print-length limit reached */ Scm_PutzUnsafe(" ...)", -1, port); POP(); } else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1))) { /* cdr part is shared */ Scm_PutzUnsafe(" . ", -1, port); obj = v; SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1)); SCM_SET_CDR(SCM_CDR(top), SCM_NIL); goto write1; } else { Scm_PutcUnsafe(' ', port); obj = SCM_CAR(v); SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1)); SCM_SET_CDR(SCM_CDR(top), SCM_CDR(v)); goto write1; } } if (st) st->currentLevel--; } break; } #undef PUSH #undef POP #undef CHECK_DEPTH }
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; }