From 64d2a9acaf915d665fa440c3779ca36510927d39 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 3 Jun 2023 19:11:47 +0200 Subject: [PATCH 4/5] Tweak list operations to work for weak pairs too and document this The list and pair operations we have typically check their argument by comparing the header bits to the verbatim header tag. This is extra safe because it implicitly also checks that the type is consistent - for instance, that it has a length of 2 and that both are block types etc. Instead, we add a new C accessor to grab just the type bits, ignoring the rest, sacrificing a little bit of that safety for interoperability between pairs and weak pairs. Add some docs to the (chicken base) module docs, and also add a brief mention to a few of the scheme pair operations that they accept weak pairs. This is not exhaustive (list?, memq/memv/member etc are not updated) as that would be a bit silly to do. --- chicken.h | 7 ++- manual/Module (chicken base) | 60 +++++++++++++++++++ manual/Module scheme | 14 +++++ runtime.c | 113 ++++++++++++++++++----------------- tests/weak-pointer-test.scm | 46 +++++++++++--- 5 files changed, 173 insertions(+), 67 deletions(-) diff --git a/chicken.h b/chicken.h index 7f176f5c..6510f1c9 100644 --- a/chicken.h +++ b/chicken.h @@ -1006,6 +1006,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_block_item(x,i) (*C_CHECK2(x,i,(C_header_size(C_VAL1(x))>(C_VAL2(i))),&(((C_SCHEME_BLOCK *)(C_VAL1(x)))->data [ C_VAL2(i) ]))) #define C_set_block_item(x,i,y) (C_block_item(x, i) = (y)) #define C_header_bits(bh) (C_block_header(bh) & C_HEADER_BITS_MASK) +#define C_header_type(bh) (C_block_header(bh) & C_HEADER_TYPE_BITS) #define C_header_size(bh) (C_block_header(bh) & C_HEADER_SIZE_MASK) #define C_bignum_size(b) (C_bytestowords(C_header_size(C_internal_bignum_vector(b)))-1) #define C_make_header(type, size) ((C_header)(((type) & C_HEADER_BITS_MASK) | ((size) & C_HEADER_SIZE_MASK))) @@ -1128,7 +1129,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_bignump(x) C_mk_bool(C_block_header(x) == C_BIGNUM_TAG) #define C_stringp(x) C_mk_bool(C_header_bits(x) == C_STRING_TYPE) #define C_symbolp(x) C_mk_bool(C_block_header(x) == C_SYMBOL_TAG) -#define C_pairp(x) C_mk_bool(C_block_header(x) == C_PAIR_TAG) +#define C_pairp(x) C_mk_bool(C_header_type(x) == C_PAIR_TYPE) #define C_weak_pairp(x) C_mk_bool(C_block_header(x) == C_WEAK_PAIR_TAG) #define C_closurep(x) C_mk_bool(C_header_bits(x) == C_CLOSURE_TYPE) #define C_vectorp(x) C_mk_bool(C_header_bits(x) == C_VECTOR_TYPE) @@ -1399,7 +1400,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_u_i_cddddr(x) C_u_i_cdr( C_u_i_cdddr( x ) ) #ifdef HAVE_STATEMENT_EXPRESSIONS -# define C_i_not_pair_p(x) ({C_word tmp = (x); C_mk_bool(C_immediatep(tmp) || C_block_header(tmp) != C_PAIR_TAG);}) +# define C_i_not_pair_p(x) ({C_word tmp = (x); C_mk_bool(C_immediatep(tmp) || C_header_type(tmp) != C_PAIR_TYPE);}) #else # define C_i_not_pair_p C_i_not_pair_p_2 #endif @@ -2716,7 +2717,7 @@ inline static int C_persistable_symbol(C_word x) inline static C_word C_i_pairp(C_word x) { - return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG); + return C_mk_bool(!C_immediatep(x) && C_header_type(x) == C_PAIR_TYPE); } inline static C_word C_i_weak_pairp(C_word x) diff --git a/manual/Module (chicken base) b/manual/Module (chicken base) index f8bb1eea..d26ba5ad 100644 --- a/manual/Module (chicken base) +++ b/manual/Module (chicken base) @@ -161,6 +161,66 @@ For complex numbers, returns a complex number of the same angle but with magnitude 1. +=== Weak pairs + +''Weak pairs'' behave identically to regular pairs, with one +exception: the car value may be garbage collected. When that happens, +it gets replaced with a sentinel "broken-weak-pointer" value. + +They are indistinguishable from regular pairs: {{car}}, {{cdr}}, etc +all work on them, {{pair?}} returns true, etc. The {{WRITE}} +representation is identical to regular pairs, so they will be read +back as pairs. In other words, they have no read/write invariance. + +They're the same as regular pairs for all intents and purposes. +However, there's a {{weak-pair?}} predicate which ''can'' distinguish +between regular pairs and weak pairs. + +==== weak-cons + +(weak-cons obj[1] obj[2])
+ +Returns a newly allocated weak pair whose car is obj[1] and whose cdr +is obj[2]. The pair is indistinguishable from normal pairs, except as +noted above. + + (weak-cons 'a '()) ===> (a) + (weak-cons '(a) '(b c d)) ===> ((a) b c d) + (weak-cons "a" '(b c)) ===> ("a" b c) + (weak-cons 'a 3) ===> (a . 3) + (weak-cons '(a b) 'c) ===> ((a b) . c) + + (import (chicken gc)) + + (let* ((x '(a b)) + (y (weak-cons x 'c))) + (gc #t) + (car x)) ===> (a b) + + (let ((x (weak-cons '(a b) 'c))) + (gc #t) + (car x)) ===> #!bwp + +As the final two examples show, when something ''else'' still holds on +to the value that's stored in the car of a weak pair, it will not be +reclaimed. But if the value is ''only'' referenced by one or more +weak pairs, it is reclaimed and the car of the weak pair is replaced +with the ''broken-weak-pointer'' value {{#!bwp}}. + +(weak-pair? obj)
+ +This predicate returns {{#t}} if and only if {{obj}} is a weak pair. + + (weak-pair? (weak-cons 'a '())) ===> #t + (weak-pair? (cons 'a '())) ===> #f + (weak-pair? (vector 'a '())) ===> #f + +(bwp-object? obj) + +This predicate returns {{#t}} if {{obj}} is the broken-weak-pointer +value, otherwise {{#f}}. + + === Lazy evaluation ==== delay-force diff --git a/manual/Module scheme b/manual/Module scheme index 2f8c51e6..a35e6e24 100644 --- a/manual/Module scheme +++ b/manual/Module scheme @@ -2168,11 +2168,17 @@ parse Scheme programs. (pair? obj)
Pair? returns #t if obj is a pair, and otherwise returns #f. +NOTE: [[Module (chicken base)#weak-pairs|Weak pairs]] are regarded +as pairs by this procedure. (pair? '(a . b)) ===> #t (pair? '(a b c)) ===> #t (pair? '()) ===> #f (pair? '#(a b)) ===> #f + (pair? (cons 1 2)) ===> #t + + (import (chicken base)) + (pair? (weak-cons 1 2)) ===> #t (cons obj[1] obj[2])
@@ -2195,6 +2201,10 @@ to take the car of the empty list. (car '((a) b c d)) ===> (a) (car '(1 . 2)) ===> 1 (car '()) ===> error + (car (cons 1 2)) ===> 1 + + (import (chicken base)) + (car (weak-cons 1 2)) ===> 1 (cdr pair)
@@ -2204,6 +2214,10 @@ to take the cdr of the empty list. (cdr '((a) b c d)) ===> (b c d) (cdr '(1 . 2)) ===> 2 (cdr '()) ===> error + (cdr (cons 1 2)) ===> 2 + + (import (chicken base)) + (cdr (weak-cons 1 2)) ===> 2 (set-car! pair obj)
diff --git a/runtime.c b/runtime.c index 9dbd6c21..d3a3b750 100644 --- a/runtime.c +++ b/runtime.c @@ -2119,7 +2119,7 @@ C_word C_fcall C_restore_callback_continuation(void) C_word p = C_block_item(callback_continuation_stack_symbol, 0), k; - assert(!C_immediatep(p) && C_block_header(p) == C_PAIR_TAG); + assert(!C_immediatep(p) && C_header_type(p) == C_PAIR_TYPE); k = C_u_i_car(p); C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p)); @@ -2133,7 +2133,7 @@ C_word C_fcall C_restore_callback_continuation2(int level) C_word p = C_block_item(callback_continuation_stack_symbol, 0), k; - if(level != callback_continuation_level || C_immediatep(p) || C_block_header(p) != C_PAIR_TAG) + if(level != callback_continuation_level || C_immediatep(p) || C_header_type(p) != C_PAIR_TYPE) panic(C_text("unbalanced callback continuation stack")); k = C_u_i_car(p); @@ -4770,7 +4770,8 @@ C_regparm C_word C_fcall C_equalp(C_word x, C_word y) if(C_immediatep(x) || C_immediatep(y)) return 0; - if((header = C_block_header(x)) != C_block_header(y)) return 0; + /* NOTE: Extra check at the end is special consideration for pairs being equal to weak pairs */ + if((header = C_block_header(x)) != C_block_header(y) && !(C_header_type(x) == C_PAIR_TYPE && C_header_type(y) == C_PAIR_TYPE)) return 0; else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) { if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG) return C_ub_i_flonum_eqvp(C_flonum_magnitude(x), @@ -5126,11 +5127,11 @@ C_regparm C_word C_fcall C_i_listp(C_word x) C_word fast = x, slow = x; while(fast != C_SCHEME_END_OF_LIST) - if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) { + if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) { fast = C_u_i_cdr(fast); if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE; - else if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) { + else if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) { fast = C_u_i_cdr(fast); slow = C_u_i_cdr(slow); @@ -5590,7 +5591,7 @@ C_regparm C_word C_fcall C_i_integer_oddp(C_word x) C_regparm C_word C_fcall C_i_car(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x); return C_u_i_car(x); @@ -5599,7 +5600,7 @@ C_regparm C_word C_fcall C_i_car(C_word x) C_regparm C_word C_fcall C_i_cdr(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x); return C_u_i_cdr(x); @@ -5608,14 +5609,14 @@ C_regparm C_word C_fcall C_i_cdr(C_word x) C_regparm C_word C_fcall C_i_caar(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) { + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) { bad: barf(C_BAD_ARGUMENT_TYPE_ERROR, "caar", x); } x = C_u_i_car(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; return C_u_i_car(x); } @@ -5623,14 +5624,14 @@ C_regparm C_word C_fcall C_i_caar(C_word x) C_regparm C_word C_fcall C_i_cadr(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) { + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) { bad: barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x); } x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; return C_u_i_car(x); } @@ -5638,14 +5639,14 @@ C_regparm C_word C_fcall C_i_cadr(C_word x) C_regparm C_word C_fcall C_i_cdar(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) { + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) { bad: barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdar", x); } x = C_u_i_car(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; return C_u_i_cdr(x); } @@ -5653,13 +5654,13 @@ C_regparm C_word C_fcall C_i_cdar(C_word x) C_regparm C_word C_fcall C_i_cddr(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) { + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) { bad: barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x); } x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; return C_u_i_cdr(x); } @@ -5667,15 +5668,15 @@ C_regparm C_word C_fcall C_i_cddr(C_word x) C_regparm C_word C_fcall C_i_caddr(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) { + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) { bad: barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x); } x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; return C_u_i_car(x); } @@ -5683,15 +5684,15 @@ C_regparm C_word C_fcall C_i_caddr(C_word x) C_regparm C_word C_fcall C_i_cdddr(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) { + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) { bad: barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x); } x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; return C_u_i_cdr(x); } @@ -5699,17 +5700,17 @@ C_regparm C_word C_fcall C_i_cdddr(C_word x) C_regparm C_word C_fcall C_i_cadddr(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) { + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) { bad: barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x); } x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; return C_u_i_car(x); } @@ -5717,17 +5718,17 @@ C_regparm C_word C_fcall C_i_cadddr(C_word x) C_regparm C_word C_fcall C_i_cddddr(C_word x) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) { + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) { bad: barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddddr", x); } x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; x = C_u_i_cdr(x); - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad; + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad; return C_u_i_cdr(x); } @@ -5739,14 +5740,14 @@ C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i) int n; if(lst != C_SCHEME_END_OF_LIST && - (C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG)) + (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE)) barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", lst); if(i & C_FIXNUM_BIT) n = C_unfix(i); else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i); while(n--) { - if(C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG) + if(C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE) barf(C_OUT_OF_RANGE_ERROR, "list-tail", lst0, i); lst = C_u_i_cdr(lst); @@ -6139,11 +6140,11 @@ C_regparm C_word C_fcall C_i_length(C_word lst) while(slow != C_SCHEME_END_OF_LIST) { if(fast != C_SCHEME_END_OF_LIST) { - if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) { + if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) { fast = C_u_i_cdr(fast); if(fast != C_SCHEME_END_OF_LIST) { - if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) { + if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) { fast = C_u_i_cdr(fast); } else barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst); @@ -6154,7 +6155,7 @@ C_regparm C_word C_fcall C_i_length(C_word lst) } } - if(C_immediatep(slow) || C_block_header(slow) != C_PAIR_TAG) + if(C_immediatep(slow) || C_header_type(slow) != C_PAIR_TYPE) barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst); slow = C_u_i_cdr(slow); @@ -6169,7 +6170,7 @@ C_regparm C_word C_fcall C_u_i_length(C_word lst) { int n = 0; - while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) { + while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) { lst = C_u_i_cdr(lst); ++n; } @@ -6179,7 +6180,7 @@ C_regparm C_word C_fcall C_u_i_length(C_word lst) C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x); C_mutate(&C_u_i_car(x), val); @@ -6189,7 +6190,7 @@ C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val) C_regparm C_word C_fcall C_i_set_cdr(C_word x, C_word val) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x); C_mutate(&C_u_i_cdr(x), val); @@ -7127,10 +7128,10 @@ C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst) { C_word a; - while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) { + while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) { a = C_u_i_car(lst); - if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) { + if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) { if(C_u_i_car(a) == x) return a; } else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a); @@ -7149,10 +7150,10 @@ C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst) { C_word a; - while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) { + while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) { a = C_u_i_car(lst); - if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) { + if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) { if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a; } else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a); @@ -7171,10 +7172,10 @@ C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst) { C_word a; - while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) { + while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) { a = C_u_i_car(lst); - if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) { + if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) { if(C_equalp(C_u_i_car(a), x)) return a; } else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a); @@ -7191,7 +7192,7 @@ C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst) C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst) { - while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) { + while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) { if(C_u_i_car(lst) == x) return lst; else lst = C_u_i_cdr(lst); } @@ -7216,7 +7217,7 @@ C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst) C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst) { - while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) { + while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) { if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst; else lst = C_u_i_cdr(lst); } @@ -7230,7 +7231,7 @@ C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst) C_regparm C_word C_fcall C_i_member(C_word x, C_word lst) { - while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) { + while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) { if(C_equalp(C_u_i_car(lst), x)) return lst; else lst = C_u_i_cdr(lst); } @@ -7355,7 +7356,7 @@ C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc) C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc) { - if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) { + if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) { error_location = loc; barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x); } @@ -7409,7 +7410,7 @@ C_regparm C_word C_fcall C_i_check_keyword_2(C_word x, C_word loc) C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc) { - if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)) { + if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)) { error_location = loc; barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x); } @@ -7574,14 +7575,14 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, /* I */ C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x) { - return C_mk_bool(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG); + return C_mk_bool(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE); } C_regparm C_word C_fcall C_i_null_list_p(C_word x) { if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE; - else if(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG) return C_SCHEME_FALSE; + else if(!C_immediatep(x) && C_header_type(x) == C_PAIR_TYPE) return C_SCHEME_FALSE; else { barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x); return C_SCHEME_FALSE; @@ -7674,7 +7675,7 @@ void C_ccall C_apply(C_word c, C_word *av) barf(C_NOT_A_CLOSURE_ERROR, "apply", fn); lst = av[ c - 1 ]; - if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG)) + if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE)) barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst); len = C_unfix(C_u_i_length(lst)); @@ -7820,7 +7821,7 @@ void C_ccall C_apply_values(C_word c, C_word *av) lst = av[ 2 ]; - if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG)) + if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE)) barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst); /* Check whether continuation receives multiple values: */ @@ -7857,7 +7858,7 @@ void C_ccall C_apply_values(C_word c, C_word *av) barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k); #endif } - else if(C_block_header(lst) == C_PAIR_TAG) { + else if(C_header_type(lst) == C_PAIR_TYPE) { if(C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST) n = C_u_i_car(lst); else { @@ -12907,18 +12908,18 @@ C_regparm C_word C_fcall C_i_get_keyword(C_word kw, C_word args, C_word def) { while(!C_immediatep(args)) { - if(C_block_header(args) == C_PAIR_TAG) { + if(C_header_type(args) == C_PAIR_TYPE) { if(kw == C_u_i_car(args)) { args = C_u_i_cdr(args); - if(C_immediatep(args) || C_block_header(args) != C_PAIR_TAG) + if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE) return def; else return C_u_i_car(args); } else { args = C_u_i_cdr(args); - if(C_immediatep(args) || C_block_header(args) != C_PAIR_TAG) + if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE) return def; else args = C_u_i_cdr(args); } diff --git a/tests/weak-pointer-test.scm b/tests/weak-pointer-test.scm index b1420e89..fa151e77 100644 --- a/tests/weak-pointer-test.scm +++ b/tests/weak-pointer-test.scm @@ -1,17 +1,49 @@ ;; weak-pointer-test.scm -(import (chicken gc)) +(import (chicken gc) (chicken port)) (include "test.scm") ;; Ensure weakly held items are not just equal to other references to it, but *identical* (current-test-comparator eq?) +(test-group "Testing basic pair accessors work on weak pairs, too" + (let ((my-proper-weak-list (weak-cons 1 (weak-cons 2 '()))) + (my-proper-list (cons 1 (cons 2 '()))) + (my-improper-weak-list (weak-cons 1 (weak-cons 2 3))) + (my-improper-list (cons 1 (cons 2 3)))) + + (test-assert "proper weak lists are pairs" (pair? my-proper-weak-list)) + (test-assert "improper weak lists are pairs" (pair? my-improper-weak-list)) + + (test-assert "regular proper lists are not weak pairs" (not (weak-pair? my-proper-list))) + (test-assert "regular improper lists are not weak pairs" (not (weak-pair? my-improper-list))) + + (test-assert "proper weak lists are lists" (list? my-proper-weak-list)) + (test-assert "improper weak lists are *not* lists" (not (list? my-improper-weak-list))) + + (test-equal "an weak proper list is equal to the same regular proper list" my-proper-weak-list my-proper-list equal?) + (test-equal "an weak proper list is not *identical* to the same regular proper list" my-proper-weak-list my-proper-list (complement eq?)) + + (test-equal "car of weak list returns the first item" (car my-proper-weak-list) 1) + (test-equal "cdr of weak list returns the cdr" (cdr my-proper-weak-list) (cdr my-proper-list) equal?) + (test-equal "cadr of weak list returns the second item" (cadr my-proper-weak-list) 2) + (test-equal "cddr of weak list returns the cdr of the cdr" (cddr my-proper-weak-list) '()) + + (test-equal "length of weak proper list returns the length" 2 (length my-proper-weak-list)) + (test-error "length of weak improper list raises an error" (length my-improper-weak-list)) + + (let* ((written-proper-weak-list (with-output-to-string (lambda () (write my-proper-weak-list)))) + (written-improper-weak-list (with-output-to-string (lambda () (write my-improper-weak-list)))) + (reread-proper-weak-list (with-input-from-string written-proper-weak-list read)) + (reread-improper-weak-list (with-input-from-string written-improper-weak-list read))) + (test-equal "a proper weak list is written as a regular proper list" "(1 2)" written-proper-weak-list string=?) + (test-equal "a proper weak list is read back as regular proper list" my-proper-list reread-proper-weak-list equal?) + (test-equal "an improper weak list is written as a regular improper list" "(1 2 . 3)" written-improper-weak-list string=?) + (test-equal "an improper weak list is read back as regular improper list" my-improper-list reread-improper-weak-list equal?)))) + (test-group "Testing that basic weak pairs get their car reclaimed" - (let* ((car (lambda (x) (##sys#slot x 0))) ; TODO: make list accessors work on weak pairs - (cadr (lambda (x) (car (##sys#slot x 1)))) - (caddr (lambda (x) (car (##sys#slot (##sys#slot x 1) 1)))) - (not-held-onto-value (vector 42)) + (let* ((not-held-onto-value (vector 42)) (held-onto-vector (vector 'this-one-stays)) (weak-list (weak-cons not-held-onto-value (weak-cons (vector 'ohai) @@ -37,9 +69,7 @@ (test-group "Testing cars of weak pairs referenced by their cdr do not get collected" - (let* ((car (lambda (x) (##sys#slot x 0))) ; TODO: make list accessors work on weak pairs - (cdr (lambda (x) (##sys#slot x 1))) - (obj-a (vector 42)) + (let* ((obj-a (vector 42)) (ref-a (weak-cons obj-a obj-a)) (obj-b (vector 'ohai)) (ref-b (weak-cons obj-b obj-b)) -- 2.38.5