suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add unsafe-char=?, etc.

Browse Source
This commit is contained in:
Matthew Flatt 2018-08-24 18:21:35 -06:00
parent d54c60ae3a
commit d0eb8f6c53
17 changed files with 361 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.0.0.14")
(define version "7.0.0.15")
(define deps `("racket-lib"
["racket" #:version ,version]))

2
pkgs/racket-doc/scribblings/reference/mz.rkt
View File

@ -155,6 +155,6 @@
;; The arity of many functions changed in 7.0.0.13:
(provide history/arity)
(define-syntax-rule (history/arity arg ...)
(history #:changed "7.0.0.13" @elem{Allow one argument, in addition to two or more.}
(history #:changed "7.0.0.13" @elem{Allow one argument, in addition to allowing two or more.}
arg ...))

92
pkgs/racket-doc/scribblings/reference/unsafe.scrbl
View File

@ -42,9 +42,9 @@ operations can be prevented by adjusting the code inspector (see
@section{Unsafe Numeric Operations}
@deftogether[(
@defproc[(unsafe-fx+ [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fx- [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fx* [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fx+ [a fixnum?] ...) fixnum?]
@defproc[(unsafe-fx- [a fixnum?] [b fixnum?] ...) fixnum?]
@defproc[(unsafe-fx* [a fixnum?] ...) fixnum?]
@defproc[(unsafe-fxquotient [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fxremainder [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fxmodulo [a fixnum?] [b fixnum?]) fixnum?]
@ -57,13 +57,16 @@ For @tech{fixnums}: Like @racket[+], @racket[-], @racket[*],
@tech{fixnum} result. The mathematical operation on @racket[a] and
@racket[b] must be representable as a @tech{fixnum}. In the case of
@racket[unsafe-fxquotient], @racket[unsafe-fxremainder], and
@racket[unsafe-fxmodulo], @racket[b] must not be @racket[0].}
@racket[unsafe-fxmodulo], @racket[b] must not be @racket[0].
@history[#:changed "7.0.0.13" @elem{Allow zero or more arguments for @racket[unsafe-fx+] and @racket[unsafe-fx*]
and allow one or more arguments for @racket[unsafe-fx-].}]}
@deftogether[(
@defproc[(unsafe-fxand [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fxior [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fxxor [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fxand [a fixnum?] ...) fixnum?]
@defproc[(unsafe-fxior [a fixnum?] ...) fixnum?]
@defproc[(unsafe-fxxor [a fixnum?] ...) fixnum?]
@defproc[(unsafe-fxnot [a fixnum?]) fixnum?]
@defproc[(unsafe-fxlshift [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fxrshift [a fixnum?] [b fixnum?]) fixnum?]
@ -80,49 +83,62 @@ the result is always a @tech{fixnum}. The @racket[unsafe-fxlshift] and
number of bits to shift must be no more than the number of bits used to
represent a @tech{fixnum}. In the case of @racket[unsafe-fxlshift],
bits in the result beyond the number of bits used to represent a
@tech{fixnum} are effectively replaced with a copy of the high bit.}
@tech{fixnum} are effectively replaced with a copy of the high bit.
@history[#:changed "7.0.0.13" @elem{Allow zero or more arguments for
@racket[unsafe-fxand], @racket[unsafe-fxior],
and @racket[unsafe-fxxor].}]}
@deftogether[(
@defproc[(unsafe-fx= [a fixnum?] [b fixnum?]) boolean?]
@defproc[(unsafe-fx< [a fixnum?] [b fixnum?]) boolean?]
@defproc[(unsafe-fx> [a fixnum?] [b fixnum?]) boolean?]
@defproc[(unsafe-fx<= [a fixnum?] [b fixnum?]) boolean?]
@defproc[(unsafe-fx>= [a fixnum?] [b fixnum?]) boolean?]
@defproc[(unsafe-fxmin [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fxmax [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(unsafe-fx= [a fixnum?] [b fixnum?] ...) boolean?]
@defproc[(unsafe-fx< [a fixnum?] [b fixnum?] ...) boolean?]
@defproc[(unsafe-fx> [a fixnum?] [b fixnum?] ...) boolean?]
@defproc[(unsafe-fx<= [a fixnum?] [b fixnum?] ...) boolean?]
@defproc[(unsafe-fx>= [a fixnum?] [b fixnum?] ...) boolean?]
@defproc[(unsafe-fxmin [a fixnum?] [b fixnum?] ...) fixnum?]
@defproc[(unsafe-fxmax [a fixnum?] [b fixnum?] ...) fixnum?]
)]{
For @tech{fixnums}: Like @racket[=], @racket[<], @racket[>],
@racket[<=], @racket[>=], @racket[min], and @racket[max], but
constrained to consume @tech{fixnums}.}
constrained to consume @tech{fixnums}.
@history[#:changed "7.0.0.13" @elem{Allow one or more argument,
instead of allowing just two.}]}
@deftogether[(
@defproc[(unsafe-fl+ [a flonum?] [b flonum?]) flonum?]
@defproc[(unsafe-fl- [a flonum?] [b flonum?]) flonum?]
@defproc[(unsafe-fl* [a flonum?] [b flonum?]) flonum?]
@defproc[(unsafe-fl/ [a flonum?] [b flonum?]) flonum?]
@defproc[(unsafe-fl+ [a flonum?] ...) flonum?]
@defproc[(unsafe-fl- [a flonum?] [b flonum?] ...) flonum?]
@defproc[(unsafe-fl* [a flonum?] ...) flonum?]
@defproc[(unsafe-fl/ [a flonum?] [b flonum?] ...) flonum?]
@defproc[(unsafe-flabs [a flonum?]) flonum?]
)]{
For @tech{flonums}: Unchecked versions of @racket[fl+], @racket[fl-],
@racket[fl*], @racket[fl/], and @racket[flabs].}
@racket[fl*], @racket[fl/], and @racket[flabs].
@history[#:changed "7.0.0.13" @elem{Allow zero or more arguments for @racket[unsafe-fl+] and @racket[unsafe-fl*]
and one or more arguments for @racket[unsafe-fl-] and @racket[unsafe-fl/].}]}
@deftogether[(
@defproc[(unsafe-fl= [a flonum?] [b flonum?]) boolean?]
@defproc[(unsafe-fl< [a flonum?] [b flonum?]) boolean?]
@defproc[(unsafe-fl> [a flonum?] [b flonum?]) boolean?]
@defproc[(unsafe-fl<= [a flonum?] [b flonum?]) boolean?]
@defproc[(unsafe-fl>= [a flonum?] [b flonum?]) boolean?]
@defproc[(unsafe-flmin [a flonum?] [b flonum?]) flonum?]
@defproc[(unsafe-flmax [a flonum?] [b flonum?]) flonum?]
@defproc[(unsafe-fl= [a flonum?] [b flonum?] ...) boolean?]
@defproc[(unsafe-fl< [a flonum?] [b flonum?] ...) boolean?]
@defproc[(unsafe-fl> [a flonum?] [b flonum?] ...) boolean?]
@defproc[(unsafe-fl<= [a flonum?] [b flonum?] ...) boolean?]
@defproc[(unsafe-fl>= [a flonum?] [b flonum?] ...) boolean?]
@defproc[(unsafe-flmin [a flonum?] [b flonum?] ...) flonum?]
@defproc[(unsafe-flmax [a flonum?] [b flonum?] ...) flonum?]
)]{
For @tech{flonums}: Unchecked versions of @racket[fl=], @racket[fl<],
@racket[fl>], @racket[fl<=], @racket[fl>=], @racket[flmin], and
@racket[flmax].}
@racket[flmax].
@history[#:changed "7.0.0.13" @elem{Allow one or more argument,
instead of allowing just two.}]}
@deftogether[(
@ -191,6 +207,24 @@ Unchecked version of @racket[flrandom].
}
@section{Unsafe Character Operations}
@deftogether[(
@defproc[(unsafe-char=? [a char?] [b char?] ...) boolean?]
@defproc[(unsafe-char<? [a char?] [b char?] ...) boolean?]
@defproc[(unsafe-char>? [a char?] [b char?] ...) boolean?]
@defproc[(unsafe-char<=? [a char?] [b char?] ...) boolean?]
@defproc[(unsafe-char>=? [a char?] [b char?] ...) boolean?]
@defproc[(unsafe-char->integer [a char?]) fixnum?]
)]{
Unchecked versions of @racket[char=?], @racket[char<?], @racket[char>?],
@racket[char<=?], @racket[char>=?], and @racket[char->integer].
@history[#:added "7.0.0.14"]}
@section{Unsafe Data Extraction}
@deftogether[(

22
pkgs/racket-test-core/tests/racket/unsafe.rktl
View File

@ -219,6 +219,28 @@
(test-tri 30 unsafe-fxmax 3 30 -90)
(test-tri 90 unsafe-fxmax 3 30 90)
(test-bin #f unsafe-char=? #\1 #\2 #:branch? #t)
(test-bin #t unsafe-char=? #\2 #\2 #:branch? #t)
(test-bin #f unsafe-char=? #\2 #\1 #:branch? #t)
(test-bin #t unsafe-char<? #\1 #\2 #:branch? #t)
(test-bin #f unsafe-char<? #\2 #\2 #:branch? #t)
(test-bin #f unsafe-char<? #\2 #\1 #:branch? #t)
(test-bin #f unsafe-char>? #\1 #\2 #:branch? #t)
(test-bin #f unsafe-char>? #\2 #\2 #:branch? #t)
(test-bin #t unsafe-char>? #\2 #\1 #:branch? #t)
(test-bin #t unsafe-char<=? #\1 #\2 #:branch? #t)
(test-bin #t unsafe-char<=? #\2 #\2 #:branch? #t)
(test-bin #f unsafe-char<=? #\2 #\1 #:branch? #t)
(test-bin #f unsafe-char>=? #\1 #\2 #:branch? #t)
(test-bin #t unsafe-char>=? #\2 #\2 #:branch? #t)
(test-bin #t unsafe-char>=? #\2 #\1 #:branch? #t)
(test-un 49 unsafe-char->integer #\1)
(test-un -7.8 'unsafe-fl- 7.8)
(test-bin 7.9 'unsafe-fl- 10.0 2.1)
(test-bin 3.7 'unsafe-fl- 1.0 -2.7)

6
racket/src/cs/primitive/unsafe.ss
View File

@ -17,6 +17,12 @@
[unsafe-cdr (known-procedure/succeeds 2)]
[unsafe-chaperone-procedure (known-procedure -4)]
[unsafe-chaperone-vector (known-procedure -4)]
[unsafe-char<? (known-procedure/succeeds -2)]
[unsafe-char<=? (known-procedure/succeeds -2)]
[unsafe-char=? (known-procedure/succeeds -2)]
[unsafe-char>? (known-procedure/succeeds -2)]
[unsafe-char>=? (known-procedure/succeeds -2)]
[unsafe-char->integer (known-procedure/succeeds 2)]
[unsafe-cons-list (known-procedure/succeeds 4)]
[unsafe-custodian-register (known-procedure 32)]
[unsafe-custodian-unregister (known-procedure 4)]

7
racket/src/cs/rumble.sls
View File

@ -482,6 +482,13 @@
unsafe-list-ref
unsafe-cons-list
unsafe-char=?
unsafe-char<?
unsafe-char>?
unsafe-char>=?
unsafe-char<=?
unsafe-char->integer
unsafe-fx+
unsafe-fx-
unsafe-fx*

7
racket/src/cs/rumble/unsafe.ss
View File

@ -3,6 +3,13 @@
(define unsafe-list-tail #3%list-tail)
(define unsafe-list-ref #3%list-ref)
(define unsafe-char=? #3%char=?)
(define unsafe-char<? #3%char<?)
(define unsafe-char>? #3%char>?)
(define unsafe-char>=? #3%char>=?)
(define unsafe-char<=? #3%char<=?)
(define unsafe-char->integer #3%char->integer)
(define unsafe-fx+ #3%fx+)
(define unsafe-fx- #3%fx-)
(define unsafe-fx* #3%fx*)

9
racket/src/expander/read/number.rkt
View File

@ -9,7 +9,8 @@
(prefix-in host: "../host/string-to-number.rkt")
"parameter.rkt")
(provide string->number)
(provide string->number
unchecked-string->number)
;; The `string->number` parser is responsible for handling Racket's
;; elaborate number syntax (mostly inherited from Scheme). It relies
@ -37,7 +38,9 @@
(eq? p 'decimal-as-exact)))
#:contract "(or/c 'decimal-as-inexact decimal-as-exact)"
decimal-mode)
(unchecked-string->number s radix convert-mode decimal-mode))
(define (unchecked-string->number s radix convert-mode decimal-mode)
(do-string->number s 0 (string-length s)
radix #:radix-set? #f
decimal-mode
@ -295,7 +298,7 @@
(cond
[exp-pos
(fail convert-mode "misplaced `~a` in `~.a`" c (substring s start end))]
;; Dont count a sign in something like 1e+2 as `sign-pos`
;; Don't count a sign in something like 1e+2 as `sign-pos`
[(and ((add1 i) . < . end)
(char-sign? (string-ref s (add1 i))))
(loop (+ i 2) any-digits? any-hashes? i-pos @-pos
@ -398,7 +401,7 @@
(inexact->exact p)
p)]))
;; Parse a real number that might be a faction, have `.`, or have `#`s
;; Parse a real number that might be a fraction, have `.`, or have `#`s
(define (string->real-number s start end
dot-pos slash-pos exp-pos
any-hashes? ; can be false-positive

16
racket/src/expander/read/symbol-or-number.rkt
View File

@ -114,14 +114,14 @@
(and (or (eq? mode 'symbol-or-number)
(string? mode))
(not quoted-ever?)
(string->number (if (string? mode)
(string-append mode str)
str)
10
'read
(if (check-parameter read-decimal-as-inexact config)
'decimal-as-inexact
'decimal-as-exact))))
(unchecked-string->number (if (string? mode)
(string-append mode str)
str)
10
'read
(if (check-parameter read-decimal-as-inexact config)
'decimal-as-inexact
'decimal-as-exact))))
(when (string? num)
(reader-error in config "~a" num))

114
racket/src/racket/src/char.c
View File

@ -34,6 +34,13 @@ READ_ONLY static Scheme_Object *general_category_symbols[NUM_GENERAL_CATEGORIES]
READ_ONLY Scheme_Object *scheme_char_p_proc;
READ_ONLY Scheme_Object *scheme_interned_char_p_proc;
READ_ONLY Scheme_Object *scheme_unsafe_char_eq_proc;
READ_ONLY Scheme_Object *scheme_unsafe_char_lt_proc;
READ_ONLY Scheme_Object *scheme_unsafe_char_gt_proc;
READ_ONLY Scheme_Object *scheme_unsafe_char_lt_eq_proc;
READ_ONLY Scheme_Object *scheme_unsafe_char_gt_eq_proc;
READ_ONLY Scheme_Object *scheme_unsafe_char_to_integer_proc;
/* locals */
static Scheme_Object *char_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *interned_char_p (int argc, Scheme_Object *argv[]);
@ -42,6 +49,12 @@ static Scheme_Object *char_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *char_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *char_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *char_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_char_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_char_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_char_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_char_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_char_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_char_to_integer (int argc, Scheme_Object *argv[]);
static Scheme_Object *char_eq_ci (int argc, Scheme_Object *argv[]);
static Scheme_Object *char_lt_ci (int argc, Scheme_Object *argv[]);
static Scheme_Object *char_gt_ci (int argc, Scheme_Object *argv[]);
@ -120,27 +133,32 @@ void scheme_init_char (Scheme_Startup_Env *env)
p = scheme_make_folding_prim(char_eq, "char=?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_PRODUCES_BOOL);
| SCHEME_PRIM_PRODUCES_BOOL
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("char=?", p, env);
p = scheme_make_folding_prim(char_lt, "char<?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_PRODUCES_BOOL);
| SCHEME_PRIM_PRODUCES_BOOL
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("char<?", p, env);
p = scheme_make_folding_prim(char_gt, "char>?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_PRODUCES_BOOL);
| SCHEME_PRIM_PRODUCES_BOOL
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("char>?", p, env);
p = scheme_make_folding_prim(char_lt_eq, "char<=?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_PRODUCES_BOOL);
| SCHEME_PRIM_PRODUCES_BOOL
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("char<=?", p, env);
p = scheme_make_folding_prim(char_gt_eq, "char>=?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_PRODUCES_BOOL);
| SCHEME_PRIM_PRODUCES_BOOL
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("char>=?", p, env);
ADD_FOLDING_PRIM("char-ci=?", char_eq_ci, 1, -1, 1, env);
@ -166,7 +184,8 @@ void scheme_init_char (Scheme_Startup_Env *env)
ADD_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env);
p = scheme_make_folding_prim(scheme_checked_char_to_integer, "char->integer", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("char->integer", p, env);
p = scheme_make_folding_prim(scheme_checked_integer_to_char, "integer->char", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED);
@ -181,6 +200,57 @@ void scheme_init_char (Scheme_Startup_Env *env)
ADD_IMMED_PRIM("make-known-char-range-list", char_map_list, 0, 0, env);
}
void scheme_init_unsafe_char(Scheme_Startup_Env *env)
{
Scheme_Object *p;
REGISTER_SO(scheme_unsafe_char_eq_proc);
p = scheme_make_folding_prim(unsafe_char_eq, "unsafe-char=?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_addto_prim_instance("unsafe-char=?", p, env);
scheme_unsafe_char_eq_proc = p;
REGISTER_SO(scheme_unsafe_char_lt_proc);
p = scheme_make_folding_prim(unsafe_char_lt, "unsafe-char<?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_addto_prim_instance("unsafe-char<?", p, env);
scheme_unsafe_char_lt_proc = p;
REGISTER_SO(scheme_unsafe_char_gt_proc);
p = scheme_make_folding_prim(unsafe_char_gt, "unsafe-char>?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_addto_prim_instance("unsafe-char>?", p, env);
scheme_unsafe_char_gt_proc = p;
REGISTER_SO(scheme_unsafe_char_lt_eq_proc);
p = scheme_make_folding_prim(unsafe_char_lt_eq, "unsafe-char<=?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_addto_prim_instance("unsafe-char<=?", p, env);
scheme_unsafe_char_lt_eq_proc = p;
REGISTER_SO(scheme_unsafe_char_gt_eq_proc);
p = scheme_make_folding_prim(unsafe_char_gt_eq, "unsafe-char>=?", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_addto_prim_instance("unsafe-char>=?", p, env);
scheme_unsafe_char_gt_eq_proc = p;
REGISTER_SO(scheme_unsafe_char_to_integer_proc);
p = scheme_make_folding_prim(unsafe_char_to_integer, "unsafe-char->integer", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED);
scheme_addto_prim_instance("unsafe-char->integer", p, env);
scheme_unsafe_char_to_integer_proc = p;
}
Scheme_Object *scheme_make_char(mzchar ch)
{
Scheme_Object *o;
@ -252,6 +322,25 @@ GEN_CHAR_COMP(char_gt_ci, char-ci>?, >, charSTD_FOLDCASE)
GEN_CHAR_COMP(char_lt_eq_ci, char-ci<=?, <=, charSTD_FOLDCASE)
GEN_CHAR_COMP(char_gt_eq_ci, char-ci>=?, >=, charSTD_FOLDCASE)
#define GEN_UNSAFE_CHAR_COMP(func_name, scheme_name, comp, fold) \
static Scheme_Object *func_name(int argc, Scheme_Object *argv[]) \
{ int c, prev, i; Scheme_Object *rv = scheme_true; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
prev = SCHEME_CHAR_VAL(argv[0]); \
for (i = 1; i < argc; i++) { \
c = SCHEME_CHAR_VAL(argv[i]); \
if (!(prev comp c)) rv = scheme_false; \
prev = c; \
} \
return rv; \
}
GEN_UNSAFE_CHAR_COMP(unsafe_char_eq, unsafe-char=?, ==, char_eq)
GEN_UNSAFE_CHAR_COMP(unsafe_char_lt, unsafe-char<?, <, char_lt)
GEN_UNSAFE_CHAR_COMP(unsafe_char_gt, unsafe-char>?, >, char_gt)
GEN_UNSAFE_CHAR_COMP(unsafe_char_lt_eq, unsafe-char<=?, <=, char_lt_eq)
GEN_UNSAFE_CHAR_COMP(unsafe_char_gt_eq, unsafe-char>=?, >=, char_gt_eq)
#define GEN_CHAR_TEST(func_name, scheme_name, pred) \
static Scheme_Object *func_name (int argc, Scheme_Object *argv[]) \
{ \
@ -287,6 +376,19 @@ scheme_checked_char_to_integer (int argc, Scheme_Object *argv[])
return scheme_make_integer_value(c);
}
Scheme_Object *
unsafe_char_to_integer (int argc, Scheme_Object *argv[])
{
mzchar c;
if (scheme_current_thread->constant_folding)
return scheme_checked_char_to_integer(argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
return scheme_make_integer_value(c);
}
Scheme_Object *
scheme_checked_integer_to_char (int argc, Scheme_Object *argv[])
{

1
racket/src/racket/src/env.c
View File

@ -370,6 +370,7 @@ static void init_unsafe(Scheme_Startup_Env *env)
scheme_init_unsafe_number(env);
scheme_init_unsafe_numarith(env);
scheme_init_unsafe_numcomp(env);
scheme_init_unsafe_char(env);
scheme_init_unsafe_list(env);
scheme_init_unsafe_hash(env);
scheme_init_unsafe_vector(env);

134
racket/src/racket/src/jitinline.c
View File

@ -2372,8 +2372,12 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
#endif
return 1;
} else if (IS_NAMED_PRIM(rator, "char->integer")) {
} else if (IS_NAMED_PRIM(rator, "char->integer")
|| IS_NAMED_PRIM(rator, "unsafe-char->integer")) {
GC_CAN_IGNORE jit_insn *ref, *reffail;
int unsafe;
unsafe = IS_NAMED_PRIM(rator, "unsafe-char->integer");
mz_runstack_skipped(jitter, 1);
scheme_generate_non_tail(app->rand, jitter, 0, 1, 0);
@ -2382,16 +2386,18 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
mz_rs_sync();
__START_TINY_JUMPS__(1);
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
reffail = jit_get_ip();
__END_TINY_JUMPS__(1);
(void)jit_calli(sjc.bad_char_to_integer_code);
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
(void)mz_bnei_t(reffail, JIT_R0, scheme_char_type, JIT_R1);
__END_TINY_JUMPS__(1);
if (!unsafe) {
__START_TINY_JUMPS__(1);
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
reffail = jit_get_ip();
__END_TINY_JUMPS__(1);
(void)jit_calli(sjc.bad_char_to_integer_code);
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
(void)mz_bnei_t(reffail, JIT_R0, scheme_char_type, JIT_R1);
__END_TINY_JUMPS__(1);
}
(void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_CHAR_VAL(0x0));
CHECK_LIMIT();
@ -2693,19 +2699,38 @@ int scheme_generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
}
static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, int cmp,
Branch_Info *for_branch, int branch_short, int dest)
Branch_Info *for_branch, int branch_short, int dest,
int unsafe)
/* de-sync'd ok */
{
Scheme_Object *r1, *r2, *rator = app->rator;
GC_CAN_IGNORE jit_insn *reffail = NULL, *ref;
int direct = 0, direction;
int direction;
LOG_IT(("inlined %s\n", ((Scheme_Primitive_Proc *)rator)->name));
r1 = app->rand1;
r2 = app->rand2;
direction = scheme_generate_two_args(r1, r2, jitter, 0, 2);
CHECK_LIMIT();
if (SCHEME_CHARP(r2)) {
if (!SCHEME_CHARP(r1)) {
mz_runstack_skipped(jitter, 2);
scheme_generate_non_tail(r1, jitter, 0, 1, 0);
mz_runstack_unskipped(jitter, 2);
} else {
/* We could perform the comparison statically, but we don't
bother, because this seems unlikely to happen. */
}
direction = 1;
} else if (SCHEME_CHARP(r1)) {
mz_runstack_skipped(jitter, 2);
scheme_generate_non_tail(r2, jitter, 0, 1, 0);
mz_runstack_unskipped(jitter, 2);
direction = -1;
} else {
direction = scheme_generate_two_args(r1, r2, jitter, 0, 2);
CHECK_LIMIT();
}
if (direction < 0) {
/* reverse sense of comparison */
@ -2731,12 +2756,14 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, int
mz_rs_sync();
__START_SHORT_JUMPS__(branch_short);
if (!SCHEME_CHARP(r1)) {
if (!SCHEME_CHARP(r1) && !unsafe) {
GC_CAN_IGNORE jit_insn *pref;
pref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
reffail = jit_get_ip();
(void)jit_movi_p(JIT_R2, ((Scheme_Primitive_Proc *)rator)->prim_val);
if (SCHEME_CHARP(r2))
scheme_mz_load_retained(jitter, JIT_R1, r2);
__END_SHORT_JUMPS__(branch_short);
if (direction > 0) {
(void)jit_calli(sjc.call_original_binary_rev_arith_code);
@ -2747,11 +2774,9 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, int
mz_patch_branch(pref);
(void)mz_bnei_t(reffail, JIT_R0, scheme_char_type, JIT_R2);
CHECK_LIMIT();
} else {
if (!direct)
direct = (SCHEME_CHAR_VAL(r1) < 256);
}
if (!SCHEME_CHARP(r2)) {
if (!SCHEME_CHARP(r2) && !unsafe) {
if (!reffail) {
GC_CAN_IGNORE jit_insn *pref;
pref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1);
@ -2770,9 +2795,22 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, int
}
(void)mz_bnei_t(reffail, JIT_R1, scheme_char_type, JIT_R2);
CHECK_LIMIT();
}
/* Now that checks are done, extract character value */
if (!SCHEME_CHARP(r1)) {
/* Extract character value */
jit_ldxi_i(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0));
} else {
if (!direct)
direct = (SCHEME_CHAR_VAL(r2) < 256);
/* Unlikely, due to folding, but possible due to specialization */
jit_ldi_i(JIT_R0, SCHEME_CHAR_VAL(r1));
}
if (!SCHEME_CHARP(r2)) {
/* Extract character value */
jit_ldxi_i(JIT_R1, JIT_R1, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0));
} else {
/* Generate comparsion below to an immediate number */
}
if (for_branch) {
@ -2780,11 +2818,7 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, int
CHECK_LIMIT();
}
if (!direct || (cmp != CMP_EQUAL)) {
/* Extract character value */
jit_ldxi_i(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0));
jit_ldxi_i(JIT_R1, JIT_R1, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0));
if (!SCHEME_CHARP(r2)) {
switch (cmp) {
case CMP_EQUAL:
ref = jit_bner_i(jit_forward(), JIT_R0, JIT_R1);
@ -2805,15 +2839,28 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, int
ref = NULL; /* never happens */
}
} else {
/* Equality on small chars can compare pointers */
switch(cmp) {
int ch = SCHEME_CHAR_VAL(r2);
switch (cmp) {
case CMP_EQUAL:
ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1);
ref = jit_bnei_i(jit_forward(), JIT_R0, ch);
break;
case CMP_LEQ:
ref = jit_bgti_i(jit_forward(), JIT_R0, ch);
break;
case CMP_GEQ:
ref = jit_blti_i(jit_forward(), JIT_R0, ch);
break;
case CMP_GT:
ref = jit_blei_i(jit_forward(), JIT_R0, ch);
break;
case CMP_LT:
ref = jit_bgei_i(jit_forward(), JIT_R0, ch);
break;
default:
ref = NULL; /* never happens */
}
}
CHECK_LIMIT();
if (for_branch) {
scheme_add_branch_false(for_branch, ref);
@ -3598,19 +3645,34 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_BIT, 0, for_branch, branch_short, 0, 0, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "char=?")) {
generate_binary_char(jitter, app, CMP_EQUAL, for_branch, branch_short, dest);
generate_binary_char(jitter, app, CMP_EQUAL, for_branch, branch_short, dest, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-char=?")) {
generate_binary_char(jitter, app, CMP_EQUAL, for_branch, branch_short, dest, 1);
return 1;
} else if (IS_NAMED_PRIM(rator, "char<=?")) {
generate_binary_char(jitter, app, CMP_LEQ, for_branch, branch_short, dest);
generate_binary_char(jitter, app, CMP_LEQ, for_branch, branch_short, dest, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-char<=?")) {
generate_binary_char(jitter, app, CMP_LEQ, for_branch, branch_short, dest, 1);
return 1;
} else if (IS_NAMED_PRIM(rator, "char>=?")) {
generate_binary_char(jitter, app, CMP_GEQ, for_branch, branch_short, dest);
generate_binary_char(jitter, app, CMP_GEQ, for_branch, branch_short, dest, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-char>=?")) {
generate_binary_char(jitter, app, CMP_GEQ, for_branch, branch_short, dest, 1);
return 1;
} else if (IS_NAMED_PRIM(rator, "char>?")) {
generate_binary_char(jitter, app, CMP_GT, for_branch, branch_short, dest);
generate_binary_char(jitter, app, CMP_GT, for_branch, branch_short, dest, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-char>?")) {
generate_binary_char(jitter, app, CMP_GT, for_branch, branch_short, dest, 1);
return 1;
} else if (IS_NAMED_PRIM(rator, "char<?")) {
generate_binary_char(jitter, app, CMP_LT, for_branch, branch_short, dest);
generate_binary_char(jitter, app, CMP_LT, for_branch, branch_short, dest, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-char<?")) {
generate_binary_char(jitter, app, CMP_LT, for_branch, branch_short, dest, 1);
return 1;
} else if (!for_branch) {
if (IS_NAMED_PRIM(rator, "+")) {

12
racket/src/racket/src/optimize.c
View File

@ -4009,9 +4009,9 @@ static void check_known_both_try(Optimize_Info *info, Scheme_Object *app,
reset_rator(app, unsafe);
} else {
pred1 = expr_implies_predicate(rand1, info);
if (pred1 && SAME_OBJ(pred1, expect_pred)) {
if (pred1 && predicate_implies(pred1, expect_pred)) {
pred2 = expr_implies_predicate(rand2, info);
if (pred2 && SAME_OBJ(pred2, expect_pred)) {
if (pred2 && predicate_implies(pred2, expect_pred)) {
reset_rator(app, unsafe);
}
}
@ -4637,6 +4637,8 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
check_known(info, app_o, rator, rand, "symbol->string", scheme_symbol_p_proc, scheme_true, info->unsafe_mode);
check_known(info, app_o, rator, rand, "string->keyword", scheme_string_p_proc, scheme_true, info->unsafe_mode);
check_known(info, app_o, rator, rand, "keyword->string", scheme_keyword_p_proc, scheme_true, info->unsafe_mode);
check_known(info, app_o, rator, rand, "char->integer", scheme_char_p_proc, scheme_unsafe_char_to_integer_proc, info->unsafe_mode);
}
if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL)
@ -5124,6 +5126,12 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
check_known_both_try(info, app_o, rator, rand1, rand2, "fx-", scheme_fixnum_p_proc, scheme_unsafe_fx_minus_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "fx*", scheme_fixnum_p_proc, scheme_unsafe_fx_times_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "char=?", scheme_char_p_proc, scheme_unsafe_char_eq_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "char<?", scheme_char_p_proc, scheme_unsafe_char_lt_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "char>?", scheme_char_p_proc, scheme_unsafe_char_gt_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "char<=?", scheme_char_p_proc, scheme_unsafe_char_lt_eq_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "char>=?", scheme_char_p_proc, scheme_unsafe_char_gt_eq_proc, info->unsafe_mode);
rator = app->rator; /* in case it was updated */
check_known_both(info, app_o, rator, rand1, rand2, "string-append", scheme_string_p_proc, scheme_true, info->unsafe_mode);

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1441
#define EXPECTED_PRIM_COUNT 1447
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

8
racket/src/racket/src/schpriv.h
View File

@ -377,6 +377,7 @@ void scheme_init_compile(Scheme_Startup_Env *env);
void scheme_init_symbol(Scheme_Startup_Env *env);
void scheme_init_char_constants(void);
void scheme_init_char(Scheme_Startup_Env *env);
void scheme_init_unsafe_char(Scheme_Startup_Env *env);
void scheme_init_bool(Scheme_Startup_Env *env);
void scheme_init_syntax(Scheme_Startup_Env *env);
void scheme_init_marshal(Scheme_Startup_Env *env);
@ -639,6 +640,13 @@ extern Scheme_Object *scheme_unsafe_fx_plus_proc;
extern Scheme_Object *scheme_unsafe_fx_minus_proc;
extern Scheme_Object *scheme_unsafe_fx_times_proc;
extern Scheme_Object *scheme_unsafe_char_eq_proc;
extern Scheme_Object *scheme_unsafe_char_lt_proc;
extern Scheme_Object *scheme_unsafe_char_gt_proc;
extern Scheme_Object *scheme_unsafe_char_lt_eq_proc;
extern Scheme_Object *scheme_unsafe_char_gt_eq_proc;
extern Scheme_Object *scheme_unsafe_char_to_integer_proc;
extern Scheme_Object *scheme_not_proc;
extern Scheme_Object *scheme_true_object_p_proc;
extern Scheme_Object *scheme_boolean_p_proc;

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "7.0.0.14"
#define MZSCHEME_VERSION "7.0.0.15"
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 14
#define MZSCHEME_VERSION_W 15
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

27
racket/src/racket/src/startup.inc
View File

@ -50130,6 +50130,16 @@ static const char *startup_source =
" 'string->number"
" \"(or/c 'decimal-as-inexact decimal-as-exact)\""
" decimal-mode_0)))"
"(unchecked-string->number s_0 radix_0 convert-mode_0 decimal-mode_0)))))))))))))"
"(case-lambda"
"((s_0)(begin 'string->number(string->number5_0 s_0 10 'number-or-false unsafe-undefined)))"
"((s_0 radix_0 convert-mode_0 decimal-mode3_0)(string->number5_0 s_0 radix_0 convert-mode_0 decimal-mode3_0))"
"((s_0 radix_0 convert-mode2_0)(string->number5_0 s_0 radix_0 convert-mode2_0 unsafe-undefined))"
"((s_0 radix1_0)(string->number5_0 s_0 radix1_0 'number-or-false unsafe-undefined)))))"
"(define-values"
"(unchecked-string->number)"
"(lambda(s_0 radix_0 convert-mode_0 decimal-mode_0)"
"(begin"
"(let-values(((s66_0) s_0)"
"((temp67_0) 0)"
"((temp68_0)(string-length s_0))"
@ -50137,20 +50147,7 @@ static const char *startup_source =
"((temp70_0) #f)"
"((decimal-mode71_0) decimal-mode_0)"
"((convert-mode72_0) convert-mode_0))"
"(do-string->number17.1"
" #f"
" temp70_0"
" s66_0"
" temp67_0"
" temp68_0"
" radix69_0"
" decimal-mode71_0"
" convert-mode72_0))))))))))))))"
"(case-lambda"
"((s_0)(begin 'string->number(string->number5_0 s_0 10 'number-or-false unsafe-undefined)))"
"((s_0 radix_0 convert-mode_0 decimal-mode3_0)(string->number5_0 s_0 radix_0 convert-mode_0 decimal-mode3_0))"
"((s_0 radix_0 convert-mode2_0)(string->number5_0 s_0 radix_0 convert-mode2_0 unsafe-undefined))"
"((s_0 radix1_0)(string->number5_0 s_0 radix1_0 'number-or-false unsafe-undefined)))))"
"(do-string->number17.1 #f temp70_0 s66_0 temp67_0 temp68_0 radix69_0 decimal-mode71_0 convert-mode72_0)))))"
"(define-values"
"(do-string->number17.1)"
"(lambda(in-complex8_0 radix-set?7_0 s11_0 start12_0 end13_0 radix14_0 exactness15_0 convert-mode16_0)"
@ -51948,7 +51945,7 @@ static const char *startup_source =
"(eq? mode_0 'symbol-or-number)))"
"(if or-part_0 or-part_0(string? mode_0)))"
"(if(not quoted-ever?_0)"
"(1/string->number"
"(unchecked-string->number"
"(if(string? mode_0)"
"(string-append mode_0 str_0)"
" str_0)"