SCM
scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
{
if (!SCM_UNBNDP (filename))
{
SCM old_alist = alist;
/*
have to extract the acons, and operate on that, for
thread safety.
*/
SCM last_acons = SCM_CDR (scm_last_alist_filename);
if (scm_is_null (old_alist)
&& scm_is_eq (SCM_CDAR (last_acons), filename))
{
alist = last_acons;
}
else
{
alist = scm_acons (scm_sym_filename, filename, alist);
if (scm_is_null (old_alist))
scm_set_cdr_x (scm_last_alist_filename, alist);
}
}
SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
SRCPROPMAKPOS (line, col),
SCM_UNPACK (copy),
SCM_UNPACK (alist));
}
void
scm_dynstack_push_dynwind (scm_t_dynstack *dynstack, SCM enter, SCM leave)
{
scm_t_bits *words;
words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNWIND, 0,
DYNWIND_WORDS);
words[0] = SCM_UNPACK (enter);
words[1] = SCM_UNPACK (leave);
}
/* Change the size of a port's bytevector to NEW_SIZE. This doesn't
change `read_buf_size'. */
static void
st_resize_port (scm_t_port *pt, scm_t_off new_size)
{
SCM old_stream = SCM_PACK (pt->stream);
const signed char *src = SCM_BYTEVECTOR_CONTENTS (old_stream);
SCM new_stream = scm_c_make_bytevector (new_size);
signed char *dst = SCM_BYTEVECTOR_CONTENTS (new_stream);
unsigned long int old_size = SCM_BYTEVECTOR_LENGTH (old_stream);
unsigned long int min_size = min (old_size, new_size);
scm_t_off offset = pt->write_pos - pt->write_buf;
pt->write_buf_size = new_size;
memcpy (dst, src, min_size);
scm_remember_upto_here_1 (old_stream);
/* reset buffer. */
{
pt->stream = SCM_UNPACK (new_stream);
pt->read_buf = pt->write_buf = (unsigned char *)dst;
pt->read_pos = pt->write_pos = pt->write_buf + offset;
pt->write_end = pt->write_buf + pt->write_buf_size;
pt->read_end = pt->read_buf + pt->read_buf_size;
}
}
static void
register_disappearing_links (scm_t_weak_entry *entry,
SCM k, SCM v,
scm_t_weak_table_kind kind)
{
if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k)
&& (kind == SCM_WEAK_TABLE_KIND_KEY
|| kind == SCM_WEAK_TABLE_KIND_BOTH))
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->key,
(GC_PTR) SCM2PTR (k));
if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
&& (kind == SCM_WEAK_TABLE_KIND_VALUE
|| kind == SCM_WEAK_TABLE_KIND_BOTH))
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->value,
(GC_PTR) SCM2PTR (v));
}
void
scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
scm_putc_unlocked (' ', port);
scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
scm_puts_unlocked (">", port);
}
/* The fluid is stored on the stack, but the value has to be stored on the heap,
so that all continuations that capture this dynamic scope capture the same
binding. */
void
scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value,
scm_t_dynamic_state *dynamic_state)
{
scm_t_bits *words;
SCM value_box;
if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)))
scm_wrong_type_arg ("with-fluid*", 0, fluid);
value_box = scm_make_variable (value);
words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_WITH_FLUID, 0,
WITH_FLUID_WORDS);
words[0] = SCM_UNPACK (fluid);
words[1] = SCM_UNPACK (value_box);
/* Go ahead and swap them. */
scm_swap_fluid (fluid, value_box, dynamic_state);
}
void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<hash-table ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
scm_putc (' ', port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
scm_puts_unlocked (">", port);
}
void
scm_dynstack_push_dynamic_state (scm_t_dynstack *dynstack, SCM state,
scm_t_dynamic_state *dynamic_state)
{
scm_t_bits *words;
SCM state_box;
if (SCM_UNLIKELY (scm_is_false (scm_dynamic_state_p (state))))
scm_wrong_type_arg ("with-dynamic-state", 0, state);
state_box = scm_make_variable (scm_set_current_dynamic_state (state));
words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNAMIC_STATE, 0,
DYNAMIC_STATE_WORDS);
words[0] = SCM_UNPACK (state_box);
}
void
scm_dynstack_push_prompt (scm_t_dynstack *dynstack,
scm_t_dynstack_prompt_flags flags,
SCM key,
scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
scm_t_uint32 *ip, scm_i_jmp_buf *registers)
{
scm_t_bits *words;
words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_PROMPT, flags,
PROMPT_WORDS);
words[0] = SCM_UNPACK (key);
words[1] = (scm_t_bits) fp_offset;
words[2] = (scm_t_bits) sp_offset;
words[3] = (scm_t_bits) ip;
words[4] = (scm_t_bits) registers;
}
static SCM
make_hash_table (unsigned long k, const char *func_name)
{
SCM vector;
scm_t_hashtable *t;
int i = 0, n = k ? k : 31;
while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
++i;
n = hashtable_size[i];
vector = scm_c_make_vector (n, SCM_EOL);
t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
t->min_size_index = t->size_index = i;
t->n_items = 0;
t->lower = 0;
t->upper = 9 * n / 10;
/* FIXME: we just need two words of storage, not three */
return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
(scm_t_bits)t, 0);
}
resize_set (set);
return weak_set_add_x (set, hash >> 1, pred, closure, obj);
}
/* Displace the entry if our distance is less, otherwise keep
looking. */
if (entry_distance (other_hash, k, size) < distance)
{
rob_from_rich (set, k);
break;
}
}
set->n_items++;
entries[k].hash = hash;
entries[k].key = SCM_UNPACK (obj);
if (SCM_HEAP_OBJECT_P (obj))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
(void *) SCM2PTR (obj));
return obj;
}
static void
weak_set_remove_x (scm_t_weak_set *set, unsigned long hash,
scm_t_set_predicate_fn pred, void *closure)
{
unsigned long k, distance, size;
scm_t_weak_entry *entries;
/*! Unsafely convert a Scheme value into a pointer. */
static inline gpointer
unpack_as_pointer (SCM s)
{
return (void *) SCM_UNPACK (s);
}
" \"rw\"))\n"
"\n"
"(write p p) @result{} #<input-output: soft 8081e20>\n"
"@end lisp")
#define FUNC_NAME s_scm_make_soft_port
{
int vlen;
SCM z;
SCM_VALIDATE_VECTOR (1, pv);
vlen = SCM_SIMPLE_VECTOR_LENGTH (pv);
SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, modes);
z = scm_c_make_port (scm_tc16_sfport, scm_i_mode_bits (modes),
SCM_UNPACK (pv));
scm_port_non_buffer (SCM_PTAB_ENTRY (z));
return z;
}
#undef FUNC_NAME
static scm_t_bits
scm_make_sfptob ()
{
scm_t_bits tc = scm_make_port_type ("soft", sf_fill_input, sf_write);
scm_set_port_flush (tc, sf_flush);
scm_set_port_close (tc, sf_close);
scm_set_port_input_waiting (tc, sf_input_waiting);
