~ chicken-core (chicken-5) 8f3446e2269f8ff3e5273516adee78bcfc32feab
commit 8f3446e2269f8ff3e5273516adee78bcfc32feab
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Mar 31 12:22:07 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Mar 31 12:22:07 2011 +0200
use safer character-comparison macros in generated C code that mask out garbage in the upper bits; increase C_STACK_RESERVE for deeply recursive direct-call-optimized code
diff --git a/c-platform.scm b/c-platform.scm
index 18e305c7..a815e1cb 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -626,11 +626,11 @@
(rewrite 'string-set! 2 3 "C_i_string_set" #t)
(rewrite 'vector-ref 2 2 "C_slot" #f)
(rewrite 'vector-ref 2 2 "C_i_vector_ref" #t)
-(rewrite 'char=? 2 2 "C_eqp" #t)
-(rewrite 'char>? 2 2 "C_fixnum_greaterp" #t)
-(rewrite 'char<? 2 2 "C_fixnum_lessp" #t)
-(rewrite 'char>=? 2 2 "C_fixnum_greater_or_equal_p" #t)
-(rewrite 'char<=? 2 2 "C_fixnum_less_or_equal_p" #t)
+(rewrite 'char=? 2 2 "C_i_char_equalp" #t) ; a bit of a lie: won't crash but accepts garbage
+(rewrite 'char>? 2 2 "C_i_char_greaterp" #t)
+(rewrite 'char<? 2 2 "C_i_char_lessp" #t)
+(rewrite 'char>=? 2 2 "C_i_char_greater_or_equal_p" #t)
+(rewrite 'char<=? 2 2 "C_i_char_less_or_equal_p" #t)
(rewrite '##sys#slot 2 2 "C_slot" #t) ; consider as safe, the primitive is unsafe anyway.
(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t) ;*** must be safe for pattern matcher (anymore?)
(rewrite '##sys#size 2 1 "C_block_size" #t)
diff --git a/chicken.h b/chicken.h
index 040115ee..7a3f6891 100644
--- a/chicken.h
+++ b/chicken.h
@@ -349,7 +349,7 @@ void *alloca ();
/* Constants: */
-#define C_STACK_RESERVE 4096
+#define C_STACK_RESERVE 0x10000
#define C_DEFAULT_MAX_PENDING_FINALIZERS 2048
#define C_IMMEDIATE_MARK_BITS 0x00000003
@@ -914,7 +914,7 @@ extern double trunc(double);
#define C_fix(n) (((C_word)(n) << C_FIXNUM_SHIFT) | C_FIXNUM_BIT)
#define C_unfix(x) ((x) >> C_FIXNUM_SHIFT)
#define C_make_character(c) ((((c) & C_CHAR_BIT_MASK) << C_CHAR_SHIFT) | C_CHARACTER_BITS)
-#define C_character_code(x) (((x) >> C_CHAR_SHIFT) & C_CHAR_BIT_MASK)
+#define C_character_code(x) (((C_word)(x) >> C_CHAR_SHIFT) & C_CHAR_BIT_MASK)
#define C_flonum_magnitude(x) (*((double *)(((C_SCHEME_BLOCK *)(x))->data)))
#define C_c_string(x) ((C_char *)(((C_SCHEME_BLOCK *)(x))->data))
#define C_c_pointer(x) ((void *)(x))
@@ -1066,6 +1066,11 @@ extern double trunc(double);
#define C_fix_to_char(x) (C_make_character(C_unfix(x)))
#define C_char_to_fix(x) (C_fix(C_character_code(x)))
+#define C_i_char_equalp(x, y) C_mk_bool(C_character_code(x) == C_character_code(y))
+#define C_i_char_greaterp(x, y) C_mk_bool(C_character_code(x) > C_character_code(y))
+#define C_i_char_lessp(x, y) C_mk_bool(C_character_code(x) < C_character_code(y))
+#define C_i_char_greater_or_equal_p(x, y) C_mk_bool(C_character_code(x) >= C_character_code(y))
+#define C_i_char_less_or_equal_p(x, y) C_mk_bool(C_character_code(x) <= C_character_code(y))
#define C_substring_copy(s1, s2, start1, end1, start2) \
(C_memcpy((C_char *)C_data_pointer(s2) + C_unfix(start2), \
(C_char *)C_data_pointer(s1) + C_unfix(start1), \
diff --git a/library.scm b/library.scm
index 2c64448b..4e7a6f6b 100644
--- a/library.scm
+++ b/library.scm
@@ -1389,27 +1389,27 @@ EOF
(define (char=? c1 c2)
(##sys#check-char c1 'char=?)
(##sys#check-char c2 'char=?)
- (eq? c1 c2) )
+ (##core#inline "C_i_char_equalp" c1 c2) )
(define (char>? c1 c2)
(##sys#check-char c1 'char>?)
(##sys#check-char c2 'char>?)
- (fx> c1 c2) )
+ (##core#inline "C_i_char_greaterp" c1 c2) )
(define (char<? c1 c2)
(##sys#check-char c1 'char<?)
(##sys#check-char c2 'char<?)
- (fx< c1 c2) )
+ (##core#inline "C_i_char_lessp" c1 c2) )
(define (char>=? c1 c2)
(##sys#check-char c1 'char>=?)
(##sys#check-char c2 'char>=?)
- (fx>= c1 c2) )
+ (##core#inline "C_i_char_greater_or_equal_p" c1 c2) )
(define (char<=? c1 c2)
(##sys#check-char c1 'char<=?)
(##sys#check-char c2 'char<=?)
- (fx<= c1 c2) )
+ (##core#inline "C_i_char_less_or_equal_p" c1 c2) )
(define (char-upcase c)
(##sys#check-char c 'char-upcase)
Trap