int graphicsGdImageStringFT(gdImage *im, ScmPair **brect0, ScmPair **brect1, ScmPair **brect2, ScmPair **brect3, int fg, ScmString *fontlist, double ptsize, double angle, int x, int y, ScmString *str) { int brect[8]; char *s = Scm_GetString(str); char *fl = Scm_GetString(fontlist); char *e = gdImageStringFT(im, brect, fg, fl, ptsize, angle, x, y, s); if (e == NULL) { *brect0 = SCM_NEW(ScmPair); SCM_SET_CAR(*brect0, Scm_MakeInteger(brect[0])); SCM_SET_CDR(*brect0, Scm_MakeInteger(brect[1])); *brect1 = SCM_NEW(ScmPair); SCM_SET_CAR(*brect1, Scm_MakeInteger(brect[2])); SCM_SET_CDR(*brect1, Scm_MakeInteger(brect[3])); *brect2 = SCM_NEW(ScmPair); SCM_SET_CAR(*brect2, Scm_MakeInteger(brect[4])); SCM_SET_CDR(*brect2, Scm_MakeInteger(brect[5])); *brect3 = SCM_NEW(ScmPair); SCM_SET_CAR(*brect3, Scm_MakeInteger(brect[6])); SCM_SET_CDR(*brect3, Scm_MakeInteger(brect[7])); return 0; } else { graphicsGdRaiseCondition("gdImageStringFT failed: %s", e); return -1; } }
ScmObj Scm_Acons(ScmObj caar, ScmObj cdar, ScmObj cdr) { ScmPair *y = SCM_NEW(ScmPair); ScmPair *z = SCM_NEW(ScmPair); SCM_SET_CAR(y, caar); SCM_SET_CDR(y, cdar); SCM_SET_CAR(z, SCM_OBJ(y)); SCM_SET_CDR(z, cdr); return SCM_OBJ(z); }
static void message_prefix_set(ScmMessageCondition *obj, ScmObj val) { ScmObj msglist = obj->message; if (SCM_PAIRP(msglist) && SCM_PAIRP(SCM_CDR(msglist))) { SCM_SET_CAR(SCM_CDR(msglist), val); } else { obj->message = SCM_LIST2(msglist, val); } }
/* 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. */
ScmObj Scm_Cons(ScmObj car, ScmObj cdr) { ScmPair *z = SCM_NEW(ScmPair); /* NB: these ENSURE_MEMs are moved here from vm loop to reduce the register pressure there. In most cases these increases just a couple of mask-and-test instructions on the data on the register. */ SCM_FLONUM_ENSURE_MEM(car); SCM_FLONUM_ENSURE_MEM(cdr); SCM_SET_CAR(z, car); SCM_SET_CDR(z, cdr); return SCM_OBJ(z); }
ScmObj Scm_VaList(va_list pvar) { ScmObj start = SCM_NIL, cp = SCM_NIL, obj; for (obj = va_arg(pvar, ScmObj); obj != NULL; obj = va_arg(pvar, ScmObj)) { if (SCM_NULLP(start)) { start = SCM_OBJ(SCM_NEW(ScmPair)); SCM_SET_CAR(start, obj); SCM_SET_CDR(start, SCM_NIL); cp = start; } else { ScmObj item; item = SCM_OBJ(SCM_NEW(ScmPair)); SCM_SET_CDR(cp, item); SCM_SET_CAR(item, obj); SCM_SET_CDR(item, SCM_NIL); cp = item; } } return start; }
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 */ }
static ScmObj sort_list_int(ScmObj objs, ScmObj fn, int destructive) { ScmObj starray[STATIC_SIZE]; int len = STATIC_SIZE; ScmObj *array = Scm_ListToArray(objs, &len, starray, TRUE); Scm_SortArray(array, len, fn); if (destructive) { ScmObj cp = objs; for (int i=0; i<len; i++, cp = SCM_CDR(cp)) { SCM_SET_CAR(cp, array[i]); } return objs; } else { return Scm_ArrayToList(array, len); } }
/* 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 }
static void message_set(ScmMessageCondition *obj, ScmObj val) { ScmObj msglist = obj->message; if (SCM_PAIRP(msglist)) SCM_SET_CAR(msglist, val); else SCM_MESSAGE_CONDITION(obj)->message = SCM_LIST2(val, val); }
/* 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 }