~ chicken-core (chicken-5) 274e7afa599adc501ca84f5e8e44d45cbf90c5c7
commit 274e7afa599adc501ca84f5e8e44d45cbf90c5c7
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Fri Nov 20 15:46:48 2015 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Mon Nov 30 22:23:10 2015 +1300
C_i_char_*p are now truly safe.
The original definitions are retained under C_u_i_char_*p and used in
unsafe mode and when the argument types are known to be characters.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 6aad0865..4f431869 100644
--- a/NEWS
+++ b/NEWS
@@ -18,6 +18,7 @@
work, removing the requirement for the inferred types to match
declared types exactly. Specializations are matched from first to
last to resolve ambiguities (#1214).
+ - Compiler rewrites for char{<,>,<=,>=,=}? are now safe (#1122).
- Core libraries
- SRFI-18: thread-join! no longer gives an error when passed a
diff --git a/c-platform.scm b/c-platform.scm
index ecc97f45..434593c0 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -620,10 +620,15 @@
(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_i_char_equalp" #t) ; a bit of a lie: won't crash but accepts garbage
+(rewrite 'char=? 2 2 "C_u_i_char_equalp" #f)
+(rewrite 'char=? 2 2 "C_i_char_equalp" #t)
+(rewrite 'char>? 2 2 "C_u_i_char_greaterp" #f)
(rewrite 'char>? 2 2 "C_i_char_greaterp" #t)
+(rewrite 'char<? 2 2 "C_u_i_char_lessp" #f)
(rewrite 'char<? 2 2 "C_i_char_lessp" #t)
+(rewrite 'char>=? 2 2 "C_u_i_char_greater_or_equal_p" #f)
(rewrite 'char>=? 2 2 "C_i_char_greater_or_equal_p" #t)
+(rewrite 'char<=? 2 2 "C_u_i_char_less_or_equal_p" #f)
(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) ;XXX must be safe for pattern matcher (anymore?)
diff --git a/chicken.h b/chicken.h
index f51d5dc4..e1d73445 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1188,11 +1188,11 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#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_u_i_char_equalp(x, y) C_mk_bool(C_character_code(x) == C_character_code(y))
+#define C_u_i_char_greaterp(x, y) C_mk_bool(C_character_code(x) > C_character_code(y))
+#define C_u_i_char_lessp(x, y) C_mk_bool(C_character_code(x) < C_character_code(y))
+#define C_u_i_char_greater_or_equal_p(x, y) C_mk_bool(C_character_code(x) >= C_character_code(y))
+#define C_u_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_memmove((C_char *)C_data_pointer(s2) + C_unfix(start2), \
(C_char *)C_data_pointer(s1) + C_unfix(start1), \
@@ -1881,6 +1881,11 @@ C_fctexport C_word C_fcall C_i_not_pair_p_2(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_null_list_p(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_string_null_p(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_null_pointerp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_char_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_char_greaterp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_char_lessp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_char_greater_or_equal_p(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_char_less_or_equal_p(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_locative_set(C_word loc, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_locative_to_object(C_word loc) C_regparm;
C_fctexport C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak) C_regparm;
@@ -2455,7 +2460,6 @@ C_fast_retrieve(C_word sym)
return val;
}
-
C_inline void *
C_fast_retrieve_proc(C_word closure)
{
diff --git a/library.scm b/library.scm
index 377c8826..1502b6c3 100644
--- a/library.scm
+++ b/library.scm
@@ -1437,30 +1437,11 @@ EOF
(##sys#check-exact n 'integer->char)
(##core#inline "C_make_character" (##core#inline "C_unfix" n)) )
-(define (char=? c1 c2)
- (##sys#check-char c1 'char=?)
- (##sys#check-char c2 'char=?)
- (##core#inline "C_i_char_equalp" c1 c2) )
-
-(define (char>? c1 c2)
- (##sys#check-char c1 'char>?)
- (##sys#check-char c2 'char>?)
- (##core#inline "C_i_char_greaterp" c1 c2) )
-
-(define (char<? c1 c2)
- (##sys#check-char c1 'char<?)
- (##sys#check-char c2 'char<?)
- (##core#inline "C_i_char_lessp" c1 c2) )
-
-(define (char>=? c1 c2)
- (##sys#check-char c1 'char>=?)
- (##sys#check-char c2 'char>=?)
- (##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<=?)
- (##core#inline "C_i_char_less_or_equal_p" c1 c2) )
+(define (char=? c1 c2) (##core#inline "C_i_char_equalp" c1 c2))
+(define (char>? c1 c2) (##core#inline "C_i_char_greaterp" c1 c2))
+(define (char<? c1 c2) (##core#inline "C_i_char_lessp" c1 c2))
+(define (char>=? c1 c2) (##core#inline "C_i_char_greater_or_equal_p" c1 c2))
+(define (char<=? c1 c2) (##core#inline "C_i_char_less_or_equal_p" c1 c2))
(define (char-upcase c)
(##sys#check-char c 'char-upcase)
@@ -1479,16 +1460,16 @@ EOF
(let ((char-downcase char-downcase))
(set! char-ci=? (lambda (x y) (eq? (char-downcase x) (char-downcase y))))
(set! char-ci>? (lambda (x y)
- (##core#inline "C_i_char_greaterp"
+ (##core#inline "C_u_i_char_greaterp"
(char-downcase x) (char-downcase y))))
(set! char-ci<? (lambda (x y)
- (##core#inline "C_i_char_lessp"
+ (##core#inline "C_u_i_char_lessp"
(char-downcase x) (char-downcase y))))
(set! char-ci>=? (lambda (x y)
- (##core#inline "C_i_char_greater_or_equal_p"
+ (##core#inline "C_u_i_char_greater_or_equal_p"
(char-downcase x) (char-downcase y))))
(set! char-ci<=? (lambda (x y)
- (##core#inline "C_i_char_less_or_equal_p"
+ (##core#inline "C_u_i_char_less_or_equal_p"
(char-downcase x) (char-downcase y)))) )
(define (char-upper-case? c)
diff --git a/runtime.c b/runtime.c
index 0d1deacb..9d93476c 100644
--- a/runtime.c
+++ b/runtime.c
@@ -5969,6 +5969,41 @@ C_regparm C_word C_fcall C_i_null_pointerp(C_word x)
return C_SCHEME_FALSE;
}
+C_regparm C_word C_i_char_equalp(C_word x, C_word y)
+{
+ C_i_check_char_2(x, intern0("char=?"));
+ C_i_check_char_2(y, intern0("char=?"));
+ return C_u_i_char_equalp(x, y);
+}
+
+C_regparm C_word C_i_char_greaterp(C_word x, C_word y)
+{
+ C_i_check_char_2(x, intern0("char>?"));
+ C_i_check_char_2(y, intern0("char>?"));
+ return C_u_i_char_greaterp(x, y);
+}
+
+C_regparm C_word C_i_char_lessp(C_word x, C_word y)
+{
+ C_i_check_char_2(x, intern0("char<?"));
+ C_i_check_char_2(y, intern0("char<?"));
+ return C_u_i_char_lessp(x, y);
+}
+
+C_regparm C_word C_i_char_greater_or_equal_p(C_word x, C_word y)
+{
+ C_i_check_char_2(x, intern0("char>=?"));
+ C_i_check_char_2(y, intern0("char>=?"));
+ return C_u_i_char_greater_or_equal_p(x, y);
+}
+
+C_regparm C_word C_i_char_less_or_equal_p(C_word x, C_word y)
+{
+ C_i_check_char_2(x, intern0("char<=?"));
+ C_i_check_char_2(y, intern0("char<=?"));
+ return C_u_i_char_less_or_equal_p(x, y);
+}
+
/* Primitives: */
diff --git a/types.db b/types.db
index 40588721..88ce6b31 100644
--- a/types.db
+++ b/types.db
@@ -505,12 +505,17 @@
(char? (#(procedure #:pure #:predicate char) char? (*) boolean))
-;; we could rewrite these, but this is done by the optimizer anyway (safe)
-(char=? (#(procedure #:clean #:enforce) char=? (char char) boolean))
-(char>? (#(procedure #:clean #:enforce) char>? (char char) boolean))
-(char<? (#(procedure #:clean #:enforce) char<? (char char) boolean))
-(char>=? (#(procedure #:clean #:enforce) char>=? (char char) boolean))
-(char<=? (#(procedure #:clean #:enforce) char<=? (char char) boolean))
+;; safe rewrites are already done by the optimizer
+(char=? (#(procedure #:clean #:enforce) char=? (char char) boolean)
+ ((char char) (##core#inline "C_u_i_char_equalp" #(1) #(2))))
+(char>? (#(procedure #:clean #:enforce) char>? (char char) boolean)
+ ((char char) (##core#inline "C_u_i_char_greaterp" #(1) #(2))))
+(char<? (#(procedure #:clean #:enforce) char<? (char char) boolean)
+ ((char char) (##core#inline "C_u_i_char_lessp" #(1) #(2))))
+(char>=? (#(procedure #:clean #:enforce) char>=? (char char) boolean)
+ ((char char) (##core#inline "C_u_i_char_greater_or_equal_p" #(1) #(2))))
+(char<=? (#(procedure #:clean #:enforce) char<=? (char char) boolean)
+ ((char char) (##core#inline "C_u_i_char_less_or_equal_p" #(1) #(2))))
(char-ci=? (#(procedure #:clean #:enforce) char-ci=? (char char) boolean))
(char-ci<? (#(procedure #:clean #:enforce) char-ci<? (char char) boolean))
Trap