static LISP
frob(LISP arg)
{
printf("frob called: ");
if FLONUMP(arg)
printf("%d\n", (int)FLONM(arg));
else
static void siag_print(LISP p)
{
if (FLONUMP(p)) {
siag_type = EXPRESSION;
siag_result.number = FLONM(p);
} else if (TYPEP(p, tc_string)) {
siag_type = STRING;
siag_result.text = p->storage_as.string.data;
} else {
siag_type = ERROR;
siag_result.number = 0, errorflag = 1;
}
}
static LISP ani_property(LISP name, LISP value)
{
buffer *b = w_list->buf;
MwAniScript *lasts = w_list->script;
MwAniObject *lasto = w_list->object;
int n = get_c_long(name);
if (!lasts) err("Last script is NULL", NIL);
if (FLONUMP(value)) {
int lv = get_c_long(value);
switch (n) {
case MW_ANI_X:
lasts->x = lv;
break;
case MW_ANI_Y:
lasts->y = lv;
break;
case MW_ANI_WIDTH:
lasts->width = lv;
break;
case MW_ANI_HEIGHT:
lasts->height = lv;
break;
case MW_ANI_VISIBLE:
lasts->visible = lv;
break;
case MW_ANI_FORMAT:
lasto->fmt = lv;
break;
default:
err("No such property", name);
}
} else {
char *tv = get_c_string(value);
switch (n) {
case MW_ANI_TEXT:
lasto->string = MwStrdup(tv);
break;
default:
err("No such property", name);
}
}
b->change = TRUE;
pr_scr_flag = TRUE;
return NIL;
}
void
finalize(object_heap_t* heap, void* obj)
{
// do not access shared object during finalize, it may collected.
assert(heap->is_collectible(obj));
if (PAIRP(obj)) {
assert(false);
}
if (FLONUMP(obj)) {
assert(false);
}
int tc = HDR_TC(HDR(obj));
assert(tc >= 0);
assert(tc <= TC_MASKBITS);
switch (tc) {
case TC_BIGNUM: {
scm_bignum_t bignum = (scm_bignum_t)obj;
if (bignum->elts != (digit_t*)((uintptr_t)bignum + sizeof(scm_bignum_rec_t))) {
heap->deallocate_private(bignum->elts);
}
break;
}
case TC_SYMBOL: {
scm_symbol_t symbol = (scm_symbol_t)obj;
if (symbol->name != (char*)((uintptr_t)symbol + sizeof(scm_symbol_rec_t))) {
heap->deallocate_private(symbol->name);
}
break;
}
case TC_STRING: {
scm_string_t string = (scm_string_t)obj;
if (string->name != (char*)((uintptr_t)string + sizeof(scm_string_rec_t))) {
heap->deallocate_private(string->name);
}
break;
}
case TC_VECTOR: {
scm_vector_t vector = (scm_vector_t)obj;
if (vector->elts != (scm_obj_t*)((uintptr_t)vector + sizeof(scm_vector_rec_t))) {
heap->deallocate_private(vector->elts);
}
break;
}
case TC_BVECTOR: {
scm_bvector_t bvector = (scm_bvector_t)obj;
if (HDR_BVECTOR_MAPPING(bvector->hdr) == 0) heap->deallocate_private(bvector->elts);
break;
}
case TC_TUPLE: {
scm_tuple_t tuple = (scm_tuple_t)obj;
if (tuple->elts != (scm_obj_t*)((uintptr_t)tuple + sizeof(scm_tuple_rec_t))) {
heap->deallocate_private(tuple->elts);
}
break;
}
case TC_VALUES: {
scm_values_t values = (scm_values_t)obj;
if (values->elts != (scm_obj_t*)((uintptr_t)values + sizeof(scm_values_rec_t))) {
heap->deallocate_private(values->elts);
}
break;
}
case TC_HASHTABLE: {
scm_hashtable_t ht = (scm_hashtable_t)obj;
heap->deallocate_private(ht->datum);
ht->lock.destroy();
break;
}
case TC_WEAKHASHTABLE: {
scm_weakhashtable_t ht = (scm_weakhashtable_t)obj;
heap->deallocate_private(ht->datum);
ht->lock.destroy();
break;
}
case TC_PORT: {
scm_port_t port = (scm_port_t)obj;
{
scoped_lock lock(port->lock);
if (port->type != SCM_PORT_TYPE_CUSTOM) port_close(port);
// todo: finalizer for custom port
}
port->lock.destroy();
break;
}
case TC_SOCKET: {
scm_socket_t socket = (scm_socket_t)obj;
socket_close(socket);
break;
}
case TC_SHAREDQUEUE: {
scm_sharedqueue_t queue = (scm_sharedqueue_t)obj;
queue->buf.destroy();
queue->queue.destroy();
break;
}
case TC_SHAREDBAG: {
scm_sharedbag_t bag = (scm_sharedbag_t)obj;
for (int i = 0; i < bag->capacity; i++) {
bag->datum[i]->buf.destroy();
bag->datum[i]->queue.destroy();
free(bag->datum[i]->key);
free(bag->datum[i]);
}
free(bag->datum);
bag->lock.destroy();
break;
}
}
}
static void debug_print_flonum(lref_t object, lref_t port, bool machine_readable)
{
_TCHAR buf[STACK_STRBUF_LEN];
UNREFERENCED(machine_readable);
assert(FLONUMP(object));
if (isnan(FLONM(object)))
{
_sntprintf(buf, STACK_STRBUF_LEN, _T("#inan"));
}
else if (!isfinite(FLONM(object)))
{
if (FLONM(object) > 0)
_sntprintf(buf, STACK_STRBUF_LEN, _T("#iposinf"));
else
_sntprintf(buf, STACK_STRBUF_LEN, _T("#ineginf"));
}
else
{
int digits = DEBUG_FLONUM_PRINT_PRECISION;
assert((digits >= 0) && (digits <= 16));
/* Nothing is as easy as it seems...
*
* The sprintf 'g' format code will drop the decimal
* point if all following digits are zero. That causes
* the reader to read such numbers as exact, rather than
* inexact. As a result, we need to implement our own
* switching between scientific and conventional notation.
*/
double scale = 0.0;
if (FLONM(object) != 0.0)
scale = log10(fabs(FLONM(object)));
if (fabs(scale) >= digits)
_sntprintf(buf, STACK_STRBUF_LEN, _T("%.*e"), digits, FLONM(object));
else
{
/* Prevent numbers on the left of the decimal point from
* adding to the number of digits we print. */
if ((scale > 0) && (scale <= digits))
digits -= (int) scale;
_sntprintf(buf, STACK_STRBUF_LEN, _T("%.*f"), digits, FLONM(object));
}
}
write_text(port, buf, _tcslen(buf));
if (COMPLEXP(object))
{
if (CMPLXIM(object) >= 0.0)
write_text(port, _T("+"), 1);
debug_print_flonum(FLOIM(object), port, machine_readable);
write_text(port, _T("i"), 1);
}
}
