~ chicken-core (chicken-5) 445e245a54b56e232236c3a47ce4905ca79b2007
commit 445e245a54b56e232236c3a47ce4905ca79b2007
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sat Oct 12 11:12:57 2013 +0200
Commit: Mario Domenech Goulart <mario.goulart@gmail.com>
CommitDate: Thu Oct 17 15:08:09 2013 -0300
Add paranoid checks to C_u_i_car and C_u_i_cdr.
Replace all calls to these two on non-pairs for "convenience" (use C_block_item)
Signed-off-by: Mario Domenech Goulart <mario.goulart@gmail.com>
diff --git a/chicken.h b/chicken.h
index 88bceb8e..aea58fec 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1280,7 +1280,7 @@ extern double trunc(double);
#define C_pointer_address(x) ((C_byte *)C_block_item((x), 0))
#define C_block_address(ptr, n, x) C_a_unsigned_int_to_num(ptr, n, x)
#define C_offset_pointer(x, y) (C_pointer_address(x) + (y))
-#define C_kontinue(k, r) ((C_proc2)(void *)C_u_i_car(k))(2, (k), (r))
+#define C_kontinue(k, r) ((C_proc2)(void *)C_block_item(k,0))(2, (k), (r))
#define C_fetch_byte(x, p) (((unsigned C_byte *)C_data_pointer(x))[ p ])
#define C_poke_integer(x, i, n) (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED)
#define C_pointer_to_block(p, x) (C_set_block_item(p, 0, (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED)
@@ -1386,8 +1386,8 @@ extern double trunc(double);
#define C_i_list_ref(lst, i) C_i_car(C_i_list_tail(lst, i))
#define C_u_i_list_ref(lst, i) C_u_i_car(C_i_list_tail(lst, i))
-#define C_u_i_car(x) C_block_item(x, 0)
-#define C_u_i_cdr(x) C_block_item(x, 1)
+#define C_u_i_car(x) (*C_CHECKp(x,C_pairp(C_VAL1(x)),&C_block_item(C_VAL1(x), 0)))
+#define C_u_i_cdr(x) (*C_CHECKp(x,C_pairp(C_VAL1(x)),&C_block_item(C_VAL1(x), 1)))
#define C_u_i_caar(x) C_u_i_car( C_u_i_car( x ) )
#define C_u_i_cadr(x) C_u_i_car( C_u_i_cdr( x ) )
#define C_u_i_cdar(x) C_u_i_cdr( C_u_i_car( x ) )
@@ -2673,6 +2673,17 @@ C_inline C_word C_fcall C_a_pair(C_word **ptr, C_word car, C_word cdr)
return (C_word)p0;
}
+C_inline C_word C_fcall C_a_bucket(C_word **ptr, C_word head, C_word tail)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_BUCKET_TYPE | (C_SIZEOF_BUCKET - 1);
+ *(p++) = head;
+ *(p++) = tail;
+ *ptr = p;
+ return (C_word)p0;
+}
+
C_inline C_word C_a_i_list1(C_word **a, int n, C_word x1)
{
diff --git a/runtime.c b/runtime.c
index f459bd61..0ed18de2 100644
--- a/runtime.c
+++ b/runtime.c
@@ -906,7 +906,7 @@ void *CHICKEN_global_lookup(char *name)
void *root = CHICKEN_new_gc_root();
if(C_truep(s = lookup(key, len, name, symbol_table))) {
- if(C_u_i_car(s) != C_SCHEME_UNBOUND) {
+ if(C_block_item(s, 0) != C_SCHEME_UNBOUND) {
CHICKEN_gc_root_set(root, s);
return root;
}
@@ -996,7 +996,7 @@ C_regparm C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable)
else return C_SCHEME_FALSE;
}
-
+/* OBSOLETE */
C_regparm C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos)
{
int i;
@@ -1554,7 +1554,7 @@ void barf(int code, char *loc, ...)
C_dbg_hook(C_SCHEME_UNDEFINED);
C_temporary_stack = C_temporary_stack_bottom;
- err = C_u_i_car(err);
+ err = C_block_item(err, 0);
if(C_immediatep(err))
panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable"));
@@ -2013,8 +2013,8 @@ void C_zap_strings(C_word str)
for(bucket = symbol_table->table[ i ];
bucket != C_SCHEME_END_OF_LIST;
- bucket = C_u_i_cdr(bucket)) {
- sym = C_u_i_car(bucket);
+ bucket = C_block_item(bucket,1)) {
+ sym = C_block_item(bucket,0);
C_set_block_item(sym, 1, str);
}
}
@@ -2171,7 +2171,7 @@ C_regparm C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value)
{
C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table);
- C_mutate2(&C_u_i_car(s), value);
+ C_mutate2(&C_block_item(s,0), value);
return s;
}
@@ -2194,8 +2194,8 @@ C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE
C_word bucket, sym, s;
for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;
- bucket = C_u_i_cdr(bucket)) {
- sym = C_u_i_car(bucket);
+ bucket = C_block_item(bucket,1)) {
+ sym = C_block_item(bucket,0);
s = C_block_item(sym, 1);
if(C_header_size(s) == (C_word)len
@@ -2216,7 +2216,7 @@ double compute_symbol_table_load(double *avg_bucket_len, int *total_n)
bucket = symbol_table->table[ i ];
for(j = 0; bucket != C_SCHEME_END_OF_LIST; ++j)
- bucket = C_u_i_cdr(bucket);
+ bucket = C_block_item(bucket,1);
if(j > 0) {
alen += j;
@@ -2250,8 +2250,7 @@ C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stabl
C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);
*ptr = p;
b2 = stable->table[ key ]; /* previous bucket */
- bucket = C_a_pair(ptr, sym, b2); /* create new bucket */
- C_block_header(bucket) = (C_block_header(bucket) & ~C_HEADER_TYPE_BITS) | C_BUCKET_TYPE;
+ bucket = C_a_bucket(ptr, sym, b2); /* create new bucket */
if(ptr != C_heaptop) C_mutate_slot(&stable->table[ key ], bucket);
else {
@@ -2259,7 +2258,7 @@ C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stabl
heap-top (say, in a toplevel literal frame allocation) then we have
to inform the memory manager that a 2nd gen. block points to a
1st gen. block, hence the mutation: */
- C_mutate2(&C_u_i_cdr(bucket), b2);
+ C_mutate2(&C_block_item(bucket,1), b2);
stable->table[ key ] = bucket;
}
@@ -2969,7 +2968,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
C_dbg(C_text("GC"), C_text("queueing %d finalizer(s)\n"), pending_finalizer_count);
last = C_block_item(pending_finalizers_symbol, 0);
- assert(C_u_i_car(last) == C_fix(0));
+ assert(C_block_item(last, 0) == C_fix(0));
C_set_block_item(last, 0, C_fix(pending_finalizer_count));
for(i = 0; i < pending_finalizer_count; ++i) {
@@ -3040,10 +3039,10 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
for(i = 0; i < stp->size; ++i) {
last = 0;
- for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket))
- if(C_u_i_car(bucket) == C_SCHEME_UNDEFINED) {
- if(last) C_set_block_item(last, 1, C_u_i_cdr(bucket));
- else stp->table[ i ] = C_u_i_cdr(bucket);
+ for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_block_item(bucket,1))
+ if(C_block_item(bucket,0) == C_SCHEME_UNDEFINED) {
+ if(last) C_set_block_item(last, 1, C_block_item(bucket,1));
+ else stp->table[ i ] = C_block_item(bucket,1);
}
else last = bucket;
}
@@ -3227,7 +3226,7 @@ C_regparm void C_fcall really_mark(C_word *x)
#endif
if(C_enable_gcweak && (h & C_HEADER_TYPE_BITS) == C_BUCKET_TYPE) {
- item = C_u_i_car(val);
+ item = C_block_item(val,0);
/* Lookup item in weak item table or add entry: */
if((wep = lookup_weak_table_entry(item, (C_word)p2)) != NULL) {
@@ -5697,7 +5696,7 @@ C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc)
C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc)
{
- if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_u_i_car(x) != st) {
+ if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x,0) != st) {
error_location = loc;
barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);
}
@@ -6172,13 +6171,13 @@ void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont)
{
C_word *a = C_alloc(3),
wrapper;
- void *pr = (void *)C_u_i_car(cont);
+ void *pr = (void *)C_block_item(cont,0);
if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);
/* Check for values-continuation: */
- if(C_u_i_car(k) == (C_word)values_continuation)
+ if(C_block_item(k,0) == (C_word)values_continuation)
wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);
else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);
@@ -6188,7 +6187,7 @@ void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont)
void C_ccall call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result)
{
- C_word cont = C_u_i_cdr(closure);
+ C_word cont = C_block_item(closure,1);
if(c != 3) C_bad_argc(c, 3);
@@ -6199,7 +6198,7 @@ void C_ccall call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result)
void C_ccall call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...)
{
va_list v;
- C_word cont = C_u_i_cdr(closure),
+ C_word cont = C_block_item(closure,1),
x1;
int n = c;
@@ -6318,7 +6317,7 @@ void C_ccall C_u_call_with_values(C_word c, C_word closure, C_word k, C_word thu
void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...)
{
- C_word kont = C_u_i_cdr(closure),
+ C_word kont = C_block_item(closure, 1),
k = C_block_item(closure, 2),
n = c,
*ptr;
@@ -8124,8 +8123,8 @@ void C_ccall C_context_switch(C_word c, C_word closure, C_word k, C_word state)
C_temporary_stack = C_temporary_stack_bottom - n;
C_memcpy(C_temporary_stack, (C_word *)state + 2, n * sizeof(C_word));
- trampoline = (TRAMPOLINE)C_u_i_car(adrs);
- trampoline((void *)C_u_i_cdr(adrs));
+ trampoline = (TRAMPOLINE)C_block_item(adrs,0);
+ trampoline((void *)C_block_item(adrs,1));
}
Trap