From 4808b49d48bf53a9eb781b0f6f01e647eed0da59 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Fri, 20 Nov 2015 15:54:39 +0100 Subject: [PATCH] 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. Conflicts: types.db --- NEWS | 1 + c-platform.scm | 7 ++++++- chicken.h | 16 ++++++++++------ library.scm | 37 +++++++++---------------------------- runtime.c | 35 +++++++++++++++++++++++++++++++++++ types.db | 17 +++++++++++------ 6 files changed, 72 insertions(+), 41 deletions(-) diff --git a/NEWS b/NEWS index eba4c91..266c80d 100644 --- a/NEWS +++ b/NEWS @@ -48,6 +48,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). 4.10.1 diff --git a/c-platform.scm b/c-platform.scm index f30e1d1..d619425 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -500,10 +500,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_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 b504883..4caf916 100644 --- a/chicken.h +++ b/chicken.h @@ -1257,11 +1257,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), \ @@ -2042,6 +2042,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; @@ -3195,7 +3200,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 bb49d8b..27c3d28 100644 --- a/library.scm +++ b/library.scm @@ -2201,30 +2201,11 @@ EOF (##sys#check-fixnum 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_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_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) @@ -2243,16 +2224,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_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 05fcd98..be77d7d 100644 --- a/runtime.c +++ b/runtime.c @@ -7148,6 +7148,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_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 050824a..e332f5a 100644 --- a/types.db +++ b/types.db @@ -618,12 +618,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 #:foldable) char=? (char char) boolean)) -(char>? (#(procedure #:clean #:enforce #:foldable) char>? (char char) boolean)) -(char=? (#(procedure #:clean #:enforce #:foldable) char>=? (char char) boolean)) -(char<=? (#(procedure #:clean #:enforce #:foldable) char<=? (char char) boolean)) +;; safe rewrites are already done by the optimizer +(char=? (#(procedure #:clean #:enforce #:foldable) char=? (char char) boolean) + ((char char) (##core#inline "C_u_i_char_equalp" #(1) #(2)))) +(char>? (#(procedure #:clean #:enforce #:foldable) char>? (char char) boolean) + ((char char) (##core#inline "C_u_i_char_greaterp" #(1) #(2)))) +(char=? (#(procedure #:clean #:enforce #:foldable) char>=? (char char) boolean) + ((char char) (##core#inline "C_u_i_char_greater_or_equal_p" #(1) #(2)))) +(char<=? (#(procedure #:clean #:enforce #:foldable) char<=? (char char) boolean) + ((char char) (##core#inline "C_u_i_char_less_or_equal_p" #(1) #(2)))) (char-ci=? (#(procedure #:clean #:enforce #:foldable) char-ci=? (char char) boolean)) (char-ci