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

generalize some function arities

Browse Source 
Allow a single argument to comparison functions like `<`, and
support the same arities as the generic version for fixnum and
flonum operations like `fx+` or `fl+`.
This commit is contained in:
Matthew Flatt 2018-08-19 15:01:35 -06:00
parent 008102decc
commit 4128189499
34 changed files with 1258 additions and 546 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.12")
(define version "7.0.0.13")
(define deps `("racket-lib"
["racket" #:version ,version]))

4
pkgs/racket-doc/scribblings/guide/performance.scrbl
View File

@ -325,7 +325,9 @@ compiler to generate code that avoids boxing and unboxing intermediate
results. Besides results within immediate combinations,
flonum-specific results that are bound with @racket[let] and consumed
by a later flonum-specific operation are unboxed within temporary
storage. Finally, the compiler can detect some flonum-valued loop
storage. @margin-note*{Unboxing applies most reliably to uses of a
flonum-specific operation with two arguments.}
Finally, the compiler can detect some flonum-valued loop
accumulators and avoid boxing of the accumulator. The bytecode
decompiler (see @secref[#:doc '(lib "scribblings/raco/raco.scrbl")
"decompile"]) annotates combinations where the JIT can avoid boxes with

18
pkgs/racket-doc/scribblings/reference/bytes.scrbl
View File

@ -195,30 +195,36 @@ For communication among @tech{places}, the new byte string is allocated in the
@; ----------------------------------------
@section{Byte String Comparisons}
@defproc[(bytes=? [bstr1 bytes?] [bstr2 bytes?] ...+) boolean?]{ Returns
@racket[#t] if all of the arguments are @racket[eqv?].}
@defproc[(bytes=? [bstr1 bytes?] [bstr2 bytes?] ...) boolean?]{ Returns
@racket[#t] if all of the arguments are @racket[eqv?].
@mz-examples[(bytes=? #"Apple" #"apple")
(bytes=? #"a" #"as" #"a")]
@history/arity[]}
@(define (bytes-sort direction)
@elem{Like @racket[bytes<?], but checks whether the arguments are @|direction|.})
@defproc[(bytes<? [bstr1 bytes?] [bstr2 bytes?] ...+) boolean?]{
@defproc[(bytes<? [bstr1 bytes?] [bstr2 bytes?] ...) boolean?]{
Returns @racket[#t] if the arguments are lexicographically sorted
increasing, where individual bytes are ordered by @racket[<],
@racket[#f] otherwise.
@mz-examples[(bytes<? #"Apple" #"apple")
(bytes<? #"apple" #"Apple")
(bytes<? #"a" #"b" #"c")]}
(bytes<? #"a" #"b" #"c")]
@defproc[(bytes>? [bstr1 bytes?] [bstr2 bytes?] ...+) boolean?]{
@history/arity[]}
@defproc[(bytes>? [bstr1 bytes?] [bstr2 bytes?] ...) boolean?]{
@bytes-sort["decreasing"]
@mz-examples[(bytes>? #"Apple" #"apple")
(bytes>? #"apple" #"Apple")
(bytes>? #"c" #"b" #"a")]}
(bytes>? #"c" #"b" #"a")]
@history/arity[]}
@; ----------------------------------------
@section{Bytes to/from Characters, Decoding and Encoding}

60
pkgs/racket-doc/scribblings/reference/chars.scrbl
View File

@ -60,19 +60,21 @@ Produces the same result as @racket[(bytes-length (string->bytes/utf-8
@; ----------------------------------------
@section{Character Comparisons}
@defproc[(char=? [char1 char?] [char2 char?] ...+) boolean?]{
@defproc[(char=? [char1 char?] [char2 char?] ...) boolean?]{
Returns @racket[#t] if all of the arguments are @racket[eqv?].
@mz-examples[(char=? #\a #\a)
(char=? #\a #\A #\a)]}
(char=? #\a #\A #\a)]
@history/arity[]}
@(define (char-sort direction folded?)
(if folded?
@elem{Like @racket[char-ci<?], but checks whether the arguments would be @direction after case-folding.}
@elem{Like @racket[char<?], but checks whether the arguments are @|direction|.}))
@defproc[(char<? [char1 char?] [char2 char?] ...+) boolean?]{
@defproc[(char<? [char1 char?] [char2 char?] ...) boolean?]{
Returns @racket[#t] if the arguments are sorted increasing, where
two characters are ordered by their scalar values, @racket[#f]
@ -80,66 +82,84 @@ otherwise.
@mz-examples[(char<? #\A #\a)
(char<? #\a #\A)
(char<? #\a #\b #\c)]}
(char<? #\a #\b #\c)]
@defproc[(char<=? [char1 char?] [char2 char?] ...+) boolean?]{
@history/arity[]}
@defproc[(char<=? [char1 char?] [char2 char?] ...) boolean?]{
@char-sort["nondecreasing" #f]
@mz-examples[(char<=? #\A #\a)
(char<=? #\a #\A)
(char<=? #\a #\b #\b)]}
(char<=? #\a #\b #\b)]
@defproc[(char>? [char1 char?] [char2 char?] ...+) boolean?]{
@history/arity[]}
@defproc[(char>? [char1 char?] [char2 char?] ...) boolean?]{
@char-sort["decreasing" #f]
@mz-examples[(char>? #\A #\a)
(char>? #\a #\A)
(char>? #\c #\b #\a)]}
(char>? #\c #\b #\a)]
@defproc[(char>=? [char1 char?] [char2 char?] ...+) boolean?]{
@history/arity[]}
@defproc[(char>=? [char1 char?] [char2 char?] ...) boolean?]{
@char-sort["nonincreasing" #f]
@mz-examples[(char>=? #\A #\a)
(char>=? #\a #\A)
(char>=? #\c #\b #\b)]}
(char>=? #\c #\b #\b)]
@history/arity[]}
@defproc[(char-ci=? [char1 char?] [char2 char?] ...+) boolean?]{
@defproc[(char-ci=? [char1 char?] [char2 char?] ...) boolean?]{
Returns @racket[#t] if all of the arguments are @racket[eqv?] after
locale-insensitive case-folding via @racket[char-foldcase].
@mz-examples[(char-ci=? #\A #\a)
(char-ci=? #\a #\a #\a)]}
(char-ci=? #\a #\a #\a)]
@defproc[(char-ci<? [char1 char?] [char2 char?] ...+) boolean?]{
@history/arity[]}
@defproc[(char-ci<? [char1 char?] [char2 char?] ...) boolean?]{
Like @racket[char<?], but checks whether the arguments would be in
increasing order if each was first case-folded using
@racket[char-foldcase] (which is locale-insensitive).
@mz-examples[(char-ci<? #\A #\a)
(char-ci<? #\a #\b)
(char-ci<? #\a #\b #\c)]}
(char-ci<? #\a #\b #\c)]
@defproc[(char-ci<=? [char1 char?] [char2 char?] ...+) boolean?]{
@history/arity[]}
@defproc[(char-ci<=? [char1 char?] [char2 char?] ...) boolean?]{
@char-sort["nondecreasing" #t]
@mz-examples[(char-ci<=? #\A #\a)
(char-ci<=? #\a #\A)
(char-ci<=? #\a #\b #\b)]}
(char-ci<=? #\a #\b #\b)]
@defproc[(char-ci>? [char1 char?] [char2 char?] ...+) boolean?]{
@history/arity[]}
@defproc[(char-ci>? [char1 char?] [char2 char?] ...) boolean?]{
@char-sort["decreasing" #t]
@mz-examples[(char-ci>? #\A #\a)
(char-ci>? #\b #\A)
(char-ci>? #\c #\b #\a)]}
(char-ci>? #\c #\b #\a)]
@defproc[(char-ci>=? [char1 char?] [char2 char?] ...+) boolean?]{
@history/arity[]}
@defproc[(char-ci>=? [char1 char?] [char2 char?] ...) boolean?]{
@char-sort["nonincreasing" #t]
@mz-examples[(char-ci>=? #\A #\a)
(char-ci>=? #\a #\A)
(char-ci>=? #\c #\b #\b)]}
(char-ci>=? #\c #\b #\b)]
@history/arity[]}
@; ----------------------------------------
@section{Classifications}

6
pkgs/racket-doc/scribblings/reference/data.scrbl
View File

@ -64,12 +64,14 @@ not including the leading @litchar{#:}.}
Returns a keyword whose @racket[display]ed form is the same as that of
@racket[str], but with a leading @litchar{#:}.}
@defproc[(keyword<? [a-keyword keyword?] [b-keyword keyword?] ...+) boolean?]{
@defproc[(keyword<? [a-keyword keyword?] [b-keyword keyword?] ...) boolean?]{
Returns @racket[#t] if the arguments are sorted, where the comparison
for each pair of keywords is the same as using
@racket[keyword->string] with @racket[string->bytes/utf-8] and
@racket[bytes<?].}
@racket[bytes<?].
@history/arity[]}
@; ----------------------------------------------------------------------
@include-section["pairs.scrbl"]

40
pkgs/racket-doc/scribblings/reference/fixnums.scrbl
View File

@ -37,9 +37,9 @@ the @racketmodname[racket/fixnum] library to help debug the problems.
@section{Fixnum Arithmetic}
@deftogether[(
@defproc[(fx+ [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fx- [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fx* [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fx+ [a fixnum?] ...) fixnum?]
@defproc[(fx- [a fixnum?] [b fixnum?] ...) fixnum?]
@defproc[(fx* [a fixnum?] ...) fixnum?]
@defproc[(fxquotient [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fxremainder [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fxmodulo [a fixnum?] [b fixnum?]) fixnum?]
@ -51,13 +51,16 @@ Safe versions of @racket[unsafe-fx+], @racket[unsafe-fx-],
@racket[unsafe-fxremainder], @racket[unsafe-fxmodulo], and
@racket[unsafe-fxabs]. The
@exnraise[exn:fail:contract:non-fixnum-result] if the arithmetic
result would not be a fixnum.}
result would not be a fixnum.
@history[#:changed "7.0.0.13" @elem{Allow zero or more arguments for @racket[fx+] and @racket[fx*]
and one or more arguments for @racket[fx-].}]}
@deftogether[(
@defproc[(fxand [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fxior [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fxxor [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fxand [a fixnum?] ...) fixnum?]
@defproc[(fxior [a fixnum?] ...) fixnum?]
@defproc[(fxxor [a fixnum?] ...) fixnum?]
@defproc[(fxnot [a fixnum?]) fixnum?]
@defproc[(fxlshift [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fxrshift [a fixnum?] [b fixnum?]) fixnum?]
@ -67,22 +70,27 @@ Safe versions of @racket[unsafe-fxand], @racket[unsafe-fxior],
@racket[unsafe-fxxor], @racket[unsafe-fxnot],
@racket[unsafe-fxlshift], and @racket[unsafe-fxrshift]. The
@exnraise[exn:fail:contract:non-fixnum-result] if the arithmetic
result would not be a fixnum.}
result would not be a fixnum.
@history[#:changed "7.0.0.13" @elem{Allow any number of arguments for @racket[fxand], @racket[fxior],
and @racket[fxxor].}]}
@deftogether[(
@defproc[(fx= [a fixnum?] [b fixnum?]) boolean?]
@defproc[(fx< [a fixnum?] [b fixnum?]) boolean?]
@defproc[(fx> [a fixnum?] [b fixnum?]) boolean?]
@defproc[(fx<= [a fixnum?] [b fixnum?]) boolean?]
@defproc[(fx>= [a fixnum?] [b fixnum?]) boolean?]
@defproc[(fxmin [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fxmax [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fx= [a fixnum?] ...) boolean?]
@defproc[(fx< [a fixnum?] ...) boolean?]
@defproc[(fx> [a fixnum?] ...) boolean?]
@defproc[(fx<= [a fixnum?] ...) boolean?]
@defproc[(fx>= [a fixnum?] ...) boolean?]
@defproc[(fxmin [a fixnum?] ...) fixnum?]
@defproc[(fxmax [a fixnum?] ...) fixnum?]
)]{
Safe versions of @racket[unsafe-fx=], @racket[unsafe-fx<],
@racket[unsafe-fx>], @racket[unsafe-fx<=], @racket[unsafe-fx>=],
@racket[unsafe-fxmin], and @racket[unsafe-fxmax].}
@racket[unsafe-fxmin], and @racket[unsafe-fxmax].
@history/arity[]}
@deftogether[(
@defproc[(fx->fl [a fixnum?]) flonum?]

31
pkgs/racket-doc/scribblings/reference/flonums.scrbl
View File

@ -21,30 +21,35 @@ operations like @racket[+].
@section{Flonum Arithmetic}
@deftogether[(
@defproc[(fl+ [a flonum?] [b flonum?]) flonum?]
@defproc[(fl- [a flonum?] [b flonum?]) flonum?]
@defproc[(fl* [a flonum?] [b flonum?]) flonum?]
@defproc[(fl/ [a flonum?] [b flonum?]) flonum?]
@defproc[(fl+ [a flonum?] ...) flonum?]
@defproc[(fl- [a flonum?] [b flonum?] ...) flonum?]
@defproc[(fl* [a flonum?] ...) flonum?]
@defproc[(fl/ [a flonum?] [b flonum?] ...) flonum?]
@defproc[(flabs [a flonum?]) flonum?]
)]{
Like @racket[+], @racket[-], @racket[*], @racket[/], and @racket[abs],
but constrained to consume @tech{flonums}. The result is always a
@tech{flonum}.}
@tech{flonum}.
@history[#:changed "7.0.0.13" @elem{Allow zero or more arguments for @racket[fl+] and @racket[fl*]
and one or more arguments for @racket[fl-] and @racket[fl/].}]}
@deftogether[(
@defproc[(fl= [a flonum?] [b flonum?]) boolean?]
@defproc[(fl< [a flonum?] [b flonum?]) boolean?]
@defproc[(fl> [a flonum?] [b flonum?]) boolean?]
@defproc[(fl<= [a flonum?] [b flonum?]) boolean?]
@defproc[(fl>= [a flonum?] [b flonum?]) boolean?]
@defproc[(flmin [a flonum?] [b flonum?]) flonum?]
@defproc[(flmax [a flonum?] [b flonum?]) flonum?]
@defproc[(fl= [a flonum?] [b flonum?] ...) boolean?]
@defproc[(fl< [a flonum?] [b flonum?] ...) boolean?]
@defproc[(fl> [a flonum?] [b flonum?] ...) boolean?]
@defproc[(fl<= [a flonum?] [b flonum?] ...) boolean?]
@defproc[(fl>= [a flonum?] [b flonum?] ...) boolean?]
@defproc[(flmin [a flonum?] [b flonum?] ...) flonum?]
@defproc[(flmax [a flonum?] [b flonum?] ...) flonum?]
)]{
Like @racket[=], @racket[<], @racket[>], @racket[<=], @racket[>=],
@racket[min], and @racket[max], but constrained to consume
@tech{flonums}.}
@tech{flonums}.
@history/arity[]}
@deftogether[(
@defproc[(flround [a flonum?]) flonum?]

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

@ -151,3 +151,10 @@
" of a " x " is the " x " itself")))
(define (ResultItself x) (esultItself "T" x))
(define (resultItself x) (esultItself "t" x))
;; 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.}
arg ...))

28
pkgs/racket-doc/scribblings/reference/numbers.scrbl
View File

@ -464,42 +464,52 @@ Among the real numbers within @racket[(abs tolerance)] of @racket[x],
@; ----------------------------------------
@subsection{Number Comparison}
@defproc[(= [z number?] [w number?] ...+) boolean?]{ Returns
@defproc[(= [z number?] [w number?] ...) boolean?]{ Returns
@racket[#t] if all of the arguments are numerically equal,
@racket[#f] otherwise. An inexact number is numerically equal to an
exact number when the exact coercion of the inexact number is the
exact number. Also, @racket[0.0] and @racket[-0.0] are numerically
equal, but @racket[+nan.0] is not numerically equal to itself.
@mz-examples[(= 1 1.0) (= 1 2) (= 2+3i 2+3i 2+3i)]}
@mz-examples[(= 1 1.0) (= 1 2) (= 2+3i 2+3i 2+3i) (= 1)]
@history/arity[]}
@defproc[(< [x real?] [y real?] ...+) boolean?]{ Returns @racket[#t] if
@defproc[(< [x real?] [y real?] ...) boolean?]{ Returns @racket[#t] if
the arguments in the given order are strictly increasing,
@racket[#f] otherwise.
@mz-examples[(< 1 1) (< 1 2 3) (< 1 +inf.0) (< 1 +nan.0)]}
@mz-examples[(< 1 1) (< 1 2 3) (< 1) (< 1 +inf.0) (< 1 +nan.0)]
@history/arity[]}
@defproc[(<= [x real?] [y real?] ...+) boolean?]{ Returns @racket[#t]
@defproc[(<= [x real?] [y real?] ...) boolean?]{ Returns @racket[#t]
if the arguments in the given order are non-decreasing,
@racket[#f] otherwise.
@mz-examples[(<= 1 1) (<= 1 2 1)]}
@mz-examples[(<= 1 1) (<= 1 2 1)]
@history/arity[]}
@defproc[(> [x real?] [y real?] ...+) boolean?]{ Returns @racket[#t] if
the arguments in the given order are strictly decreasing,
@racket[#f] otherwise.
@mz-examples[(> 1 1) (> 3 2 1) (> +inf.0 1) (> +nan.0 1)]}
@mz-examples[(> 1 1) (> 3 2 1) (> +inf.0 1) (> +nan.0 1)]
@history/arity[]}
@defproc[(>= [x real?] [y real?] ...+) boolean?]{ Returns @racket[#t]
@defproc[(>= [x real?] [y real?] ...) boolean?]{ Returns @racket[#t]
if the arguments in the given order are non-increasing,
@racket[#f] otherwise.
@mz-examples[(>= 1 1) (>= 1 2 1)]}
@mz-examples[(>= 1 1) (>= 1 2 1)]
@history/arity[]}
@; ------------------------------------------------------------------------

4
pkgs/racket-doc/scribblings/reference/paths.scrbl
View File

@ -214,7 +214,9 @@ reassembling the result with @racket[bytes->path-element] and
Returns @racket[#t] if the arguments are sorted, where the comparison
for each pair of paths is the same as using
@racket[path->bytes] and @racket[bytes<?].}
@racket[path->bytes] and @racket[bytes<?].
@history/arity[]}
@defproc[(path-convention-type [path path-for-some-system?])

94
pkgs/racket-doc/scribblings/reference/strings.scrbl
View File

@ -190,84 +190,104 @@ _i)] is the character produced by @racket[(proc _i)].
@section{String Comparisons}
@defproc[(string=? [str1 string?] [str2 string?] ...+) boolean?]{ Returns
@racket[#t] if all of the arguments are @racket[equal?].}
@defproc[(string=? [str1 string?] [str2 string?] ...) boolean?]{ Returns
@racket[#t] if all of the arguments are @racket[equal?].
@mz-examples[(string=? "Apple" "apple")
(string=? "a" "as" "a")]
@history/arity[]}
@(define (string-sort direction folded?)
(if folded?
@elem{Like @racket[string-ci<?], but checks whether the arguments would be @direction after case-folding.}
@elem{Like @racket[string<?], but checks whether the arguments are @|direction|.}))
@defproc[(string<? [str1 string?] [str2 string?] ...+) boolean?]{
@defproc[(string<? [str1 string?] [str2 string?] ...) boolean?]{
Returns @racket[#t] if the arguments are lexicographically sorted
increasing, where individual characters are ordered by
@racket[char<?], @racket[#f] otherwise.
@mz-examples[(string<? "Apple" "apple")
(string<? "apple" "Apple")
(string<? "a" "b" "c")]}
(string<? "a" "b" "c")]
@defproc[(string<=? [str1 string?] [str2 string?] ...+) boolean?]{
@history/arity[]}
@defproc[(string<=? [str1 string?] [str2 string?] ...) boolean?]{
@string-sort["nondecreasing" #f]
@mz-examples[(string<=? "Apple" "apple")
(string<=? "apple" "Apple")
(string<=? "a" "b" "b")]}
(string<=? "a" "b" "b")]
@defproc[(string>? [str1 string?] [str2 string?] ...+) boolean?]{
@history/arity[]}
@defproc[(string>? [str1 string?] [str2 string?] ...) boolean?]{
@string-sort["decreasing" #f]
@mz-examples[(string>? "Apple" "apple")
(string>? "apple" "Apple")
(string>? "c" "b" "a")]}
(string>? "c" "b" "a")]
@defproc[(string>=? [str1 string?] [str2 string?] ...+) boolean?]{
@history/arity[]}
@defproc[(string>=? [str1 string?] [str2 string?] ...) boolean?]{
@string-sort["nonincreasing" #f]
@mz-examples[(string>=? "Apple" "apple")
(string>=? "apple" "Apple")
(string>=? "c" "b" "b")]}
(string>=? "c" "b" "b")]
@history/arity[]}
@defproc[(string-ci=? [str1 string?] [str2 string?] ...+) boolean?]{
@defproc[(string-ci=? [str1 string?] [str2 string?] ...) boolean?]{
Returns @racket[#t] if all of the arguments are @racket[equal?] after
locale-insensitive case-folding via @racket[string-foldcase].
@mz-examples[(string-ci=? "Apple" "apple")
(string-ci=? "a" "a" "a")]}
(string-ci=? "a" "a" "a")]
@defproc[(string-ci<? [str1 string?] [str2 string?] ...+) boolean?]{
@history/arity[]}
@defproc[(string-ci<? [str1 string?] [str2 string?] ...) boolean?]{
Like @racket[string<?], but checks whether the arguments would be in
increasing order if each was first case-folded using
@racket[string-foldcase] (which is locale-insensitive).
@mz-examples[(string-ci<? "Apple" "apple")
(string-ci<? "apple" "banana")
(string-ci<? "a" "b" "c")]}
(string-ci<? "a" "b" "c")]
@defproc[(string-ci<=? [str1 string?] [str2 string?] ...+) boolean?]{
@history/arity[]}
@defproc[(string-ci<=? [str1 string?] [str2 string?] ...) boolean?]{
@string-sort["nondecreasing" #t]
@mz-examples[(string-ci<=? "Apple" "apple")
(string-ci<=? "apple" "Apple")
(string-ci<=? "a" "b" "b")]}
(string-ci<=? "a" "b" "b")]
@defproc[(string-ci>? [str1 string?] [str2 string?] ...+) boolean?]{
@history/arity[]}
@defproc[(string-ci>? [str1 string?] [str2 string?] ...) boolean?]{
@string-sort["decreasing" #t]
@mz-examples[(string-ci>? "Apple" "apple")
(string-ci>? "banana" "Apple")
(string-ci>? "c" "b" "a")]}
(string-ci>? "c" "b" "a")]
@defproc[(string-ci>=? [str1 string?] [str2 string?] ...+) boolean?]{
@history/arity[]}
@defproc[(string-ci>=? [str1 string?] [str2 string?] ...) boolean?]{
@string-sort["nonincreasing" #t]
@mz-examples[(string-ci>=? "Apple" "apple")
(string-ci>=? "apple" "Apple")
(string-ci>=? "c" "b" "b")]}
(string-ci>=? "c" "b" "b")]
@history/arity[]}
@; ----------------------------------------
@section{String Conversions}
@ -335,34 +355,46 @@ allocated string).}
@; ----------------------------------------
@section{Locale-Specific String Operations}
@defproc[(string-locale=? [str1 string?] [str2 string?] ...+)
@defproc[(string-locale=? [str1 string?] [str2 string?] ...)
boolean?]{ Like @racket[string=?], but the strings are compared in a
locale-specific way, based on the value of @racket[current-locale]. See
@secref["encodings"] for more information on locales.}
@secref["encodings"] for more information on locales.
@history/arity[]}
@defproc[(string-locale<? [str1 string?] [str2 string?] ...+) boolean?]{
Like @racket[string<?], but the sort order compares strings in a
locale-specific way, based on the value of @racket[current-locale]. In
particular, the sort order may not be simply a lexicographic
extension of character ordering.}
extension of character ordering.
@defproc[(string-locale>? [str1 string?] [str2 string?] ...+)
@history/arity[]}
@defproc[(string-locale>? [str1 string?] [str2 string?] ...)
boolean?]{ Like @racket[string>?], but locale-specific like
@racket[string-locale<?].}
@racket[string-locale<?].
@defproc[(string-locale-ci=? [str1 string?] [str2 string?] ...+)
@history/arity[]}
@defproc[(string-locale-ci=? [str1 string?] [str2 string?] ...)
boolean?]{ Like @racket[string-locale=?], but strings are compared
using rules that are both locale-specific and case-insensitive
(depending on what ``case-insensitive'' means for the current
locale).}
locale).
@defproc[(string-locale-ci<? [str1 string?] [str2 string?] ...+)
@history/arity[]}
@defproc[(string-locale-ci<? [str1 string?] [str2 string?] ...)
boolean?]{ Like @racket[string<?], but both locale-sensitive and
case-insensitive like @racket[string-locale-ci=?].}
case-insensitive like @racket[string-locale-ci=?].
@defproc[(string-locale-ci>? [str1 string?] [str2 string?] ...+)
@history/arity[]}
@defproc[(string-locale-ci>? [str1 string?] [str2 string?] ...)
boolean?]{ Like @racket[string>?], but both locale-sensitive and
case-insensitive like @racket[string-locale-ci=?].}
case-insensitive like @racket[string-locale-ci=?].
@history/arity[]}
@defproc[(string-locale-upcase [string string?]) string?]{ Like
@racket[string-upcase], but using locale-specific case-conversion

4
pkgs/racket-doc/scribblings/reference/symbols.scrbl
View File

@ -107,4 +107,6 @@ used as an ephemeron key (see @secref["ephemerons"]).
Returns @racket[#t] if the arguments are sorted, where the comparison
for each pair of symbols is the same as using
@racket[symbol->string] with @racket[string->bytes/utf-8] and
@racket[bytes<?].}
@racket[bytes<?].
@history/arity[]}

42
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -434,10 +434,13 @@
(test #f keyword? 'a)
(test '#:apple string->keyword "apple")
(test "apple" keyword->string '#:apple)
(test #t keyword<? '#:a)
(test #t keyword<? '#:a '#:b)
(test #f keyword<? '#:b '#:b)
(test #t keyword<? '#:b '#:bb)
(test #f keyword<? '#:b '#:)
(test #t keyword<? '#:b '#:c '#:d)
(test #f keyword<? '#:b '#:c '#:c)
(test #t keyword<? (string->keyword "a") (string->keyword "\uA0"))
(test #t keyword<? (string->keyword "a") (string->keyword "\uFF"))
(test #f keyword<? (string->keyword "\uA0") (string->keyword "a"))
@ -447,7 +450,7 @@
(test #f keyword<? (string->keyword "\uA0") (string->keyword "\uA0"))
(arity-test keyword? 1 1)
(arity-test keyword<? 2 -1)
(arity-test keyword<? 1 -1)
(define (char-tests)
(test #t eqv? '#\ #\Space)
@ -482,7 +485,7 @@
(test #t char=? #\370 #\370)
(test #f char=? #\371 #\370)
(test #f char=? #\370 #\371)
(arity-test char=? 2 -1)
(arity-test char=? 1 -1)
(err/rt-test (char=? #\a 1))
(err/rt-test (char=? #\a #\b 1))
(err/rt-test (char=? 1 #\a))
@ -497,7 +500,7 @@
(test #f char<? #\370 #\370)
(test #f char<? #\371 #\370)
(test #t char<? #\370 #\371)
(arity-test char<? 2 -1)
(arity-test char<? 1 -1)
(err/rt-test (char<? #\a 1))
(err/rt-test (char<? #\a #\a 1))
(err/rt-test (char<? 1 #\a))
@ -513,7 +516,7 @@
(test #f char>? #\370 #\370)
(test #t char>? #\371 #\370)
(test #f char>? #\370 #\371)
(arity-test char>? 2 -1)
(arity-test char>? 1 -1)
(err/rt-test (char>? #\a 1))
(err/rt-test (char>? #\a #\a 1))
(err/rt-test (char>? 1 #\a))
@ -529,7 +532,7 @@
(test #t char<=? #\370 #\370)
(test #f char<=? #\371 #\370)
(test #t char<=? #\370 #\371)
(arity-test char<=? 2 -1)
(arity-test char<=? 1 -1)
(err/rt-test (char<=? #\a 1))
(err/rt-test (char<=? #\b #\a 1))
(err/rt-test (char<=? 1 #\a))
@ -541,7 +544,7 @@
(test #t char>=? #\370 #\370)
(test #t char>=? #\371 #\370)
(test #f char>=? #\370 #\371)
(arity-test char>=? 2 -1)
(arity-test char>=? 1 -1)
(err/rt-test (char>=? #\a 1))
(err/rt-test (char>=? #\a #\b 1))
(err/rt-test (char>=? 1 #\a))
@ -558,7 +561,7 @@
(test #t char-ci=? #\370 #\370)
(test #f char-ci=? #\371 #\370)
(test #f char-ci=? #\370 #\371)
(arity-test char-ci=? 2 -1)
(arity-test char-ci=? 1 -1)
(err/rt-test (char-ci=? #\a 1))
(err/rt-test (char-ci=? #\a #\b 1))
(err/rt-test (char-ci=? 1 #\a))
@ -576,7 +579,7 @@
(test #f char-ci<? #\370 #\370)
(test #f char-ci<? #\371 #\370)
(test #t char-ci<? #\370 #\371)
(arity-test char-ci<? 2 -1)
(arity-test char-ci<? 1 -1)
(err/rt-test (char-ci<? #\a 1))
(err/rt-test (char-ci<? #\b #\a 1))
(err/rt-test (char-ci<? 1 #\a))
@ -594,7 +597,7 @@
(test #f char-ci>? #\370 #\370)
(test #t char-ci>? #\371 #\370)
(test #f char-ci>? #\370 #\371)
(arity-test char-ci>? 2 -1)
(arity-test char-ci>? 1 -1)
(err/rt-test (char-ci>? #\a 1))
(err/rt-test (char-ci>? #\a #\b 1))
(err/rt-test (char-ci>? 1 #\a))
@ -611,7 +614,7 @@
(test #t char-ci<=? #\370 #\370)
(test #f char-ci<=? #\371 #\370)
(test #t char-ci<=? #\370 #\371)
(arity-test char-ci<=? 2 -1)
(arity-test char-ci<=? 1 -1)
(err/rt-test (char-ci<=? #\a 1))
(err/rt-test (char-ci<=? #\b #\a 1))
(err/rt-test (char-ci<=? 1 #\a))
@ -628,7 +631,7 @@
(test #t char-ci>=? #\370 #\370)
(test #t char-ci>=? #\371 #\370)
(test #f char-ci>=? #\370 #\371)
(arity-test char-ci>=? 2 -1)
(arity-test char-ci>=? 1 -1)
(err/rt-test (char-ci>=? #\a 1))
(err/rt-test (char-ci>=? #\a #\b 1))
(err/rt-test (char-ci>=? 1 #\a)))
@ -855,6 +858,9 @@
(define ay (string #\a #\nul #\371 #\x))
(define (string-tests)
(test #t string=? "")
(test #t string=? "A")
(test #t string=? "" "")
(test #f string<? "" "")
(test #f string>? "" "")
@ -876,6 +882,7 @@
(test #f string=? ax ay)
(test #f string=? ay ax)
(test #t string<? "A")
(test #t string<? "A" "B")
(test #t string<? "a" "b")
(test #f string<? "9" "0")
@ -886,6 +893,7 @@
(test #t string<? ax ay)
(test #f string<? ay ax)
(test #t string>? "A")
(test #f string>? "A" "B")
(test #f string>? "a" "b")
(test #t string>? "9" "0")
@ -896,6 +904,7 @@
(test #f string>? ax ay)
(test #t string>? ay ax)
(test #t string<=? "A")
(test #t string<=? "A" "B")
(test #t string<=? "a" "b")
(test #f string<=? "9" "0")
@ -906,6 +915,7 @@
(test #t string<=? ax ay)
(test #f string<=? ay ax)
(test #t string>=? "A")
(test #f string>=? "A" "B")
(test #f string>=? "a" "b")
(test #t string>=? "9" "0")
@ -916,6 +926,7 @@
(test #f string>=? ax ay)
(test #t string>=? ay ax)
(test #t string-ci=? "A")
(test #f string-ci=? "A" "B")
(test #f string-ci=? "a" "B")
(test #f string-ci=? "A" "b")
@ -931,6 +942,7 @@
(test #f string-ci=? abigx ay)
(test #f string-ci=? ay abigx)
(test #t string-ci<? "A")
(test #t string-ci<? "A" "B")
(test #t string-ci<? "a" "B")
(test #t string-ci<? "A" "b")
@ -947,6 +959,7 @@
(test #t string-ci<? abigx ay)
(test #f string-ci<? ay abigx)
(test #t string-ci>? "A")
(test #f string-ci>? "A" "B")
(test #f string-ci>? "a" "B")
(test #f string-ci>? "A" "b")
@ -963,6 +976,7 @@
(test #f string-ci>? abigx ay)
(test #t string-ci>? ay abigx)
(test #t string-ci<=? "A")
(test #t string-ci<=? "A" "B")
(test #t string-ci<=? "a" "B")
(test #t string-ci<=? "A" "b")
@ -979,6 +993,7 @@
(test #t string-ci<=? abigx ay)
(test #f string-ci<=? ay abigx)
(test #t string-ci>=? "A")
(test #f string-ci>=? "A" "B")
(test #f string-ci>=? "a" "B")
(test #f string-ci>=? "A" "b")
@ -998,7 +1013,7 @@
(string-tests)
(map (lambda (pred)
(arity-test pred 2 -1)
(arity-test pred 1 -1)
(err/rt-test (pred "a" 1))
(err/rt-test (pred "a" "b" 5))
(err/rt-test (pred 1 "a")))
@ -1019,7 +1034,6 @@
string-locale-ci>?
string-locale-ci<?))
(test #t byte? 10)
(test #t byte? 0)
(test #t byte? 255)
@ -1990,7 +2004,7 @@
(test 1 procedure-arity procedure-arity)
(test 2 procedure-arity cons)
(test (make-arity-at-least 2) procedure-arity >)
(test (make-arity-at-least 1) procedure-arity >)
(test (list 0 1) procedure-arity current-output-port)
(test (list 1 3 (make-arity-at-least 5))
procedure-arity (case-lambda [(x) 0] [(x y z) 1] [(x y z w u . rest) 2]))

51
pkgs/racket-test-core/tests/racket/fixnum.rktl
View File

@ -18,18 +18,8 @@
(list (lambda (v) (fl->fx (exact->inexact x)))
(lambda (v) (unsafe-fl->fx (exact->inexact x))))))
(define binary-table
(list (list fx+ unsafe-fx+)
(list fx- unsafe-fx-)
(list fx* unsafe-fx*)
(list fxquotient unsafe-fxquotient)
(list fxremainder unsafe-fxremainder)
(list fxmodulo unsafe-fxmodulo)
(list fxand unsafe-fxand)
(list fxior unsafe-fxior)
(list fxxor unsafe-fxxor)
(define 1nary-table
(list (list fx- unsafe-fx-)
(list fx>= unsafe-fx>=)
(list fx> unsafe-fx>)
@ -39,14 +29,24 @@
(list fxmin unsafe-fxmin)
(list fxmax unsafe-fxmax)))
(define 0nary-table
(list (list fx+ unsafe-fx+)
(list fx* unsafe-fx*)
(list fxand unsafe-fxand)
(list fxior unsafe-fxior)
(list fxxor unsafe-fxxor)))
(define binary-table
(list (list fxquotient unsafe-fxquotient)
(list fxremainder unsafe-fxremainder)
(list fxmodulo unsafe-fxmodulo)))
(define binary/small-second-arg-table
(list (list fxlshift unsafe-fxlshift)
(list fxrshift unsafe-fxrshift)))
(define nary-table
(list))
(define table (append binary/small-second-arg-table binary-table unary-table nary-table))
(define table (append binary/small-second-arg-table binary-table unary-table 1nary-table 0nary-table))
(define (check-arity fx unsafe-fx)
(let ([same-arities? (λ (x y) (equal? (procedure-arity x)
@ -95,7 +95,8 @@
(for ([line (in-list (append binary/small-second-arg-table
binary-table
nary-table))])
1nary-table
0nary-table))])
(for ([i (in-range (- (expt 2 4)) (expt 2 4))])
(for ([j (in-range (- (expt 2 4)) (expt 2 4))])
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j))))))
@ -108,7 +109,8 @@
(for ([line (in-list (append binary/small-second-arg-table
binary-table
nary-table))])
1nary-table
0nary-table))])
(for ([i (in-list interesting-values)])
(for ([j (in-list interesting-values)])
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))))))
@ -123,14 +125,19 @@
(test #t same-results (list-ref line 0) (list-ref line 1) (list i)))
(for ([line (in-list binary-table)])
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))
(for ([line (in-list 0nary-table)])
(test #t same-results (list-ref line 0) (list-ref line 1) (list))
(test #t same-results (list-ref line 0) (list-ref line 1) (list i))
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))
(for ([line (in-list 1nary-table)])
(test #t same-results (list-ref line 0) (list-ref line 1) (list i))
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))
(for ([line (in-list binary/small-second-arg-table)])
(test #t same-results (list-ref line 0) (list-ref line 1) (list i k)))
(for ([line (in-list nary-table)])
(test #t same-results (list-ref line 0) (list-ref line 1) (list i))
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j))
(for ([line (in-list (append 0nary-table 1nary-table))])
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j k))
(test #t same-results (list-ref line 0) (list-ref line 1) (list i k j))
(test #t same-results (list-ref line 0) (list-ref line 1) more-fixnums)))))
(test #t same-results (list-ref line 0) (list-ref line 1) (cons i more-fixnums))))))
(define (random-fixnum)
(inexact->exact (floor (+ (least-fixnum) (* (random) (+ (- (greatest-fixnum) (least-fixnum)) 1))))))

38
pkgs/racket-test-core/tests/racket/flonum.rktl
View File

@ -3,8 +3,46 @@
(Section 'flonum)
(require racket/flonum
scheme/unsafe/ops
"for-util.rkt")
(define 1nary-table
(list (list fl- unsafe-fl-)
(list fl/ unsafe-fl/)
(list fl>= unsafe-fl>=)
(list fl> unsafe-fl>)
(list fl= unsafe-fl=)
(list fl<= unsafe-fl<=)
(list fl< unsafe-fl<)
(list flmin unsafe-flmin)
(list flmax unsafe-flmax)))
(define 0nary-table
(list (list fl+ unsafe-fl+)
(list fl* unsafe-fl*)))
(let ()
(define (same-results fl unsafe-fl args)
(test (apply fl args) apply unsafe-fl args))
(for ([ignore (in-range 0 800)])
(let ([i (random)]
[j (random)]
[k (random)]
[more-flonums (build-list (random 20) (λ (i) (random)))])
(for ([line (in-list 0nary-table)])
(test #t same-results (list-ref line 0) (list-ref line 1) (list))
(test #t same-results (list-ref line 0) (list-ref line 1) (list i))
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))
(for ([line (in-list 1nary-table)])
(test #t same-results (list-ref line 0) (list-ref line 1) (list i))
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))
(for ([line (in-list (append 0nary-table 1nary-table))])
(test #t same-results (list-ref line 0) (list-ref line 1) (list i j k))
(test #t same-results (list-ref line 0) (list-ref line 1) (list i k j))
(test #t same-results (list-ref line 0) (list-ref line 1) (cons i more-flonums))))))
(define (flonum-close? fl1 fl2)
(<= (flabs (fl- fl1 fl2))
1e-8))

101
pkgs/racket-test-core/tests/racket/jitinline.rktl
View File

@ -173,24 +173,25 @@
;; (printf " for branch...\n")
(test (if v 'yes 'no) name ((eval `(lambda (x y z) (if ,(wrap `(,op x y z)) 'yes 'no))) (get-arg1) arg2 arg3))
(check-effect))))]
[tri (lambda (v op get-arg1 arg2 arg3 check-effect #:wrap [wrap values])
[tri (lambda (v op get-arg1 arg2 arg3 check-effect #:wrap [wrap values] #:exact? [exact? #f])
(define (e->i n) (if (number? n) (exact->inexact n) n))
(tri0 v op get-arg1 arg2 arg3 check-effect #:wrap wrap)
(tri0 (e->i v) op (lambda () (exact->inexact (get-arg1))) (exact->inexact arg2) (exact->inexact arg3) check-effect
#:wrap wrap)
(tri0 (e->i v) op get-arg1 (exact->inexact arg2) arg3 check-effect
#:wrap wrap))]
[tri-if (lambda (v op get-arg1 arg2 arg3 check-effect)
(tri v op get-arg1 arg2 arg3 check-effect)
(unless exact?
(tri0 (e->i v) op (lambda () (exact->inexact (get-arg1))) (exact->inexact arg2) (exact->inexact arg3) check-effect
#:wrap wrap)
(tri0 (e->i v) op get-arg1 (exact->inexact arg2) arg3 check-effect
#:wrap wrap)))]
[tri-if (lambda (v op get-arg1 arg2 arg3 check-effect #:exact? [exact? #f])
(tri v op get-arg1 arg2 arg3 check-effect #:exact? exact?)
(tri (if v 'true 'false) op get-arg1 arg2 arg3 check-effect
#:wrap (lambda (e) `(if ,e 'true 'false))))]
#:wrap (lambda (e) `(if ,e 'true 'false))
#:exact? exact?))]
[tri-exact (lambda (v op get-arg1 arg2 arg3 check-effect 3rd-all-ok?)
(check-error-message op (eval `(lambda (x) (,op x ,arg2 ,arg3))))
(check-error-message op (eval `(lambda (x) (,op (,get-arg1) x ,arg3))))
(unless 3rd-all-ok?
(check-error-message op (eval `(lambda (x) (,op (,get-arg1) ,arg2 x)))))
(tri0 v op get-arg1 arg2 arg3 check-effect))])
(un #f 'null? 0)
(un-exact #t 'null? '())
@ -341,6 +342,7 @@
(un #t 'k:true-object? #t)
(un #f 'k:true-object? 10)
(un #t '< 100)
(bin #t '< 100 200)
(bin #f '< 200 100)
(bin #f '< 100 100)
@ -350,13 +352,23 @@
(tri-if #t '< (lambda () 1) 2 3 void)
(tri-if #f '< (lambda () 1) 3 3 void)
(tri-if #f '< (lambda () 1) -1 3 void)
(un-exact #t 'fx< 100)
(bin-exact #t 'fx< 100 200)
(bin-exact #f 'fx< 200 100)
(bin-exact #f 'fx< 200 200)
(tri-if #t 'fx< (lambda () 10) 20 30 void #:exact? #t)
(tri-if #f 'fx< (lambda () 10) 30 30 void #:exact? #t)
(tri-if #f 'fx< (lambda () 10) -10 30 void #:exact? #t)
(un-exact #t 'fl< 100.0)
(un-exact #t 'fl< 100.0 #t)
(bin-exact #t 'fl< 100.0 200.0 #t)
(bin-exact #f 'fl< 200.0 100.0)
(bin-exact #f 'fl< 200.0 200.0)
(tri-if #t 'fl< (lambda () 10.5) 20.5 30.5 void #:exact? #t)
(tri-if #f 'fl< (lambda () 10.5) 30.5 30.5 void #:exact? #t)
(tri-if #f 'fl< (lambda () 10.5) -10.5 30.5 void #:exact? #t)
(un #t '<= 100)
(bin #t '<= 100 200)
(bin #f '<= 200 100)
(bin #t '<= 100 100)
@ -365,13 +377,23 @@
(tri-if #t '<= (lambda () 1) 2 3 void)
(tri-if #t '<= (lambda () 1) 3 3 void)
(tri-if #f '<= (lambda () 1) -1 3 void)
(un-exact #t 'fx<= 100)
(bin-exact #t 'fx<= 100 200)
(bin-exact #f 'fx<= 200 100)
(bin-exact #t 'fx<= 200 200)
(tri-if #t 'fx<= (lambda () 10) 20 30 void #:exact? #t)
(tri-if #t 'fx<= (lambda () 10) 30 30 void #:exact? #t)
(tri-if #f 'fx<= (lambda () 10) -10 30 void #:exact? #t)
(un-exact #t 'fl<= 100.0)
(un-exact #t 'fl<= 100.0 #t)
(bin-exact #t 'fl<= 100.0 200.0 #t)
(bin-exact #f 'fl<= 200.0 100.0)
(bin-exact #t 'fl<= 200.0 200.0)
(tri-if #t 'fl<= (lambda () 10.5) 20.5 30.5 void #:exact? #t)
(tri-if #t 'fl<= (lambda () 10.5) 30.5 30.5 void #:exact? #t)
(tri-if #f 'fl<= (lambda () 10.5) -10.5 30.5 void #:exact? #t)
(un #t '> 100)
(bin #f '> 100 200)
(bin #t '> 200 100)
(bin #f '> 100 100)
@ -381,13 +403,23 @@
(tri-if #t '> (lambda () 3) 2 1 void)
(tri-if #f '> (lambda () 3) 3 1 void)
(tri-if #f '> (lambda () 3) -1 1 void)
(un-exact #t 'fx> 100)
(bin-exact #f 'fx> 100 200)
(bin-exact #t 'fx> 200 100)
(bin-exact #f 'fx> 200 200)
(tri-if #t 'fx> (lambda () 30) 20 10 void #:exact? #t)
(tri-if #f 'fx> (lambda () 30) 30 10 void #:exact? #t)
(tri-if #f 'fx> (lambda () 30) -10 10 void #:exact? #t)
(un-exact #t 'fl> 100.0)
(un-exact #t 'fl> 100.0 #t)
(bin-exact #f 'fl> 100.0 200.0 #t)
(bin-exact #t 'fl> 200.0 100.0)
(bin-exact #f 'fl> 200.0 200.0)
(tri-if #t 'fl> (lambda () 30.5) 20.5 10.5 void #:exact? #t)
(tri-if #f 'fl> (lambda () 30.5) 30.5 10.5 void #:exact? #t)
(tri-if #f 'fl> (lambda () 30.5) -10.5 10.5 void #:exact? #t)
(un #t '>= 100)
(bin #f '>= 100 200)
(bin #t '>= 200 100)
(bin #t '>= 100 100)
@ -396,13 +428,23 @@
(tri-if #t '>= (lambda () 3) 2 1 void)
(tri-if #t '>= (lambda () 3) 3 1 void)
(tri-if #f '>= (lambda () 3) -1 1 void)
(un-exact #t 'fx>= 100)
(bin-exact #f 'fx>= 100 200)
(bin-exact #t 'fx>= 200 100)
(bin-exact #t 'fx>= 200 200)
(tri-if #t 'fx>= (lambda () 30) 20 10 void #:exact? #t)
(tri-if #t 'fx>= (lambda () 30) 30 10 void #:exact? #t)
(tri-if #f 'fx>= (lambda () 30) -10 10 void #:exact? #t)
(un-exact #t 'fl>= 100.0)
(un-exact #t 'fl>= 100.0 #t)
(bin-exact #f 'fl>= 100.0 200.0 #t)
(bin-exact #t 'fl>= 200.0 100.0)
(bin-exact #t 'fl>= 200.0 200.0)
(tri-if #t 'fl>= (lambda () 30.5) 20.5 10.5 void #:exact? #t)
(tri-if #t 'fl>= (lambda () 30.5) 30.5 10.5 void #:exact? #t)
(tri-if #f 'fl>= (lambda () 30.5) -10.5 10.5 void #:exact? #t)
(un #t '= 100)
(bin #f '= 100 200)
(bin #f '= 200 100)
(bin #t '= 100 100)
@ -412,10 +454,21 @@
(tri-if #f '= (lambda () 3) 3 1 void)
(tri-if #f '= (lambda () 3) 1 3 void)
(tri-if #f '= (lambda () 1) 3 3 void)
(un-exact #t 'fx= 100)
(bin-exact #f 'fx= 100 200)
(bin-exact #t 'fx= 200 200)
(tri-if #t 'fx= (lambda () 30) 30 30 void #:exact? #t)
(tri-if #f 'fx= (lambda () 30) 30 10 void #:exact? #t)
(tri-if #f 'fx= (lambda () 30) 10 30 void #:exact? #t)
(tri-if #f 'fx= (lambda () 10) 30 30 void #:exact? #t)
(un-exact #t 'fl= 100.0)
(un-exact #t 'fl= 100.0 #t)
(bin-exact #f 'fl= 100.0 200.0 #t)
(bin-exact #t 'fl= 200.0 200.0)
(tri-if #t 'fl= (lambda () 30.5) 30.5 30.5 void #:exact? #t)
(tri-if #f 'fl= (lambda () 30.5) 30.5 10.5 void #:exact? #t)
(tri-if #f 'fl= (lambda () 30.5) 10.5 30.5 void #:exact? #t)
(tri-if #f 'fl= (lambda () 10.5) 30.5 30.5 void #:exact? #t)
(un 3 'add1 2)
(un -3 'add1 -4)
@ -439,6 +492,7 @@
(un (expt 2 30) 'abs (- (expt 2 30)))
(un (sub1 (expt 2 62)) 'abs (sub1 (expt 2 62)))
(un (expt 2 62) 'abs (- (expt 2 62)))
(un-exact 3 'fxabs -3)
(un-exact 3.0 'flabs -3.0 #t)
(un-exact 3.0 'flsqrt 9.0 #t)
@ -495,6 +549,7 @@
(un-exact 11 'fl->fx 11.0 #t)
(un-exact -11 'fl->fx -11.0)
(un 4 '+ 4)
(bin 11 '+ 4 7)
(bin -3 '+ 4 -7)
(bin (expt 2 30) '+ (expt 2 29) (expt 2 29))
@ -502,8 +557,11 @@
(tri 6 '+ (lambda () 1) 2 3 void)
(tri 13/2 '+ (lambda () 1) 5/2 3 void)
(bin-exact 25 'fx+ 10 15)
(tri-exact 33 'fx+ (lambda () 10) 15 8 void #f)
(bin-exact 3.4 'fl+ 1.1 2.3 #t)
(tri-exact 7.4 'fl+ (lambda () 1.1) 2.3 4.0 void #f)
(un -3 '- 3)
(bin 3 '- 7 4)
(bin 11 '- 7 -4)
(bin 0 '- (expt 2 29) (expt 2 29))
@ -512,9 +570,14 @@
(bin (- 2 (expt 2 31)) '- (- 1 (expt 2 30)) (sub1 (expt 2 30)))
(tri 6 '- (lambda () 10) 3 1 void)
(tri 13/2 '- (lambda () 10) 3 1/2 void)
(un-exact -3 'fx- 3)
(bin-exact 13 'fx- 5 -8)
(tri-exact 14 'fx- (lambda () 5) -8 -1 void #f)
(un-exact -3.6 'fl- 3.6)
(bin-exact -0.75 'fl- 1.5 2.25 #t)
(tri-exact -1.5 'fl- (lambda () 1.5) 2.25 0.75 void #f)
(un 4 '* 4)
(bin 4 '* 1 4)
(bin 0 '* 0 4)
(bin 12 '* 3 4)
@ -527,9 +590,13 @@
(bin (- (expt 2 30)) '* 2 (- (expt 2 29)))
(tri 30 '* (lambda () 2) 3 5 void)
(tri 5 '* (lambda () 2) 3 5/6 void)
(un-exact 11 'fx* 11)
(bin-exact 253 'fx* 11 23)
(bin-exact 2.53 'fl* 1.1 2.3 #t)
(tri-exact 506 'fx* (lambda () 11) 23 2 void #f)
(tri-exact 7.59 'fl* (lambda () 1.1) 2.3 3.0 void #f)
(un 1/4 '/ 4)
(bin 0 '/ 0 4)
(bin 1/4 '/ 1 4)
(bin 4 '/ 4 1)
@ -539,7 +606,9 @@
(bin 4 '/ -16 -4)
(tri 3 '/ (lambda () 30) 5 2 void)
(tri 12 '/ (lambda () 30) 5 1/2 void)
(un-exact 0.25 'fl/ 4.0)
(bin-exact (/ 1.1 2.3) 'fl/ 1.1 2.3 #t)
(tri-exact (/ 1.1 2.3 0.5) 'fl/ (lambda () 1.1) 2.3 0.5 void #f)
(bin 4/3 '/ 4 3)
(bin -4/3 '/ 4 -3)
(bin -4/3 '/ -4 3)
@ -577,16 +646,19 @@
(bin-exact -1 'fxmodulo -10 -3)
(bin-exact 2 'fxmodulo -10 3)
(un 3 'min 3)
(bin 3 'min 3 300)
(bin -300 'min 3 -300)
(bin -400 'min -400 -300)
(tri 5 'min (lambda () 10) 5 20 void)
(tri 5 'min (lambda () 5) 10 20 void)
(tri 5 'min (lambda () 20) 10 5 void)
(un-exact 3.0 'flmin 3.0 #t)
(bin-exact 3.0 'flmin 3.0 4.5 #t)
(bin-exact 2.5 'flmin 3.0 2.5)
(bin0 3.5 '(lambda (x y) (fl+ 1.0 (flmin x y))) 3.0 2.5)
(bin0 4.0 '(lambda (x y) (fl+ 1.0 (flmin x y))) 3.0 4.5)
(un-exact 30 'fxmin 30)
(bin-exact 30 'fxmin 30 45)
(bin-exact 25 'fxmin 30 25)
@ -596,10 +668,12 @@
(tri 50 'max (lambda () 10) 50 20 void)
(tri 50 'max (lambda () 50) 10 20 void)
(tri 50 'max (lambda () 20) 10 50 void)
(un-exact 4.5 'flmax 4.5 #t)
(bin-exact 4.5 'flmax 3.0 4.5 #t)
(bin-exact 3.0 'flmax 3.0 2.5)
(bin0 5.5 '(lambda (x y) (fl+ 1.0 (flmax x y))) 3.0 4.5)
(bin0 4.0 '(lambda (x y) (fl+ 1.0 (flmax x y))) 3.0 2.5)
(un-exact 30 'fxmax 30)
(bin-exact 45 'fxmax 30 45)
(bin-exact 30 'fxmax 30 25)
@ -611,23 +685,31 @@
(bin-exact -11 'bitwise-and -11 -1)
(bin-exact (expt 2 50) 'bitwise-and (expt 2 50) (expt 2 50))
(tri-exact #x10101 'bitwise-and (lambda () #x11111) #x10111 #x110101 void #f)
(un-exact 11 'fxand 11)
(bin-exact 11 'fxand 11 43)
(tri-exact 11 'fxand (lambda () 11) 43 75 void #f)
(un-exact 8 'bitwise-ior 8)
(bin-exact 11 'bitwise-ior 8 3)
(bin-exact 11 'bitwise-ior 11 3)
(bin-exact -1 'bitwise-ior 11 -1)
(bin-exact (sub1 (expt 2 51)) 'bitwise-ior (sub1 (expt 2 50)) (expt 2 50))
(bin-exact (add1 (expt 2 50)) 'bitwise-ior 1 (expt 2 50))
(tri-exact #x10101 'bitwise-ior (lambda () #x1) #x100 #x10000 void #f)
(un-exact 8 'fxior 8)
(bin-exact 11 'fxior 8 3)
(tri-exact 11 'fxior (lambda () 8) 3 1 void #f)
(un-exact 8 'bitwise-xor 8)
(bin-exact 11 'bitwise-xor 8 3)
(bin-exact 8 'bitwise-xor 11 3)
(bin-exact -2 'bitwise-xor 1 -1)
(bin-exact (sub1 (expt 2 51)) 'bitwise-xor (sub1 (expt 2 50)) (expt 2 50))
(bin-exact (add1 (expt 2 50)) 'bitwise-xor 1 (expt 2 50))
(tri-exact #x10101 'bitwise-xor (lambda () #x1) #x110 #x10010 void #f)
(un-exact 8 'fxxor 8)
(bin-exact 11 'fxxor 8 3)
(tri-exact 10 'fxxor (lambda () 8) 3 1 void #f)
(bin-exact 4 'arithmetic-shift 2 1)
(bin-exact 1 'arithmetic-shift 2 -1)
@ -684,6 +766,7 @@
(bin-exact 1 'make-rectangular 1 0)
(bin-exact 1.0 'make-rectangular 1.0 0)
(un-exact #t 'char=? #\a)
(bin-exact #t 'char=? #\a #\a)
(bin-exact #t 'char=? #\u1034 #\u1034)
(bin-exact #f 'char=? #\a #\b)

16
pkgs/racket-test-core/tests/racket/number.rktl
View File

@ -234,6 +234,12 @@
(test-lh m hi)
(test-hl -m -hi)
(test #t > m)
(test #t < m)
(test #t = m)
(test #t >= m)
(test #t <= m)
(test #f > m m)
(test #f < m m)
(test #t = m m)
@ -401,11 +407,11 @@
(err/rt-test (<= 0.5+0.1i 1))
(err/rt-test (<= 1 0.5+0.1i))
(arity-test = 2 -1)
(arity-test < 2 -1)
(arity-test > 2 -1)
(arity-test <= 2 -1)
(arity-test >= 2 -1)
(arity-test = 1 -1)
(arity-test < 1 -1)
(arity-test > 1 -1)
(arity-test <= 1 -1)
(arity-test >= 1 -1)
(test #t zero? 0)
(test #t zero? 0.0)

14
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -3877,12 +3877,12 @@
(when needs-two-args?
(test-comp `(lambda (x)
(if (real? x)
(let ([tmp (= x)])
(let ([tmp (,op x)])
'whatever)
(error "bad")))
`(lambda (x)
(if (real? x)
(= x)
(,op x)
(error "bad")))))))
(check-real-op 'quotient #f #f)
@ -3890,11 +3890,11 @@
(check-real-op 'modulo #f #f)
(check-real-op 'max)
(check-real-op 'min)
(check-real-op '= #:needs-two-args? #t #:implies-real? #f)
(check-real-op '< #:needs-two-args? #t)
(check-real-op '> #:needs-two-args? #t)
(check-real-op '<= #:needs-two-args? #t)
(check-real-op '>= #:needs-two-args? #t)
(check-real-op '= #:implies-real? #f)
(check-real-op '<)
(check-real-op '>)
(check-real-op '<=)
(check-real-op '>=)
(define (check-number-op op [closed-under-reals? #t])
(test-comp `(lambda (x y)

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

@ -9,13 +9,18 @@
ffi/vector
racket/extflonum)
(let ()
(let* ([identity (lambda (x) x)]
[compose (lambda (f g)
(if (eq? f identity)
g
(compose f g)))])
(define ((add-star str) sym)
(string->symbol (regexp-replace str (symbol->string sym) (string-append str "*"))))
(define (test-tri result proc x y z
#:pre [pre void]
#:post [post (lambda (x) x)]
#:literal-ok? [lit-ok? #t])
#:post [post identity]
#:literal-ok? [lit-ok? #t]
#:branch? [branch? #f])
(pre)
(test result (compose post (eval proc)) x y z)
(pre)
@ -36,11 +41,29 @@
(pre)
(test result (compose post (eval `(lambda (z) (,proc ,x ,y z)))) z)
(pre)
(test result (compose post (eval `(lambda () (,proc ,x ,y ,z)))))))
(test result (compose post (eval `(lambda () (,proc ,x ,y ,z))))))
(when branch?
(pre)
(test (if result 'yes 'no) (compose post (eval `(lambda (x y z) (if (,proc x y z) 'yes 'no)))) x y z)
(when lit-ok?
(pre)
(test (if result 'yes 'no) (compose post (eval `(lambda (y z) (if (,proc ,x y z) 'yes 'no)))) y z))
(pre)
(test (if result 'yes 'no) (compose post (eval `(lambda (x z) (if (,proc x ,y z) 'yes 'no)))) x z)
(pre)
(test (if result 'yes 'no) (compose post (eval `(lambda (x y) (if (,proc x y ,z) 'yes 'no)))) x y)
(when lit-ok?
(pre)
(test (if result 'yes 'no) (compose post (eval `(lambda (z) (if (,proc ,x ,y z) 'yes 'no)))) z)
(pre)
(test (if result 'yes 'no) (compose post (eval `(lambda (y) (if (,proc ,x y ,z) 'yes 'no)))) y))
(pre)
(test (if result 'yes 'no) (compose post (eval `(lambda (x) (if (,proc x ,y ,z) 'yes 'no)))) x)))
(define (test-bin result proc x y
#:pre [pre void]
#:post [post (lambda (x) x)]
#:literal-ok? [lit-ok? #t])
#:post [post identity]
#:literal-ok? [lit-ok? #t]
#:branch? [branch? #f])
(pre)
(test result (compose post (eval proc)) x y)
(pre)
@ -51,26 +74,54 @@
(pre)
(test result (compose post (eval `(lambda () (,proc ',x ',y))))))
(pre)
(test result (compose post (eval `(lambda (x) (,proc x ',y)))) x))
(test result (compose post (eval `(lambda (x) (,proc x ',y)))) x)
(when branch?
(pre)
(test (if result 'yep 'nope) (compose post (eval `(lambda (x y) (if (,proc x y) 'yep 'nope)))) x y)
(when lit-ok?
(pre)
(test (if result 'yep 'nope) (compose post (eval `(lambda (y) (if (,proc ,x y) 'yep 'nope)))) y))
(pre)
(test (if result 'yep 'nope) (compose post (eval `(lambda (x) (if (,proc x ,y) 'yep 'nope)))) x)))
(define (test-un result proc x
#:pre [pre void]
#:post [post (lambda (x) x)])
#:post [post identity]
#:branch? [branch? #f])
(pre)
(test result (compose post (eval proc)) x)
(pre)
(test result (compose post (eval `(lambda (x) (,proc x)))) x)
(pre)
(test result (compose post (eval `(lambda () (,proc ',x))))))
(test result (compose post (eval `(lambda () (,proc ',x)))))
(when branch?
(pre)
(test (if result 'y 'n) (compose post (eval `(lambda (x) (if (,proc x) 'y 'n)))) x)
(pre)
(test (if result 'y 'n) (compose post (eval `(lambda () (if (,proc ',x) 'y 'n)))))))
(define (test-zero result proc
#:pre [pre void]
#:post [post identity])
(pre)
(test result (compose post (eval proc)))
(pre)
(test result (compose post (eval `(lambda () (,proc))))))
(test-zero 0 'unsafe-fx+)
(test-un 7 'unsafe-fx+ 7)
(test-bin 3 'unsafe-fx+ 1 2)
(test-bin -1 'unsafe-fx+ 1 -2)
(test-bin 12 'unsafe-fx+ 12 0)
(test-bin -12 'unsafe-fx+ 0 -12)
(test-tri 72 'unsafe-fx+ 12 23 37)
(test-un -10 'unsafe-fx- 10)
(test-bin 8 'unsafe-fx- 10 2)
(test-bin 3 'unsafe-fx- 1 -2)
(test-bin 13 'unsafe-fx- 13 0)
(test-tri 2 'unsafe-fx- 37 12 23)
(test-zero 1 'unsafe-fx*)
(test-un 17 'unsafe-fx* 17)
(test-bin 20 'unsafe-fx* 10 2)
(test-bin -20 'unsafe-fx* 10 -2)
(test-bin -2 'unsafe-fx* 1 -2)
@ -79,6 +130,7 @@
(test-bin 0 'unsafe-fx* -21 0)
(err/rt-test (unsafe-fx* 0 (error "bad")) exn:fail?) ; not 0
(err/rt-test (unsafe-fx* (error "bad") 0) exn:fail?) ; not 0
(test-tri 60 'unsafe-fx* 3 4 5)
(test-bin 3 'unsafe-fxquotient 17 5)
(test-bin -3 'unsafe-fxquotient 17 -5)
@ -99,6 +151,8 @@
(err/rt-test (unsafe-fxmodulo (error "bad") 1) exn:fail?) ; not 0
(err/rt-test (unsafe-fxmodulo 0 (error "bad")) exn:fail?) ; not 0
(test-zero 0.0 'unsafe-fl+)
(test-un 6.7 'unsafe-fl+ 6.7)
(test-bin 3.4 'unsafe-fl+ 1.4 2.0)
(test-bin -1.1 'unsafe-fl+ 1.0 -2.1)
(test-bin +inf.0 'unsafe-fl+ 1.0 +inf.0)
@ -106,47 +160,85 @@
(test-bin +nan.0 'unsafe-fl+ +nan.0 -inf.0)
(test-bin 1.5 'unsafe-fl+ 1.5 0.0)
(test-bin 1.7 'unsafe-fl+ 0.0 1.7)
(test-tri 1.25 'unsafe-fl* 1.0 2.5 0.5)
(test-bin #f unsafe-fx= 1 2)
(test-bin #t unsafe-fx= 2 2)
(test-bin #f unsafe-fx= 2 1)
(test-un #t unsafe-fx= 1 #:branch? #t)
(test-bin #f unsafe-fx= 1 2 #:branch? #t)
(test-bin #t unsafe-fx= 2 2 #:branch? #t)
(test-bin #f unsafe-fx= 2 1 #:branch? #t)
(test-tri #t unsafe-fx= 2 2 2 #:branch? #t)
(test-tri #f unsafe-fx= 1 2 2 #:branch? #t)
(test-tri #f unsafe-fx= 2 1 2 #:branch? #t)
(test-tri #f unsafe-fx= 2 2 1 #:branch? #t)
(test-bin #t unsafe-fx< 1 2)
(test-bin #f unsafe-fx< 2 2)
(test-bin #f unsafe-fx< 2 1)
(test-un #t unsafe-fx< 1 #:branch? #t)
(test-bin #t unsafe-fx< 1 2 #:branch? #t)
(test-bin #f unsafe-fx< 2 2 #:branch? #t)
(test-bin #f unsafe-fx< 2 1 #:branch? #t)
(test-tri #t unsafe-fx< 1 2 3 #:branch? #t)
(test-tri #f unsafe-fx< 2 2 3 #:branch? #t)
(test-tri #f unsafe-fx< 1 2 2 #:branch? #t)
(test-bin #f unsafe-fx> 1 2)
(test-bin #f unsafe-fx> 2 2)
(test-bin #t unsafe-fx> 2 1)
(test-un #t unsafe-fx> 1 #:branch? #t)
(test-bin #f unsafe-fx> 1 2 #:branch? #t)
(test-bin #f unsafe-fx> 2 2 #:branch? #t)
(test-bin #t unsafe-fx> 2 1 #:branch? #t)
(test-tri #t unsafe-fx> 2 1 0 #:branch? #t)
(test-tri #f unsafe-fx> 2 2 0 #:branch? #t)
(test-tri #f unsafe-fx> 2 1 1 #:branch? #t)
(test-bin #t unsafe-fx<= 1 2)
(test-bin #t unsafe-fx<= 2 2)
(test-bin #f unsafe-fx<= 2 1)
(test-un #t unsafe-fx<= 1 #:branch? #t)
(test-bin #t unsafe-fx<= 1 2 #:branch? #t)
(test-bin #t unsafe-fx<= 2 2 #:branch? #t)
(test-bin #f unsafe-fx<= 2 1 #:branch? #t)
(test-tri #t unsafe-fx<= 1 1 1 #:branch? #t)
(test-tri #t unsafe-fx<= 1 2 3 #:branch? #t)
(test-tri #f unsafe-fx<= 3 2 3 #:branch? #t)
(test-tri #f unsafe-fx<= 1 2 1 #:branch? #t)
(test-bin #f unsafe-fx>= 1 2)
(test-bin #t unsafe-fx>= 2 2)
(test-bin #t unsafe-fx>= 2 1)
(test-un #t unsafe-fx>= 1 #:branch? #t)
(test-bin #f unsafe-fx>= 1 2 #:branch? #t)
(test-bin #t unsafe-fx>= 2 2 #:branch? #t)
(test-bin #t unsafe-fx>= 2 1 #:branch? #t)
(test-tri #t unsafe-fx>= 3 2 1 #:branch? #t)
(test-tri #t unsafe-fx>= 3 3 3 #:branch? #t)
(test-tri #f unsafe-fx>= 3 4 1 #:branch? #t)
(test-tri #f unsafe-fx>= 3 2 3 #:branch? #t)
(test-un 3 unsafe-fxmin 3)
(test-bin 3 unsafe-fxmin 3 30)
(test-bin -30 unsafe-fxmin 3 -30)
(test-tri 3 unsafe-fxmin 3 7 8)
(test-tri -1 unsafe-fxmin 3 -1 8)
(test-tri -8 unsafe-fxmin 3 7 -8)
(test-un 30 unsafe-fxmax 30)
(test-bin 30 unsafe-fxmax 3 30)
(test-bin 3 unsafe-fxmax 3 -30)
(test-tri 3 unsafe-fxmax 3 -30 -90)
(test-tri 30 unsafe-fxmax 3 30 -90)
(test-tri 90 unsafe-fxmax 3 30 90)
(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)
(test-bin 1.5 'unsafe-fl- 1.5 0.0)
(test-tri 0.75 'unsafe-fl- 1.5 0.5 0.25)
(test-zero 1.0 'unsafe-fl*)
(test-un 4.5 'unsafe-fl* 4.5)
(test-bin 20.02 'unsafe-fl* 10.01 2.0)
(test-bin -20.02 'unsafe-fl* 10.01 -2.0)
(test-bin +nan.0 'unsafe-fl* +inf.0 0.0)
(test-bin 1.8 'unsafe-fl* 1.0 1.8)
(test-bin 1.81 'unsafe-fl* 1.81 1.0)
(test-un 0.125 'unsafe-fl/ 8.0)
(test-bin (exact->inexact 17/5) 'unsafe-fl/ 17.0 5.0)
(test-bin +inf.0 'unsafe-fl/ 17.0 0.0)
(test-bin -inf.0 'unsafe-fl/ -17.0 0.0)
(test-bin 1.5 'unsafe-fl/ 1.5 1.0)
(test-tri 1.0 'unsafe-fl/ 8.0 2.0 4.0)
(when (extflonum-available?)
(test-bin 3.4t0 'unsafe-extfl+ 1.4t0 2.0t0)
@ -196,17 +288,26 @@
(test-bin +nan.t 'unsafe-extflmax +nan.t 2.1t0)
(test-bin +nan.t 'unsafe-extflmax 2.1t0 +nan.t))
(test-zero -1 'unsafe-fxand)
(test-un 10 'unsafe-fxand 10)
(test-bin 3 'unsafe-fxand 7 3)
(test-bin 2 'unsafe-fxand 6 3)
(test-bin 3 'unsafe-fxand -1 3)
(test-tri 1 'unsafe-fxand -1 3 17)
(test-zero 0 'unsafe-fxior)
(test-un 10 'unsafe-fxior 10)
(test-bin 7 'unsafe-fxior 7 3)
(test-bin 7 'unsafe-fxior 6 3)
(test-bin -1 'unsafe-fxior -1 3)
(test-tri 19 'unsafe-fxior 2 3 17)
(test-zero 0 'unsafe-fxxor)
(test-un 10 'unsafe-fxxor 10)
(test-bin 4 'unsafe-fxxor 7 3)
(test-bin 5 'unsafe-fxxor 6 3)
(test-bin -4 'unsafe-fxxor -1 3)
(test-tri 16 'unsafe-fxxor 2 3 17)
(test-un -1 'unsafe-fxnot 0)
(test-un -4 'unsafe-fxnot 3)
@ -236,14 +337,100 @@
(test-un 8 'unsafe-fl->fx 8.0)
(test-un -8 'unsafe-fl->fx -8.0)
(test-zero 0.0 'unsafe-fl+)
(test-un 7.0 'unsafe-fl+ 7.0)
(test-bin 3.0 'unsafe-fl+ 1.0 2.0)
(test-bin -1.0 'unsafe-fl+ 1.0 -2.0)
(test-bin 12.0 'unsafe-fl+ 12.0 0.0)
(test-bin -12.0 'unsafe-fl+ 0.0 -12.0)
(test-tri 72.0 'unsafe-fl+ 12.0 23.0 37.0)
(test-un -10.0 'unsafe-fl- 10.0)
(test-bin 8.0 'unsafe-fl- 10.0 2.0)
(test-bin 3.0 'unsafe-fl- 1.0 -2.0)
(test-bin 13.0 'unsafe-fl- 13.0 0.0)
(test-tri 2.0 'unsafe-fl- 37.0 12.0 23.0)
(test-zero 1.0 'unsafe-fl*)
(test-un 17.0 'unsafe-fl* 17.0)
(test-bin 20.0 'unsafe-fl* 10.0 2.0)
(test-bin -20.0 'unsafe-fl* 10.0 -2.0)
(test-bin -2.0 'unsafe-fl* 1.0 -2.0)
(test-bin -21.0 'unsafe-fl* -21.0 1.0)
(test-bin -0.0 'unsafe-fl* 0.0 -2.0)
(test-bin -0.0 'unsafe-fl* -21.0 0.0)
(test-tri 60.0 'unsafe-fl* 3.0 4.0 5.0)
(test-tri +nan.0 'unsafe-fl* 3.0 +nan.0 5.0)
(test-un 0.25 'unsafe-fl/ 4.0)
(test-bin 5.0 'unsafe-fl/ 10.0 2.0)
(test-bin -5.0 'unsafe-fl/ 10.0 -2.0)
(test-bin -0.5 'unsafe-fl/ 1.0 -2.0)
(test-bin -21.0 'unsafe-fl/ -21.0 1.0)
(test-bin -0.0 'unsafe-fl/ 0.0 -2.0)
(test-bin -inf.0 'unsafe-fl/ -21.0 0.0)
(test-tri (/ 3.0 20.0) 'unsafe-fl/ 3.0 4.0 5.0)
(test-tri +nan.0 'unsafe-fl/ 3.0 +nan.0 5.0)
(test-un #t unsafe-fl= 1.0 #:branch? #t)
(test-bin #f unsafe-fl= 1.0 2.0 #:branch? #t)
(test-bin #t unsafe-fl= 2.0 2.0 #:branch? #t)
(test-bin #f unsafe-fl= 2.0 1.0 #:branch? #t)
(test-tri #t unsafe-fl= 2.0 2.0 2.0 #:branch? #t)
(test-tri #f unsafe-fl= 1.0 2.0 2.0 #:branch? #t)
(test-tri #f unsafe-fl= 2.0 1.0 2.0 #:branch? #t)
(test-tri #f unsafe-fl= 2.0 2.0 1.0 #:branch? #t)
(test-un #t unsafe-fl< 1.0 #:branch? #t)
(test-bin #t unsafe-fl< 1.0 2.0 #:branch? #t)
(test-bin #f unsafe-fl< 2.0 2.0 #:branch? #t)
(test-bin #f unsafe-fl< 2.0 1.0 #:branch? #t)
(test-tri #t unsafe-fl< 1.0 2.0 3.0 #:branch? #t)
(test-tri #f unsafe-fl< 2.0 2.0 3.0 #:branch? #t)
(test-tri #f unsafe-fl< 1.0 2.0 2.0 #:branch? #t)
(test-un #t unsafe-fl> 1.0 #:branch? #t)
(test-bin #f unsafe-fl> 1.0 2.0 #:branch? #t)
(test-bin #f unsafe-fl> 2.0 2.0 #:branch? #t)
(test-bin #t unsafe-fl> 2.0 1.0 #:branch? #t)
(test-tri #t unsafe-fl> 2.0 1.0 0.0 #:branch? #t)
(test-tri #f unsafe-fl> 2.0 2.0 0.0 #:branch? #t)
(test-tri #f unsafe-fl> 2.0 1.0 1.0 #:branch? #t)
(test-un #t unsafe-fl<= 1.0 #:branch? #t)
(test-bin #t unsafe-fl<= 1.0 2.0 #:branch? #t)
(test-bin #t unsafe-fl<= 2.0 2.0 #:branch? #t)
(test-bin #f unsafe-fl<= 2.0 1.0 #:branch? #t)
(test-tri #t unsafe-fl<= 1.0 1.0 1.0 #:branch? #t)
(test-tri #t unsafe-fl<= 1.0 2.0 3.0 #:branch? #t)
(test-tri #f unsafe-fl<= 3.0 2.0 3.0 #:branch? #t)
(test-tri #f unsafe-fl<= 1.0 2.0 1.0 #:branch? #t)
(test-un #t unsafe-fl>= 1.0 #:branch? #t)
(test-bin #f unsafe-fl>= 1.0 2.0 #:branch? #t)
(test-bin #t unsafe-fl>= 2.0 2.0 #:branch? #t)
(test-bin #t unsafe-fl>= 2.0 1.0 #:branch? #t)
(test-tri #t unsafe-fl>= 3.0 2.0 1.0 #:branch? #t)
(test-tri #t unsafe-fl>= 3.0 3.0 3.0 #:branch? #t)
(test-tri #f unsafe-fl>= 3.0 4.0 1.0 #:branch? #t)
(test-tri #f unsafe-fl>= 3.0 2.0 3.0 #:branch? #t)
(test-un 3.7 'unsafe-flmin 3.7)
(test-bin 3.7 'unsafe-flmin 3.7 4.1)
(test-bin 2.1 'unsafe-flmin 3.7 2.1)
(test-bin +nan.0 'unsafe-flmin +nan.0 2.1)
(test-bin +nan.0 'unsafe-flmin 2.1 +nan.0)
(test-tri +nan.0 'unsafe-flmin +nan.0 2.1 3.4)
(test-tri +nan.0 'unsafe-flmin 2.1 +nan.0 3.4)
(test-tri +nan.0 'unsafe-flmin 2.1 3.4 +nan.0)
(test-un 2.1 'unsafe-flmax 2.1)
(test-bin 3.7 'unsafe-flmax 3.7 2.1)
(test-bin 4.1 'unsafe-flmax 3.7 4.1)
(test-bin +nan.0 'unsafe-flmax +nan.0 2.1)
(test-bin +nan.0 'unsafe-flmax 2.1 +nan.0)
(test-tri +nan.0 'unsafe-flmax +nan.0 2.1 3.4)
(test-tri +nan.0 'unsafe-flmax 2.1 +nan.0 3.4)
(test-tri +nan.0 'unsafe-flmax 2.1 3.4 +nan.0)
(test-bin 1.7+45.0i 'unsafe-make-flrectangular 1.7 45.0)
(test-un 3.5 'unsafe-flreal-part 3.5+4.6i)

4
pkgs/racket-test-core/tests/racket/vector.rktl
View File

@ -341,9 +341,9 @@
(err/rt-test (vector-sort! (vector 1) (λ (x) x)) (check-regs #rx"vector-sort!" #rx"any/c any/c . -> . any/c"))
(err/rt-test (vector-sort (vector 1) (λ (x) x)) (check-regs #rx"vector-sort" #rx"any/c any/c . -> . any/c"))
(err/rt-test (vector-sort! (vector 1) < #:key 42) (check-regs #rx"vector-sort!" #rx"any/c . -> . any/c"))
(err/rt-test (vector-sort! (vector 1) < #:key <) (check-regs #rx"vector-sort!" #rx"any/c . -> . any/c"))
(err/rt-test (vector-sort! (vector 1) < #:key cons) (check-regs #rx"vector-sort!" #rx"any/c . -> . any/c"))
(err/rt-test (vector-sort (vector 1) < #:key 42) (check-regs #rx"vector-sort" #rx"any/c . -> . any/c"))
(err/rt-test (vector-sort (vector 1) < #:key <) (check-regs #rx"vector-sort" #rx"any/c . -> . any/c")))
(err/rt-test (vector-sort (vector 1) < #:key cons) (check-regs #rx"vector-sort" #rx"any/c . -> . any/c")))
;; ---------- vector-sort! actually mutates arg, and vector-sort does not ----------
;; verify underlying vector is sorted

48
racket/src/cs/primitive/flfxnum.ss
View File

@ -1,17 +1,17 @@
(define-primitive-table flfxnum-table
[->fl (known-procedure 2)]
[fl* (known-procedure 4)]
[fl+ (known-procedure 4)]
[fl- (known-procedure 4)]
[fl* (known-procedure -1)]
[fl+ (known-procedure -1)]
[fl- (known-procedure -2)]
[fl->exact-integer (known-procedure 2)]
[fl->fx (known-procedure 2)]
[fl/ (known-procedure 4)]
[fl< (known-procedure 4)]
[fl<= (known-procedure 4)]
[fl= (known-procedure 4)]
[fl> (known-procedure 4)]
[fl>= (known-procedure 4)]
[fl/ (known-procedure -2)]
[fl< (known-procedure -2)]
[fl<= (known-procedure -2)]
[fl= (known-procedure -2)]
[fl> (known-procedure -2)]
[fl>= (known-procedure -2)]
[flabs (known-procedure 2)]
[flacos (known-procedure 2)]
[flasin (known-procedure 2)]
@ -23,8 +23,8 @@
[flfloor (known-procedure 2)]
[flimag-part (known-procedure 2)]
[fllog (known-procedure 2)]
[flmax (known-procedure 4)]
[flmin (known-procedure 4)]
[flmax (known-procedure -2)]
[flmin (known-procedure -2)]
[flreal-part (known-procedure 2)]
[flround (known-procedure 2)]
[flsin (known-procedure 2)]
@ -37,21 +37,21 @@
[flvector-ref (known-procedure 4)]
[flvector-set! (known-procedure 8)]
[flvector? (known-procedure 2)]
[fx* (known-procedure 4)]
[fx+ (known-procedure 4)]
[fx- (known-procedure 4)]
[fx* (known-procedure -1)]
[fx+ (known-procedure -1)]
[fx- (known-procedure -2)]
[fx->fl (known-procedure 2)]
[fx< (known-procedure 4)]
[fx<= (known-procedure 4)]
[fx= (known-procedure 4)]
[fx> (known-procedure 4)]
[fx>= (known-procedure 4)]
[fx< (known-procedure -2)]
[fx<= (known-procedure -2)]
[fx= (known-procedure -2)]
[fx> (known-procedure -2)]
[fx>= (known-procedure -2)]
[fxabs (known-procedure 2)]
[fxand (known-procedure 4)]
[fxior (known-procedure 4)]
[fxand (known-procedure -1)]
[fxior (known-procedure -1)]
[fxlshift (known-procedure 4)]
[fxmax (known-procedure 4)]
[fxmin (known-procedure 4)]
[fxmax (known-procedure -2)]
[fxmin (known-procedure -2)]
[fxmodulo (known-procedure 4)]
[fxnot (known-procedure 2)]
[fxquotient (known-procedure 4)]
@ -63,7 +63,7 @@
[fxvector-ref (known-procedure 4)]
[fxvector-set! (known-procedure 8)]
[fxvector? (known-procedure 2)]
[fxxor (known-procedure 4)]
[fxxor (known-procedure -1)]
[make-flrectangular (known-procedure 4)]
[make-flvector (known-procedure 6)]
[make-fxvector (known-procedure 6)]

74
racket/src/cs/primitive/kernel.ss
View File

@ -8,11 +8,11 @@
[+ (known-procedure -1)]
[- (known-procedure -2)]
[/ (known-procedure -2)]
[< (known-procedure -4)]
[<= (known-procedure -4)]
[= (known-procedure -4)]
[> (known-procedure -4)]
[>= (known-procedure -4)]
[< (known-procedure -2)]
[<= (known-procedure -2)]
[= (known-procedure -2)]
[> (known-procedure -2)]
[>= (known-procedure -2)]
[abort-current-continuation (known-procedure -2)]
[abs (known-procedure 2)]
[absolute-path? (known-procedure 2)]
@ -79,9 +79,9 @@
[bytes-utf-8-index (known-procedure 28)]
[bytes-utf-8-length (known-procedure 30)]
[bytes-utf-8-ref (known-procedure 28)]
[bytes<? (known-procedure -4)]
[bytes=? (known-procedure -4)]
[bytes>? (known-procedure -4)]
[bytes<? (known-procedure -2)]
[bytes=? (known-procedure -2)]
[bytes>? (known-procedure -2)]
[bytes? (known-procedure/succeeds 2)]
[caaaar (known-procedure 2)]
[caaadr (known-procedure 2)]
@ -147,11 +147,11 @@
[char->integer (known-procedure 2)]
[char-alphabetic? (known-procedure 2)]
[char-blank? (known-procedure 2)]
[char-ci<=? (known-procedure -4)]
[char-ci<? (known-procedure -4)]
[char-ci=? (known-procedure -4)]
[char-ci>=? (known-procedure -4)]
[char-ci>? (known-procedure -4)]
[char-ci<=? (known-procedure -2)]
[char-ci<? (known-procedure -2)]
[char-ci=? (known-procedure -2)]
[char-ci>=? (known-procedure -2)]
[char-ci>? (known-procedure -2)]
[char-downcase (known-procedure 2)]
[char-foldcase (known-procedure 2)]
[char-general-category (known-procedure 2)]
@ -168,11 +168,11 @@
[char-upper-case? (known-procedure 2)]
[char-utf-8-length (known-procedure 2)]
[char-whitespace? (known-procedure 2)]
[char<=? (known-procedure -4)]
[char<? (known-procedure -4)]
[char=? (known-procedure -4)]
[char>=? (known-procedure -4)]
[char>? (known-procedure -4)]
[char<=? (known-procedure -2)]
[char<? (known-procedure -2)]
[char=? (known-procedure -2)]
[char>=? (known-procedure -2)]
[char>? (known-procedure -2)]
[char? (known-procedure/succeeds 2)]
[checked-procedure-check-and-extract (known-procedure 32)]
[choice-evt (known-procedure -1)]
@ -465,7 +465,7 @@
[integer? (known-procedure 2)]
[interned-char? (known-procedure 2)]
[keyword->string (known-procedure 2)]
[keyword<? (known-procedure -4)]
[keyword<? (known-procedure -2)]
[keyword? (known-procedure 2)]
[kill-thread (known-procedure 2)]
[lcm (known-procedure -1)]
@ -589,7 +589,7 @@
[path-element->bytes (known-procedure 2)]
[path-element->string (known-procedure 2)]
[path-for-some-system? (known-procedure 2)]
[path<? (known-procedure -4)]
[path<? (known-procedure -2)]
[path? (known-procedure 2)]
[peek-byte (known-procedure 7)]
[peek-byte-or-special (known-procedure 63)]
@ -796,25 +796,25 @@
[string->uninterned-symbol (known-procedure 2)]
[string->unreadable-symbol (known-procedure 2)]
[string-append (known-procedure -1)]
[string-ci<=? (known-procedure -4)]
[string-ci<? (known-procedure -4)]
[string-ci=? (known-procedure -4)]
[string-ci>=? (known-procedure -4)]
[string-ci>? (known-procedure -4)]
[string-ci<=? (known-procedure -2)]
[string-ci<? (known-procedure -2)]
[string-ci=? (known-procedure -2)]
[string-ci>=? (known-procedure -2)]
[string-ci>? (known-procedure -2)]
[string-copy (known-procedure 2)]
[string-copy! (known-procedure 56)]
[string-downcase (known-procedure 2)]
[string-fill! (known-procedure 4)]
[string-foldcase (known-procedure 2)]
[string-length (known-procedure 2)]
[string-locale-ci<? (known-procedure -4)]
[string-locale-ci=? (known-procedure -4)]
[string-locale-ci>? (known-procedure -4)]
[string-locale-ci<? (known-procedure -2)]
[string-locale-ci=? (known-procedure -2)]
[string-locale-ci>? (known-procedure -2)]
[string-locale-downcase (known-procedure 2)]
[string-locale-upcase (known-procedure 2)]
[string-locale<? (known-procedure -4)]
[string-locale=? (known-procedure -4)]
[string-locale>? (known-procedure -4)]
[string-locale<? (known-procedure -2)]
[string-locale=? (known-procedure -2)]
[string-locale>? (known-procedure -2)]
[string-normalize-nfc (known-procedure 2)]
[string-normalize-nfd (known-procedure 2)]
[string-normalize-nfkc (known-procedure 2)]
@ -825,11 +825,11 @@
[string-titlecase (known-procedure 2)]
[string-upcase (known-procedure 2)]
[string-utf-8-length (known-procedure 14)]
[string<=? (known-procedure -4)]
[string<? (known-procedure -4)]
[string=? (known-procedure -4)]
[string>=? (known-procedure -4)]
[string>? (known-procedure -4)]
[string<=? (known-procedure -2)]
[string<? (known-procedure -2)]
[string=? (known-procedure -2)]
[string>=? (known-procedure -2)]
[string>? (known-procedure -2)]
[string? (known-procedure/succeeds 2)]
[struct->vector (known-procedure 6)]
[struct-accessor-procedure? (known-procedure 2)]
@ -884,7 +884,7 @@
[symbol->string (known-procedure 2)]
[symbol-interned? (known-procedure 2)]
[symbol-unreadable? (known-procedure 2)]
[symbol<? (known-procedure -4)]
[symbol<? (known-procedure -2)]
[symbol? (known-procedure/succeeds 2)]
[sync (known-procedure -1)]
[sync/enable-break (known-procedure -1)]

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

@ -45,16 +45,16 @@
[unsafe-f80vector-set! (known-procedure 8)]
[unsafe-file-descriptor->port (known-procedure 8)]
[unsafe-file-descriptor->semaphore (known-procedure 4)]
[unsafe-fl* (known-procedure/succeeds 4)]
[unsafe-fl+ (known-procedure/succeeds 4)]
[unsafe-fl- (known-procedure/succeeds 4)]
[unsafe-fl* (known-procedure/succeeds -1)]
[unsafe-fl+ (known-procedure/succeeds -1)]
[unsafe-fl- (known-procedure/succeeds -2)]
[unsafe-fl->fx (known-procedure/succeeds 2)]
[unsafe-fl/ (known-procedure/succeeds 4)]
[unsafe-fl< (known-procedure/succeeds 4)]
[unsafe-fl<= (known-procedure/succeeds 4)]
[unsafe-fl= (known-procedure/succeeds 4)]
[unsafe-fl> (known-procedure/succeeds 4)]
[unsafe-fl>= (known-procedure/succeeds 4)]
[unsafe-fl/ (known-procedure/succeeds -2)]
[unsafe-fl< (known-procedure/succeeds -2)]
[unsafe-fl<= (known-procedure/succeeds -2)]
[unsafe-fl= (known-procedure/succeeds -2)]
[unsafe-fl> (known-procedure/succeeds -2)]
[unsafe-fl>= (known-procedure/succeeds -2)]
[unsafe-flabs (known-procedure/succeeds 2)]
[unsafe-flimag-part (known-procedure/succeeds 2)]
[unsafe-flmax (known-procedure/succeeds 4)]
@ -65,22 +65,22 @@
[unsafe-flvector-length (known-procedure/succeeds 2)]
[unsafe-flvector-ref (known-procedure 4)]
[unsafe-flvector-set! (known-procedure 8)]
[unsafe-fx* (known-procedure/succeeds 4)]
[unsafe-fx+ (known-procedure/succeeds 4)]
[unsafe-fx- (known-procedure/succeeds 4)]
[unsafe-fx* (known-procedure/succeeds -1)]
[unsafe-fx+ (known-procedure/succeeds -1)]
[unsafe-fx- (known-procedure/succeeds -2)]
[unsafe-fx->extfl (known-procedure/succeeds 2)]
[unsafe-fx->fl (known-procedure/succeeds 2)]
[unsafe-fx< (known-procedure/succeeds 4)]
[unsafe-fx<= (known-procedure/succeeds 4)]
[unsafe-fx= (known-procedure/succeeds 4)]
[unsafe-fx> (known-procedure/succeeds 4)]
[unsafe-fx>= (known-procedure/succeeds 4)]
[unsafe-fx< (known-procedure/succeeds -2)]
[unsafe-fx<= (known-procedure/succeeds -2)]
[unsafe-fx= (known-procedure/succeeds -2)]
[unsafe-fx> (known-procedure/succeeds -2)]
[unsafe-fx>= (known-procedure/succeeds -2)]
[unsafe-fxabs (known-procedure/succeeds 2)]
[unsafe-fxand (known-procedure/succeeds 4)]
[unsafe-fxior (known-procedure/succeeds 4)]
[unsafe-fxand (known-procedure/succeeds -1)]
[unsafe-fxior (known-procedure/succeeds -1)]
[unsafe-fxlshift (known-procedure/succeeds 4)]
[unsafe-fxmax (known-procedure/succeeds 4)]
[unsafe-fxmin (known-procedure/succeeds 4)]
[unsafe-fxmax (known-procedure/succeeds -2)]
[unsafe-fxmin (known-procedure/succeeds -2)]
[unsafe-fxmodulo (known-procedure/succeeds 4)]
[unsafe-fxnot (known-procedure/succeeds 2)]
[unsafe-fxquotient (known-procedure/succeeds 4)]
@ -89,7 +89,7 @@
[unsafe-fxvector-length (known-procedure/succeeds 2)]
[unsafe-fxvector-ref (known-procedure 4)]
[unsafe-fxvector-set! (known-procedure 8)]
[unsafe-fxxor (known-procedure/succeeds 4)]
[unsafe-fxxor (known-procedure/succeeds -1)]
[unsafe-get-place-table (known-procedure 1)]
[unsafe-immutable-hash-iterate-first (known-procedure/succeeds 2)]
[unsafe-immutable-hash-iterate-key (known-procedure/succeeds 4)]

3
racket/src/cs/rumble/keyword.ss
View File

@ -21,6 +21,9 @@
(define/who keyword<?
(case-lambda
[(a)
(check who keyword? a)
#t]
[(a b)
(check who keyword? a)
(check who keyword? b)

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

@ -118,36 +118,36 @@ void scheme_init_char (Scheme_Startup_Env *env)
scheme_interned_char_p_proc = p;
scheme_addto_prim_instance("interned-char?", p, env);
p = scheme_make_folding_prim(char_eq, "char=?", 2, -1, 1);
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_addto_prim_instance("char=?", p, env);
p = scheme_make_folding_prim(char_lt, "char<?", 2, -1, 1);
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_addto_prim_instance("char<?", p, env);
p = scheme_make_folding_prim(char_gt, "char>?", 2, -1, 1);
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_addto_prim_instance("char>?", p, env);
p = scheme_make_folding_prim(char_lt_eq, "char<=?", 2, -1, 1);
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_addto_prim_instance("char<=?", p, env);
p = scheme_make_folding_prim(char_gt_eq, "char>=?", 2, -1, 1);
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_addto_prim_instance("char>=?", p, env);
ADD_FOLDING_PRIM("char-ci=?", char_eq_ci, 2, -1, 1, env);
ADD_FOLDING_PRIM("char-ci<?", char_lt_ci, 2, -1, 1, env);
ADD_FOLDING_PRIM("char-ci>?", char_gt_ci, 2, -1, 1, env);
ADD_FOLDING_PRIM("char-ci<=?", char_lt_eq_ci, 2, -1, 1, env);
ADD_FOLDING_PRIM("char-ci>=?", char_gt_eq_ci, 2, -1, 1, env);
ADD_FOLDING_PRIM("char-ci=?", char_eq_ci, 1, -1, 1, env);
ADD_FOLDING_PRIM("char-ci<?", char_lt_ci, 1, -1, 1, env);
ADD_FOLDING_PRIM("char-ci>?", char_gt_ci, 1, -1, 1, env);
ADD_FOLDING_PRIM("char-ci<=?", char_lt_eq_ci, 1, -1, 1, env);
ADD_FOLDING_PRIM("char-ci>=?", char_gt_eq_ci, 1, -1, 1, env);
ADD_FOLDING_PRIM("char-alphabetic?", char_alphabetic, 1, 1, 1, env);
ADD_FOLDING_PRIM("char-numeric?", char_numeric, 1, 1, 1, env);
ADD_FOLDING_PRIM("char-symbolic?", char_symbolic, 1, 1, 1, env);

1
racket/src/racket/src/jit.h
View File

@ -1474,6 +1474,7 @@ int scheme_generate_unboxing(mz_jit_state *jitter, int target);
int scheme_generate_pop_unboxed(mz_jit_state *jitter);
int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
int arith, int cmp, Branch_Info *for_branch, int branch_short,
int unsafe_fx, int unsafe_fl,
int dest);
int scheme_generate_alloc_double(mz_jit_state *jitter, int inline_retry, int dest);
int scheme_generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2,

143
racket/src/racket/src/jitarith.c
View File

@ -2185,9 +2185,10 @@ static void patch_nary_branches(mz_jit_state *jitter, Branch_Info *for_nary_bran
int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
int arith, int cmp, Branch_Info *for_branch, int branch_short,
int unsafe_fx, int unsafe_fl,
int dest)
{
int c, i, non_simple_c = 0, stack_c, use_fx = 1, trigger_arg = 0;
int c, i, non_simple_c = 0, stack_c, use_fx = !unsafe_fl, trigger_arg = 0;
Scheme_Object *non_simples[MAX_NON_SIMPLE_ARGS], **alt_args, *v;
Branch_Info for_nary_branch;
Branch_Info_Addr nary_addrs[3];
@ -2196,7 +2197,7 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
#ifdef INLINE_FP_OPS
int args_unboxed;
GC_CAN_IGNORE jit_insn *reffl, *refdone2;
int use_fl = 1;
int use_fl = !unsafe_fx;
# define mzSET_USE_FL(x) x
#else
# define mzSET_USE_FL(x) /* empty */
@ -2210,6 +2211,26 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
}
c = app->num_args;
if (!c) {
/* Constant folding would normally prevent us from getting here, but just in case */
if ((arith == ARITH_ADD) || (arith == ARITH_IOR) || (arith == ARITH_XOR)) {
if (!unsafe_fl)
(void)jit_movi_p(dest, scheme_make_integer(0));
else
(void)jit_movi_p(dest, scheme_zerod);
return 1;
} else if (arith == ARITH_AND) {
(void)jit_movi_p(dest, scheme_make_integer(-1));
return 1;
} else if (arith == ARITH_MUL) {
if (!unsafe_fl)
(void)jit_movi_p(dest, scheme_make_integer(1));
else
scheme_mz_load_retained(jitter, dest, scheme_make_double(1.0));
return 1;
}
}
for (i = 0; i < c; i++) {
v = app->args[i+1];
if (!scheme_is_constant_and_avoids_r1(v)) {
@ -2257,11 +2278,15 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
extract_nary_arg(JIT_R0, trigger_arg, jitter, app, alt_args, c < 100);
CHECK_LIMIT();
/* trigger argument a fixnum? */
reffx = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
if (unsafe_fl < 1) {
/* trigger argument a fixnum? */
reffx = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
} else
reffx = NULL;
#ifdef INLINE_FP_OPS
if (use_fl) {
if (use_fl && (unsafe_fl < 1)) {
/* First argument a flonum? */
jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type);
reffl = jit_beqi_i(jit_forward(), JIT_R0, scheme_double_type);
@ -2271,36 +2296,57 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
}
#endif
if (!use_fx) {
if (!use_fx && reffx) {
mz_patch_branch(reffx);
}
refslow = jit_get_ip();
/* slow path */
if (alt_args) {
/* get all args on runstack */
int delta = stack_c - c;
for (i = 0; i < c; i++) {
if (delta) {
extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100);
CHECK_LIMIT();
jit_stxi_p(WORDS_TO_BYTES(i+delta), JIT_RUNSTACK, JIT_R0);
} else
break;
if ((unsafe_fl < 1) && (unsafe_fx < 1)) {
refslow = jit_get_ip();
/* slow path */
if (alt_args) {
/* get all args on runstack */
int delta = stack_c - c;
for (i = 0; i < c; i++) {
if (delta) {
extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100);
CHECK_LIMIT();
jit_stxi_p(WORDS_TO_BYTES(i+delta), JIT_RUNSTACK, JIT_R0);
} else
break;
}
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c - stack_c));
}
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c - stack_c));
(void)jit_movi_p(JIT_V1, ((Scheme_Primitive_Proc *)app->args[0])->prim_val);
(void)jit_movi_i(JIT_R1, c);
(void)jit_calli(sjc.call_original_nary_arith_code);
if (alt_args) {
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c - stack_c));
}
refdone = jit_jmpi(jit_forward());
} else {
refdone = NULL;
refslow = NULL;
}
(void)jit_movi_p(JIT_V1, ((Scheme_Primitive_Proc *)app->args[0])->prim_val);
(void)jit_movi_i(JIT_R1, c);
(void)jit_calli(sjc.call_original_nary_arith_code);
if (alt_args) {
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c - stack_c));
}
refdone = jit_jmpi(jit_forward());
if (!arith) {
GC_CAN_IGNORE jit_insn *refskip;
if ((unsafe_fx > 0) || (unsafe_fl > 0)) {
/* No dispatch so far, so jump to fast path to skip #f result */
__START_TINY_JUMPS__(1);
refskip = jit_jmpi(jit_forward());
__END_TINY_JUMPS__(1);
} else
refskip = NULL;
reffalse = jit_get_ip();
(void)jit_movi_p(JIT_R0, scheme_false);
refdone3 = jit_jmpi(jit_forward());
if (refskip) {
__START_TINY_JUMPS__(1);
mz_patch_ucbranch(refskip);
__END_TINY_JUMPS__(1);
}
} else {
reffalse = NULL;
}
@ -2308,16 +2354,18 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
#ifdef INLINE_FP_OPS
if (use_fl) {
/* Flonum branch: */
mz_patch_branch(reffl);
for (i = 0; i < c; i++) {
if (i != trigger_arg) {
v = app->args[i+1];
if (!SCHEME_FLOATP(v)) {
extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100);
(void)jit_bmsi_ul(refslow, JIT_R0, 0x1);
jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(refslow, JIT_R0, scheme_double_type);
CHECK_LIMIT();
if (unsafe_fl < 1) {
mz_patch_branch(reffl);
for (i = 0; i < c; i++) {
if (i != trigger_arg) {
v = app->args[i+1];
if (!SCHEME_FLOATP(v)) {
extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100);
(void)jit_bmsi_ul(refslow, JIT_R0, 0x1);
jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(refslow, JIT_R0, scheme_double_type);
CHECK_LIMIT();
}
}
}
}
@ -2353,15 +2401,17 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
if (use_fx) {
/* Fixnum branch */
mz_patch_branch(reffx);
for (i = 0; i < c; i++) {
if (i != trigger_arg) {
v = app->args[i+1];
if (!SCHEME_INTP(v)) {
extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100);
CHECK_LIMIT();
(void)jit_bmci_ul(refslow, JIT_R0, 0x1);
CHECK_LIMIT();
if (unsafe_fx < 1) {
mz_patch_branch(reffx);
for (i = 0; i < c; i++) {
if (i != trigger_arg) {
v = app->args[i+1];
if (!SCHEME_INTP(v)) {
extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100);
CHECK_LIMIT();
(void)jit_bmci_ul(refslow, JIT_R0, 0x1);
CHECK_LIMIT();
}
}
}
}
@ -2392,7 +2442,8 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
if (!arith) {
(void)jit_movi_p(JIT_R0, scheme_true);
}
mz_patch_ucbranch(refdone);
if (refdone)
mz_patch_ucbranch(refdone);
if (refdone3)
mz_patch_ucbranch(refdone3);

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

@ -2197,6 +2197,18 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "-")) {
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_SUB, 0, 0, NULL, 1, 0, 0, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fx-")) {
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_SUB, 0, 0, NULL, 1, -1, 0, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fl-")) {
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_SUB, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx-")) {
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_SUB, 0, 0, NULL, 1, 1, 0, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl-")) {
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_SUB, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "abs")) {
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_ABS, 0, 0, NULL, 1, 0, 0, NULL, dest);
return 1;
@ -4580,19 +4592,79 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
scheme_direct_call_count++;
if (IS_NAMED_PRIM(rator, "=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_EQUAL, for_branch, branch_short, dest);
scheme_generate_nary_arith(jitter, app, 0, CMP_EQUAL, for_branch, branch_short, 0, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fx=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_EQUAL, for_branch, branch_short, -1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fl=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_EQUAL, for_branch, branch_short, 0, -1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_EQUAL, for_branch, branch_short, 1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_EQUAL, for_branch, branch_short, 0, 1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "<")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LT, for_branch, branch_short, dest);
scheme_generate_nary_arith(jitter, app, 0, CMP_LT, for_branch, branch_short, 0, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fx<")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LT, for_branch, branch_short, -1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fl<")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LT, for_branch, branch_short, 0, -1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx<")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LT, for_branch, branch_short, 1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl<")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LT, for_branch, branch_short, 0, 1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, ">")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GT, for_branch, branch_short, dest);
scheme_generate_nary_arith(jitter, app, 0, CMP_GT, for_branch, branch_short, 0, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fx>")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GT, for_branch, branch_short, -1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fl>")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GT, for_branch, branch_short, 0, -1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx>")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GT, for_branch, branch_short, 1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl>")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GT, for_branch, branch_short, 0, 1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "<=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LEQ, for_branch, branch_short, dest);
scheme_generate_nary_arith(jitter, app, 0, CMP_LEQ, for_branch, branch_short, 0, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fx<=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LEQ, for_branch, branch_short, -1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fl<=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LEQ, for_branch, branch_short, 0, -1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx<=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LEQ, for_branch, branch_short, 1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl<=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_LEQ, for_branch, branch_short, 0, 1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, ">=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GEQ, for_branch, branch_short, dest);
scheme_generate_nary_arith(jitter, app, 0, CMP_GEQ, for_branch, branch_short, 0, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fx>=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GEQ, for_branch, branch_short, -1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "fl>=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GEQ, for_branch, branch_short, 0, -1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx>=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GEQ, for_branch, branch_short, 1, 0, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl>=")) {
scheme_generate_nary_arith(jitter, app, 0, CMP_GEQ, for_branch, branch_short, 0, 1, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "current-future")) {
mz_rs_sync();
@ -5252,23 +5324,79 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
return 1;
} else if (IS_NAMED_PRIM(rator, "+")) {
return scheme_generate_nary_arith(jitter, app, ARITH_ADD, 0, NULL, 1, dest);
return scheme_generate_nary_arith(jitter, app, ARITH_ADD, 0, NULL, 1, 0, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fx+")) {
return scheme_generate_nary_arith(jitter, app, ARITH_ADD, 0, NULL, 1, -1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fl+")) {
return scheme_generate_nary_arith(jitter, app, ARITH_ADD, 0, NULL, 1, 0, -1, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fx+")) {
return scheme_generate_nary_arith(jitter, app, ARITH_ADD, 0, NULL, 1, 1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fl+")) {
return scheme_generate_nary_arith(jitter, app, ARITH_ADD, 0, NULL, 1, 0, 1, dest);
} else if (IS_NAMED_PRIM(rator, "-")) {
return scheme_generate_nary_arith(jitter, app, ARITH_SUB, 0, NULL, 1, dest);
return scheme_generate_nary_arith(jitter, app, ARITH_SUB, 0, NULL, 1, 0, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fx-")) {
return scheme_generate_nary_arith(jitter, app, ARITH_SUB, 0, NULL, 1, -1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fl-")) {
return scheme_generate_nary_arith(jitter, app, ARITH_SUB, 0, NULL, 1, 0, -1, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fx-")) {
return scheme_generate_nary_arith(jitter, app, ARITH_SUB, 0, NULL, 1, 1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fl-")) {
return scheme_generate_nary_arith(jitter, app, ARITH_SUB, 0, NULL, 1, 0, 1, dest);
} else if (IS_NAMED_PRIM(rator, "*")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MUL, 0, NULL, 1, dest);
return scheme_generate_nary_arith(jitter, app, ARITH_MUL, 0, NULL, 1, 0, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fx*")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MUL, 0, NULL, 1, -1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fl*")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MUL, 0, NULL, 1, 0, -1, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fx*")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MUL, 0, NULL, 1, 1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fl*")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MUL, 0, NULL, 1, 0, 1, dest);
} else if (IS_NAMED_PRIM(rator, "/")) {
return scheme_generate_nary_arith(jitter, app, ARITH_DIV, 0, NULL, 1, dest);
return scheme_generate_nary_arith(jitter, app, ARITH_DIV, 0, NULL, 1, 0, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fl/")) {
return scheme_generate_nary_arith(jitter, app, ARITH_DIV, 0, NULL, 1, 0, -1, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fl/")) {
return scheme_generate_nary_arith(jitter, app, ARITH_DIV, 0, NULL, 1, 0, 1, dest);
} else if (IS_NAMED_PRIM(rator, "bitwise-and")) {
return scheme_generate_nary_arith(jitter, app, ARITH_AND, 0, NULL, 1, dest);
return scheme_generate_nary_arith(jitter, app, ARITH_AND, 0, NULL, 1, 0, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fxand")) {
return scheme_generate_nary_arith(jitter, app, ARITH_AND, 0, NULL, 1, -1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fxand")) {
return scheme_generate_nary_arith(jitter, app, ARITH_AND, 0, NULL, 1, 1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "bitwise-ior")) {
return scheme_generate_nary_arith(jitter, app, ARITH_IOR, 0, NULL, 1, dest);
return scheme_generate_nary_arith(jitter, app, ARITH_IOR, 0, NULL, 1, 0, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fxior")) {
return scheme_generate_nary_arith(jitter, app, ARITH_IOR, 0, NULL, 1, -1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fxior")) {
return scheme_generate_nary_arith(jitter, app, ARITH_IOR, 0, NULL, 1, 1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "bitwise-xor")) {
return scheme_generate_nary_arith(jitter, app, ARITH_XOR, 0, NULL, 1, dest);
return scheme_generate_nary_arith(jitter, app, ARITH_XOR, 0, NULL, 1, 0, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fxxor")) {
return scheme_generate_nary_arith(jitter, app, ARITH_XOR, 0, NULL, 1, -1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fxxor")) {
return scheme_generate_nary_arith(jitter, app, ARITH_XOR, 0, NULL, 1, 1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "min")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MIN, 0, NULL, 1, dest);
return scheme_generate_nary_arith(jitter, app, ARITH_MIN, 0, NULL, 1, 0, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fxmin")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MIN, 0, NULL, 1, -1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "flmin")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MIN, 0, NULL, 1, 0, -1, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fxmin")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MIN, 0, NULL, 1, 1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-flmin")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MIN, 0, NULL, 1, 0, 1, dest);
} else if (IS_NAMED_PRIM(rator, "max")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MAX, 0, NULL, 1, dest);
return scheme_generate_nary_arith(jitter, app, ARITH_MAX, 0, NULL, 1, 0, 0, dest);
} else if (IS_NAMED_PRIM(rator, "fxmax")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MAX, 0, NULL, 1, -1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "flmax")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MAX, 0, NULL, 1, 0, -1, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-fxmax")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MAX, 0, NULL, 1, 1, 0, dest);
} else if (IS_NAMED_PRIM(rator, "unsafe-flmax")) {
return scheme_generate_nary_arith(jitter, app, ARITH_MAX, 0, NULL, 1, 0, 1, dest);
} else if (IS_NAMED_PRIM(rator, "checked-procedure-check-and-extract")) {
scheme_generate_app(app, NULL, 5, 5, jitter, 0, 0, 0, 2); /* sync'd below */
CHECK_LIMIT();

137
racket/src/racket/src/numarith.c
View File

@ -186,20 +186,24 @@ void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
Scheme_Object *p;
int flags;
p = scheme_make_folding_prim(fx_plus, "fx+", 2, 2, 1);
p = scheme_make_folding_prim(fx_plus, "fx+", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fx+", p, env);
p = scheme_make_folding_prim(fx_minus, "fx-", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
p = scheme_make_folding_prim(fx_minus, "fx-", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fx-", p, env);
p = scheme_make_folding_prim(fx_mult, "fx*", 2, 2, 1);
p = scheme_make_folding_prim(fx_mult, "fx*", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fx*", p, env);
@ -224,9 +228,9 @@ void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
| SCHEME_PRIM_PRODUCES_FIXNUM;
scheme_addto_prim_instance("fxabs", p, env);
p = scheme_make_folding_prim(fl_plus, "fl+", 2, 2, 1);
p = scheme_make_folding_prim(fl_plus, "fl+", 0, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -234,9 +238,10 @@ void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("fl+", p, env);
p = scheme_make_folding_prim(fl_minus, "fl-", 2, 2, 1);
p = scheme_make_folding_prim(fl_minus, "fl-", 1, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -244,9 +249,9 @@ void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("fl-", p, env);
p = scheme_make_folding_prim(fl_mult, "fl*", 2, 2, 1);
p = scheme_make_folding_prim(fl_mult, "fl*", 0, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -254,9 +259,9 @@ void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("fl*", p, env);
p = scheme_make_folding_prim(fl_div, "fl/", 2, 2, 1);
p = scheme_make_folding_prim(fl_div, "fl/", 1, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -358,25 +363,29 @@ void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
int flags;
REGISTER_SO(scheme_unsafe_fx_plus_proc);
p = scheme_make_folding_prim(unsafe_fx_plus, "unsafe-fx+", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_plus, "unsafe-fx+", 0, -1, 1);
scheme_unsafe_fx_plus_proc = p;
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_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fx+", p, env);
REGISTER_SO(scheme_unsafe_fx_minus_proc);
p = scheme_make_folding_prim(unsafe_fx_minus, "unsafe-fx-", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_minus, "unsafe-fx-", 1, -2, 1);
scheme_unsafe_fx_minus_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fx-", p, env);
REGISTER_SO(scheme_unsafe_fx_times_proc);
p = scheme_make_folding_prim(unsafe_fx_mult, "unsafe-fx*", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_mult, "unsafe-fx*", 0, -1, 1);
scheme_unsafe_fx_times_proc = p;
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_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fx*", p, env);
@ -406,9 +415,9 @@ void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
scheme_addto_prim_instance("unsafe-fxabs", p, env);
p = scheme_make_folding_prim(unsafe_fl_plus, "unsafe-fl+", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_plus, "unsafe-fl+", 0, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -417,9 +426,10 @@ void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("unsafe-fl+", p, env);
p = scheme_make_folding_prim(unsafe_fl_minus, "unsafe-fl-", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_minus, "unsafe-fl-", 1, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -428,9 +438,9 @@ void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("unsafe-fl-", p, env);
p = scheme_make_folding_prim(unsafe_fl_mult, "unsafe-fl*", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_mult, "unsafe-fl*", 0, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -439,9 +449,9 @@ void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("unsafe-fl*", p, env);
p = scheme_make_folding_prim(unsafe_fl_div, "unsafe-fl/", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_div, "unsafe-fl/", 1, -2, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -1216,8 +1226,10 @@ static void check_always_fixnum(const char *name, Scheme_Object *o)
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
Scheme_Object *o; \
if (!SCHEME_INTP(argv[0])) scheme_wrong_contract(s_name, "fixnum?", 0, argc, argv); \
if (!SCHEME_INTP(argv[1])) scheme_wrong_contract(s_name, "fixnum?", 1, argc, argv); \
int i; \
for (i = 0; i < argc; i++) { \
if (!SCHEME_INTP(argv[i])) scheme_wrong_contract(s_name, "fixnum?", i, argc, argv); \
} \
EXTRA_CHECK \
o = scheme_op(argc, argv); \
mzWHEN_64_BITS(if (scheme_current_thread->constant_folding) check_always_fixnum(s_name, o);) \
@ -1241,20 +1253,26 @@ static Scheme_Object *fx_abs(int argc, Scheme_Object *argv[])
return o;
}
#define UNSAFE_FX(name, op, fold) \
#define UNSAFE_FX(name, op, fold, zero_args, PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
intptr_t v; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
v = SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1]); \
return scheme_make_integer(v); \
intptr_t v; \
int i; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
if (!argc) return zero_args; \
v = SCHEME_INT_VAL(argv[0]); \
PRE_CHECK \
for (i = 1; i < argc; i++) { \
v = v op SCHEME_INT_VAL(argv[i]); \
} \
return scheme_make_integer(v); \
}
UNSAFE_FX(unsafe_fx_plus, +, fx_plus)
UNSAFE_FX(unsafe_fx_minus, -, fx_minus)
UNSAFE_FX(unsafe_fx_mult, *, fx_mult)
UNSAFE_FX(unsafe_fx_div, /, fx_div)
UNSAFE_FX(unsafe_fx_rem, %, fx_rem)
UNSAFE_FX(unsafe_fx_plus, +, fx_plus, scheme_make_integer(0), )
UNSAFE_FX(unsafe_fx_minus, -, fx_minus, scheme_false, if (argc == 1) v = -v;)
UNSAFE_FX(unsafe_fx_mult, *, fx_mult, scheme_make_integer(1), )
UNSAFE_FX(unsafe_fx_div, /, fx_div, scheme_false, )
UNSAFE_FX(unsafe_fx_rem, %, fx_rem, scheme_false, )
static Scheme_Object *unsafe_fx_mod(int argc, Scheme_Object *argv[])
{
@ -1293,19 +1311,30 @@ static Scheme_Object *unsafe_fx_abs(int argc, Scheme_Object *argv[])
return scheme_make_integer(v);
}
#define UNSAFE_FL(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
#define UNSAFE_FL(name, op, fold, zero_args, PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
double v; \
if (!argc) return zero_args; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
v = SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1]); \
return scheme_make_double(v); \
if (argc == 2) { \
v = SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1]); \
return scheme_make_double(v); \
} else { \
int i; \
v = SCHEME_DBL_VAL(argv[0]); \
PRE_CHECK \
for (i = 1; i < argc; i++) { \
v = v op SCHEME_DBL_VAL(argv[i]); \
} \
return scheme_make_double(v); \
} \
}
UNSAFE_FL(unsafe_fl_plus, +, plus)
UNSAFE_FL(unsafe_fl_minus, -, minus)
UNSAFE_FL(unsafe_fl_mult, *, mult)
UNSAFE_FL(unsafe_fl_div, /, div_prim)
UNSAFE_FL(unsafe_fl_plus, +, plus, scheme_zerod, )
UNSAFE_FL(unsafe_fl_minus, -, minus, scheme_false, if (argc == 1) v = 0.0 - v;)
UNSAFE_FL(unsafe_fl_mult, *, mult, scheme_make_double(1.0), )
UNSAFE_FL(unsafe_fl_div, /, div_prim, scheme_false, if (argc == 1) v = 1.0 / v;)
#define UNSAFE_FL1(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
@ -1328,20 +1357,26 @@ static Scheme_Object *pos_sqrt(int argc, Scheme_Object **argv)
UNSAFE_FL1(unsafe_fl_sqrt, sqrt, pos_sqrt)
#define SAFE_FL(name, sname, op) \
#define SAFE_FL(name, sname, op, zero_args, PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
double v; \
int i; \
if (!argc) return zero_args; \
if (!SCHEME_DBLP(argv[0])) scheme_wrong_contract(sname, "flonum?", 0, argc, argv); \
if (!SCHEME_DBLP(argv[1])) scheme_wrong_contract(sname, "flonum?", 1, argc, argv); \
v = SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1]); \
v = SCHEME_DBL_VAL(argv[0]); \
PRE_CHECK \
for (i = 1; i < argc; i++) { \
if (!SCHEME_DBLP(argv[i])) scheme_wrong_contract(sname, "flonum?", i, argc, argv); \
v = v op SCHEME_DBL_VAL(argv[i]); \
} \
return scheme_make_double(v); \
}
SAFE_FL(fl_plus, "fl+", +)
SAFE_FL(fl_minus, "fl-", -)
SAFE_FL(fl_mult, "fl*", *)
SAFE_FL(fl_div, "fl/", /)
SAFE_FL(fl_plus, "fl+", +, scheme_zerod, )
SAFE_FL(fl_minus, "fl-", -, scheme_false, if (argc == 1) v = 0.0 - v;)
SAFE_FL(fl_mult, "fl*", *, scheme_make_double(1.0), )
SAFE_FL(fl_div, "fl/", /, scheme_false, if (argc == 1) v = 1.0 / v;)
#define SAFE_FL1(name, sname, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \

64
racket/src/racket/src/number.c
View File

@ -867,20 +867,23 @@ void scheme_init_flfxnum_number(Scheme_Startup_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags);
scheme_addto_prim_instance("fl->exact-integer", p, env);
p = scheme_make_folding_prim(fx_and, "fxand", 2, 2, 1);
p = scheme_make_folding_prim(fx_and, "fxand", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fxand", p, env);
p = scheme_make_folding_prim(fx_or, "fxior", 2, 2, 1);
p = scheme_make_folding_prim(fx_or, "fxior", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fxior", p, env);
p = scheme_make_folding_prim(fx_xor, "fxxor", 2, 2, 1);
p = scheme_make_folding_prim(fx_xor, "fxxor", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fxxor", p, env);
@ -1325,24 +1328,27 @@ void scheme_init_unsafe_number(Scheme_Startup_Env *env)
Scheme_Object *p;
int flags;
p = scheme_make_folding_prim(unsafe_fx_and, "unsafe-fxand", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_and, "unsafe-fxand", 0, -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_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fxand", p, env);
REGISTER_SO(scheme_unsafe_fxand_proc);
scheme_unsafe_fxand_proc = p;
p = scheme_make_folding_prim(unsafe_fx_or, "unsafe-fxior", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_or, "unsafe-fxior", 0, -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_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fxior", p, env);
REGISTER_SO(scheme_unsafe_fxior_proc);
scheme_unsafe_fxior_proc = p;
p = scheme_make_folding_prim(unsafe_fx_xor, "unsafe-fxxor", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_xor, "unsafe-fxxor", 0, -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_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fxxor", p, env);
@ -5253,20 +5259,27 @@ static Scheme_Object *neg_bitwise_shift(int argc, Scheme_Object *argv[])
return scheme_bitwise_shift(argc, a);
}
#define SAFE_FX(name, s_name, scheme_op, sec_p, sec_t) \
#define SAFE_FX(name, s_name, scheme_op, sec_p, sec_t, no_args) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
Scheme_Object *o; \
int i; \
if (!argc) return no_args; \
if (!SCHEME_INTP(argv[0])) scheme_wrong_contract(s_name, "fixnum?", 0, argc, argv); \
if (!sec_p(argv[1])) scheme_wrong_contract(s_name, sec_t, 1, argc, argv); \
o = scheme_op(argc, argv); \
if (!SCHEME_INTP(o)) scheme_non_fixnum_result(s_name, o); \
o = argv[0]; \
for (i = 1; i < argc; i++) { \
if (!sec_p(argv[i])) scheme_wrong_contract(s_name, sec_t, i, argc, argv); \
argv[0] = o; \
argv[1] = argv[i]; \
o = scheme_op(2, argv); \
if (!SCHEME_INTP(o)) scheme_non_fixnum_result(s_name, o); \
} \
return o; \
}
SAFE_FX(fx_and, "fxand", scheme_bitwise_and, SCHEME_INTP, "fixnum?")
SAFE_FX(fx_or, "fxior", bitwise_or, SCHEME_INTP, "fixnum?")
SAFE_FX(fx_xor, "fxxor", bitwise_xor, SCHEME_INTP, "fixnum?")
SAFE_FX(fx_and, "fxand", scheme_bitwise_and, SCHEME_INTP, "fixnum?", scheme_make_integer(-1))
SAFE_FX(fx_or, "fxior", bitwise_or, SCHEME_INTP, "fixnum?", scheme_make_integer(0))
SAFE_FX(fx_xor, "fxxor", bitwise_xor, SCHEME_INTP, "fixnum?", scheme_make_integer(0))
#ifdef SIXTY_FOUR_BIT_INTEGERS
# define FIXNUM_WIDTH_P(v) (SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0) && (SCHEME_INT_VAL(v) <= 64))
@ -5276,8 +5289,8 @@ SAFE_FX(fx_xor, "fxxor", bitwise_xor, SCHEME_INTP, "fixnum?")
# define FIXNUM_WIDTH_TYPE "(integer-in 0 31)"
#endif
SAFE_FX(fx_lshift, "fxlshift", scheme_bitwise_shift, FIXNUM_WIDTH_P, FIXNUM_WIDTH_TYPE)
SAFE_FX(fx_rshift, "fxrshift", neg_bitwise_shift, FIXNUM_WIDTH_P, FIXNUM_WIDTH_TYPE)
SAFE_FX(fx_lshift, "fxlshift", scheme_bitwise_shift, FIXNUM_WIDTH_P, FIXNUM_WIDTH_TYPE, scheme_false)
SAFE_FX(fx_rshift, "fxrshift", neg_bitwise_shift, FIXNUM_WIDTH_P, FIXNUM_WIDTH_TYPE, scheme_false)
static Scheme_Object *fx_not (int argc, Scheme_Object *argv[])
{
@ -5475,20 +5488,25 @@ static Scheme_Object *fold_fixnum_bitwise_shift(int argc, Scheme_Object *argv[])
}
}
#define UNSAFE_FX(name, op, fold, type) \
#define UNSAFE_FX(name, op, fold, type, no_args) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
intptr_t v; \
intptr_t v; \
int i; \
if (!argc) return no_args; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
v = (type)SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1]); \
v = (type)SCHEME_INT_VAL(argv[0]); \
for (i = 1; i < argc; i++) { \
v = v op SCHEME_INT_VAL(argv[i]); \
} \
return scheme_make_integer(v); \
}
UNSAFE_FX(unsafe_fx_and, &, scheme_bitwise_and, intptr_t)
UNSAFE_FX(unsafe_fx_or, |, bitwise_or, intptr_t)
UNSAFE_FX(unsafe_fx_xor, ^, bitwise_xor, intptr_t)
UNSAFE_FX(unsafe_fx_lshift, <<, fold_fixnum_bitwise_shift, uintptr_t)
UNSAFE_FX(unsafe_fx_rshift, >>, neg_bitwise_shift, intptr_t)
UNSAFE_FX(unsafe_fx_and, &, scheme_bitwise_and, intptr_t, scheme_make_integer(-1))
UNSAFE_FX(unsafe_fx_or, |, bitwise_or, intptr_t, scheme_make_integer(0))
UNSAFE_FX(unsafe_fx_xor, ^, bitwise_xor, intptr_t, scheme_make_integer(0))
UNSAFE_FX(unsafe_fx_lshift, <<, fold_fixnum_bitwise_shift, uintptr_t, scheme_false)
UNSAFE_FX(unsafe_fx_rshift, >>, neg_bitwise_shift, intptr_t, scheme_false)
static Scheme_Object *unsafe_fx_not (int argc, Scheme_Object *argv[])
{

267
racket/src/racket/src/numcomp.c
View File

@ -102,7 +102,7 @@ void scheme_init_numcomp(Scheme_Startup_Env *env)
{
Scheme_Object *p;
p = scheme_make_folding_prim(eq, "=", 2, -1, 1);
p = scheme_make_folding_prim(eq, "=", 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_WANTS_NUMBER
@ -111,7 +111,7 @@ void scheme_init_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("=", p, env);
p = scheme_make_folding_prim(lt, "<", 2, -1, 1);
p = scheme_make_folding_prim(lt, "<", 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_WANTS_REAL
@ -120,7 +120,7 @@ void scheme_init_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("<", p, env);
p = scheme_make_folding_prim(gt, ">", 2, -1, 1);
p = scheme_make_folding_prim(gt, ">", 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_WANTS_REAL
@ -129,7 +129,7 @@ void scheme_init_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance(">", p, env);
p = scheme_make_folding_prim(lt_eq, "<=", 2, -1, 1);
p = scheme_make_folding_prim(lt_eq, "<=", 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_WANTS_REAL
@ -138,7 +138,7 @@ void scheme_init_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("<=", p, env);
p = scheme_make_folding_prim(gt_eq, ">=", 2, -1, 1);
p = scheme_make_folding_prim(gt_eq, ">=", 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_WANTS_REAL
@ -192,39 +192,44 @@ void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env)
Scheme_Object *p;
int flags;
p = scheme_make_folding_prim(fx_eq, "fx=", 2, 2, 1);
p = scheme_make_folding_prim(fx_eq, "fx=", 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_AD_HOC_OPT
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("fx=", p, env);
p = scheme_make_folding_prim(fx_lt, "fx<", 2, 2, 1);
p = scheme_make_folding_prim(fx_lt, "fx<", 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_AD_HOC_OPT
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("fx<", p, env);
p = scheme_make_folding_prim(fx_gt, "fx>", 2, 2, 1);
p = scheme_make_folding_prim(fx_gt, "fx>", 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_AD_HOC_OPT
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("fx>", p, env);
p = scheme_make_folding_prim(fx_lt_eq, "fx<=", 2, 2, 1);
p = scheme_make_folding_prim(fx_lt_eq, "fx<=", 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_AD_HOC_OPT
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("fx<=", p, env);
p = scheme_make_folding_prim(fx_gt_eq, "fx>=", 2, 2, 1);
p = scheme_make_folding_prim(fx_gt_eq, "fx>=", 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_AD_HOC_OPT
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("fx>=", p, env);
p = scheme_make_folding_prim(fx_min, "fxmin", 2, 2, 1);
p = scheme_make_folding_prim(fx_min, "fxmin", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -232,9 +237,9 @@ void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fxmin", p, env);
p = scheme_make_folding_prim(fx_max, "fxmax", 2, 2, 1);
p = scheme_make_folding_prim(fx_max, "fxmax", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -243,54 +248,54 @@ void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env)
scheme_addto_prim_instance("fxmax", p, env);
p = scheme_make_folding_prim(fl_eq, "fl=", 2, 2, 1);
p = scheme_make_folding_prim(fl_eq, "fl=", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("fl=", p, env);
p = scheme_make_folding_prim(fl_lt, "fl<", 2, 2, 1);
p = scheme_make_folding_prim(fl_lt, "fl<", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("fl<", p, env);
p = scheme_make_folding_prim(fl_gt, "fl>", 2, 2, 1);
p = scheme_make_folding_prim(fl_gt, "fl>", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("fl>", p, env);
p = scheme_make_folding_prim(fl_lt_eq, "fl<=", 2, 2, 1);
p = scheme_make_folding_prim(fl_lt_eq, "fl<=", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("fl<=", p, env);
p = scheme_make_folding_prim(fl_gt_eq, "fl>=", 2, 2, 1);
p = scheme_make_folding_prim(fl_gt_eq, "fl>=", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("fl>=", p, env);
p = scheme_make_folding_prim(fl_min, "flmin", 2, 2, 1);
p = scheme_make_folding_prim(fl_min, "flmin", 1, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -298,9 +303,9 @@ void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("flmin", p, env);
p = scheme_make_folding_prim(fl_max, "flmax", 2, 2, 1);
p = scheme_make_folding_prim(fl_max, "flmax", 1, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -386,59 +391,66 @@ void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env)
int flags;
REGISTER_SO(scheme_unsafe_fx_eq_proc);
p = scheme_make_folding_prim(unsafe_fx_eq, "unsafe-fx=", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_eq, "unsafe-fx=", 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-fx=", p, env);
scheme_unsafe_fx_eq_proc = p;
REGISTER_SO(scheme_unsafe_fx_lt_proc);
p = scheme_make_folding_prim(unsafe_fx_lt, "unsafe-fx<", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_lt, "unsafe-fx<", 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-fx<", p, env);
scheme_unsafe_fx_lt_proc = p;
REGISTER_SO(scheme_unsafe_fx_gt_proc);
p = scheme_make_folding_prim(unsafe_fx_gt, "unsafe-fx>", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_gt, "unsafe-fx>", 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-fx>", p, env);
scheme_unsafe_fx_gt_proc = p;
REGISTER_SO(scheme_unsafe_fx_lt_eq_proc);
p = scheme_make_folding_prim(unsafe_fx_lt_eq, "unsafe-fx<=", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_lt_eq, "unsafe-fx<=", 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-fx<=", p, env);
scheme_unsafe_fx_lt_eq_proc = p;
REGISTER_SO(scheme_unsafe_fx_gt_eq_proc);
p = scheme_make_folding_prim(unsafe_fx_gt_eq, "unsafe-fx>=", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_gt_eq, "unsafe-fx>=", 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-fx>=", p, env);
scheme_unsafe_fx_gt_eq_proc = p;
REGISTER_SO(scheme_unsafe_fx_min_proc);
p = scheme_make_folding_prim(unsafe_fx_min, "unsafe-fxmin", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_min, "unsafe-fxmin", 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_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fxmin", p, env);
scheme_unsafe_fx_min_proc = p;
REGISTER_SO(scheme_unsafe_fx_max_proc);
p = scheme_make_folding_prim(unsafe_fx_max, "unsafe-fxmax", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fx_max, "unsafe-fxmax", 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_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fxmax", p, env);
scheme_unsafe_fx_max_proc = p;
p = scheme_make_folding_prim(unsafe_fl_eq, "unsafe-fl=", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_eq, "unsafe-fl=", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -446,9 +458,9 @@ void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("unsafe-fl=", p, env);
p = scheme_make_folding_prim(unsafe_fl_lt, "unsafe-fl<", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_lt, "unsafe-fl<", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -456,9 +468,9 @@ void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("unsafe-fl<", p, env);
p = scheme_make_folding_prim(unsafe_fl_gt, "unsafe-fl>", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_gt, "unsafe-fl>", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -466,9 +478,9 @@ void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("unsafe-fl>", p, env);
p = scheme_make_folding_prim(unsafe_fl_lt_eq, "unsafe-fl<=", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_lt_eq, "unsafe-fl<=", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -476,9 +488,9 @@ void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("unsafe-fl<=", p, env);
p = scheme_make_folding_prim(unsafe_fl_gt_eq, "unsafe-fl>=", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_gt_eq, "unsafe-fl>=", 1, -1, 1);
if (scheme_can_inline_fp_comp())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -486,9 +498,9 @@ void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("unsafe-fl>=", p, env);
p = scheme_make_folding_prim(unsafe_fl_min, "unsafe-flmin", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_min, "unsafe-flmin", 1, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -497,9 +509,9 @@ void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env)
| SCHEME_PRIM_WANTS_FLONUM_BOTH);
scheme_addto_prim_instance("unsafe-flmin", p, env);
p = scheme_make_folding_prim(unsafe_fl_max, "unsafe-flmax", 2, 2, 1);
p = scheme_make_folding_prim(unsafe_fl_max, "unsafe-flmax", 1, -1, 1);
if (scheme_can_inline_fp_op())
flags = SCHEME_PRIM_IS_BINARY_INLINED;
flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
@ -794,63 +806,94 @@ GEN_TWOARY_OP(static, sch_min, "min", bin_min, SCHEME_REALP, "real?")
/* Flfx */
/************************************************************************/
#define SAFE_FX_X(name, s_name, op, T, F) \
#define SAFE_FX_X(name, s_name, op, T, F, result_init, loop_arg, loop_F) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (!SCHEME_INTP(argv[0])) scheme_wrong_contract(s_name, "fixnum?", 0, argc, argv); \
if (!SCHEME_INTP(argv[1])) scheme_wrong_contract(s_name, "fixnum?", 1, argc, argv); \
if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
return T; \
else \
return F; \
if (argc == 2) { \
if (!SCHEME_INTP(argv[1])) scheme_wrong_contract(s_name, "fixnum?", 1, argc, argv); \
if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
return T; \
else \
return F; \
} else { \
int i; \
Scheme_Object *result = result_init; \
for (i = 1; i < argc; i++) { \
if (!SCHEME_INTP(argv[i])) scheme_wrong_contract(s_name, "fixnum?", i, argc, argv); \
if (!(SCHEME_INT_VAL(loop_arg) op SCHEME_INT_VAL(argv[i]))) \
result = loop_F; \
} \
return result; \
} \
}
#define SAFE_FX(name, s_name, op) SAFE_FX_X(name, s_name, op, scheme_true, scheme_false)
#define SAFE_FX(name, s_name, op) SAFE_FX_X(name, s_name, op, scheme_true, scheme_false, scheme_true, argv[i-1], scheme_false)
SAFE_FX(fx_eq, "fx=", ==)
SAFE_FX(fx_lt, "fx<", <)
SAFE_FX(fx_gt, "fx>", >)
SAFE_FX(fx_lt_eq, "fx<=", <=)
SAFE_FX(fx_gt_eq, "fx>=", >=)
SAFE_FX_X(fx_min, "fxmin", <, argv[0], argv[1])
SAFE_FX_X(fx_max, "fxmax", >, argv[0], argv[1])
SAFE_FX_X(fx_min, "fxmin", <, argv[0], argv[1], argv[0], result, argv[i])
SAFE_FX_X(fx_max, "fxmax", >, argv[0], argv[1], argv[0], result, argv[i])
#define UNSAFE_FX_X(name, op, fold, T, F, SEL) \
#define UNSAFE_FX_X(name, op, fold, T, F, result_init, loop_arg, loop_F) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (scheme_current_thread->constant_folding) return SEL(fold(argv[0], argv[1])); \
if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
return T; \
else \
return F; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
if (argc == 2) { \
if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
return T; \
else \
return F; \
} else { \
int i; \
Scheme_Object *result = result_init; \
for (i = 1; i < argc; i++) { \
if (!(SCHEME_INT_VAL(loop_arg) op SCHEME_INT_VAL(argv[i]))) \
result = loop_F; \
} \
return result; \
} \
}
#define FX_SEL_BOOLEAN(e) (e ? scheme_true : scheme_false)
#define UNSAFE_FX(name, op, fold) UNSAFE_FX_X(name, op, fold, scheme_true, scheme_false, FX_SEL_BOOLEAN)
#define UNSAFE_FX(name, op, fold) UNSAFE_FX_X(name, op, fold, scheme_true, scheme_false, scheme_true, argv[i-1], scheme_false)
UNSAFE_FX(unsafe_fx_eq, ==, scheme_bin_eq)
UNSAFE_FX(unsafe_fx_lt, <, scheme_bin_lt)
UNSAFE_FX(unsafe_fx_gt, >, scheme_bin_gt)
UNSAFE_FX(unsafe_fx_lt_eq, <=, scheme_bin_lt_eq)
UNSAFE_FX(unsafe_fx_gt_eq, >=, scheme_bin_gt_eq)
UNSAFE_FX(unsafe_fx_eq, ==, eq)
UNSAFE_FX(unsafe_fx_lt, <, lt)
UNSAFE_FX(unsafe_fx_gt, >, gt)
UNSAFE_FX(unsafe_fx_lt_eq, <=, lt_eq)
UNSAFE_FX(unsafe_fx_gt_eq, >=, gt_eq)
#define FX_SEL_ID(e) e
UNSAFE_FX_X(unsafe_fx_min, <, bin_min, argv[0], argv[1], FX_SEL_ID)
UNSAFE_FX_X(unsafe_fx_max, >, bin_max, argv[0], argv[1], FX_SEL_ID)
UNSAFE_FX_X(unsafe_fx_min, <, sch_min, argv[0], argv[1], argv[0], result, argv[i])
UNSAFE_FX_X(unsafe_fx_max, >, sch_max, argv[0], argv[1], argv[0], result, argv[i])
#define SAFE_FL_X(name, sname, op, T, F, PRE_CHECK) \
#define SAFE_FL_X(name, s_name, op, T, F, PRE_CHECK, result_init, loop_arg, loop_F, LOOP_PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (!SCHEME_DBLP(argv[0])) scheme_wrong_contract(sname, "flonum?", 0, argc, argv); \
if (!SCHEME_DBLP(argv[1])) scheme_wrong_contract(sname, "flonum?", 1, argc, argv); \
PRE_CHECK \
if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
return T; \
else \
return F; \
if (!SCHEME_DBLP(argv[0])) scheme_wrong_contract(s_name, "flonum?", 0, argc, argv); \
if (argc == 2) { \
if (!SCHEME_DBLP(argv[1])) scheme_wrong_contract(s_name, "flonum?", 1, argc, argv); \
PRE_CHECK \
if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
return T; \
else \
return F; \
} else { \
int i; \
Scheme_Object *result = result_init; \
for (i = 1; i < argc; i++) { \
if (!SCHEME_DBLP(argv[i])) scheme_wrong_contract(s_name, "flonum?", i, argc, argv); \
LOOP_PRE_CHECK \
if (!(SCHEME_DBL_VAL(loop_arg) op SCHEME_DBL_VAL(argv[i]))) \
result = loop_F; \
} \
return result; \
} \
}
#define SAFE_FL(name, sname, op) SAFE_FL_X(name, sname, op, scheme_true, scheme_false, ;)
#define SAFE_FL(name, sname, op) SAFE_FL_X(name, sname, op, scheme_true, scheme_false, ;, scheme_true, argv[i-1], scheme_false, ;)
SAFE_FL(fl_eq, "fl=", ==)
SAFE_FL(fl_lt, "fl<", <)
@ -858,42 +901,44 @@ SAFE_FL(fl_gt, "fl>", >)
SAFE_FL(fl_lt_eq, "fl<=", <=)
SAFE_FL(fl_gt_eq, "fl>=", >=)
#define CHECK_ARGV0_NAN { if (MZ_IS_NAN(SCHEME_DBL_VAL(argv[0]))) return argv[0]; }
#define CHECK_ARGV0_NAN { if (MZ_IS_NAN(SCHEME_DBL_VAL(argv[0])) || MZ_IS_NAN(SCHEME_DBL_VAL(argv[1]))) return scheme_nan_object; }
#define CHECK_ARGVi_NAN if (MZ_IS_NAN(SCHEME_DBL_VAL(result)) || MZ_IS_NAN(SCHEME_DBL_VAL(argv[i]))) { result = scheme_nan_object; } else
SAFE_FL_X(fl_min, "flmin", <, argv[0], argv[1], CHECK_ARGV0_NAN)
SAFE_FL_X(fl_max, "flmax", >, argv[0], argv[1], CHECK_ARGV0_NAN)
SAFE_FL_X(fl_min, "flmin", <, argv[0], argv[1], CHECK_ARGV0_NAN, argv[0], result, argv[i], CHECK_ARGVi_NAN)
SAFE_FL_X(fl_max, "flmax", >, argv[0], argv[1], CHECK_ARGV0_NAN, argv[0], result, argv[i], CHECK_ARGVi_NAN)
/* Unsafe FL comparisons. Return boolean */
#define UNSAFE_FL_COMP(name, op, fold) \
#define UNSAFE_FL_X(name, op, fold, T, F, PRE_CHECK, result_init, loop_arg, loop_F, LOOP_PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \
if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
return scheme_true; \
else \
return scheme_false; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
if (argc == 2) { \
PRE_CHECK \
if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
return T; \
else \
return F; \
} else { \
int i; \
Scheme_Object *result = result_init; \
for (i = 1; i < argc; i++) { \
LOOP_PRE_CHECK \
if (!(SCHEME_DBL_VAL(loop_arg) op SCHEME_DBL_VAL(argv[i]))) \
result = loop_F; \
} \
return result; \
} \
}
/* Unsafe FL binary operators. Return flonum */
#define UNSAFE_FL_BINOP(name, op, fold, T, F, PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1])); \
PRE_CHECK \
if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
return T; \
else \
return F; \
}
#define UNSAFE_FL_COMP(name, op, fold) UNSAFE_FL_X(name, op, fold, scheme_true, scheme_false, ;, scheme_true, argv[i-1], scheme_false, ;)
UNSAFE_FL_COMP(unsafe_fl_eq, ==, scheme_bin_eq)
UNSAFE_FL_COMP(unsafe_fl_lt, <, scheme_bin_lt)
UNSAFE_FL_COMP(unsafe_fl_gt, >, scheme_bin_gt)
UNSAFE_FL_COMP(unsafe_fl_lt_eq, <=, scheme_bin_lt_eq)
UNSAFE_FL_COMP(unsafe_fl_gt_eq, >=, scheme_bin_gt_eq)
UNSAFE_FL_COMP(unsafe_fl_eq, ==, eq)
UNSAFE_FL_COMP(unsafe_fl_lt, <, lt)
UNSAFE_FL_COMP(unsafe_fl_gt, >, gt)
UNSAFE_FL_COMP(unsafe_fl_lt_eq, <=, lt_eq)
UNSAFE_FL_COMP(unsafe_fl_gt_eq, >=, gt_eq)
UNSAFE_FL_BINOP(unsafe_fl_min, <, bin_min, argv[0], argv[1], CHECK_ARGV0_NAN)
UNSAFE_FL_BINOP(unsafe_fl_max, >, bin_max, argv[0], argv[1], CHECK_ARGV0_NAN)
UNSAFE_FL_X(unsafe_fl_min, <, sch_min, argv[0], argv[1], CHECK_ARGV0_NAN, argv[0], result, argv[i], CHECK_ARGVi_NAN)
UNSAFE_FL_X(unsafe_fl_max, >, sch_max, argv[0], argv[1], CHECK_ARGV0_NAN, argv[0], result, argv[i], CHECK_ARGVi_NAN)
#ifdef MZ_LONG_DOUBLE
# define SAFE_EXTFL_X(name, sname, op, T, F, PRE_CHECK) \

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

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

40
racket/src/racket/src/string.c
View File

@ -346,7 +346,7 @@ scheme_init_string (Scheme_Startup_Env *env)
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("string-set!", p, env);
p = scheme_make_immed_prim(string_eq, "string=?", 2, -1);
p = scheme_make_immed_prim(string_eq, "string=?", 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);
@ -355,77 +355,77 @@ scheme_init_string (Scheme_Startup_Env *env)
scheme_addto_prim_instance("string-locale=?",
scheme_make_immed_prim(string_locale_eq,
"string-locale=?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-ci=?",
scheme_make_immed_prim(string_ci_eq,
"string-ci=?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-locale-ci=?",
scheme_make_immed_prim(string_locale_ci_eq,
"string-locale-ci=?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string<?",
scheme_make_immed_prim(string_lt,
"string<?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-locale<?",
scheme_make_immed_prim(string_locale_lt,
"string-locale<?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string>?",
scheme_make_immed_prim(string_gt,
"string>?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-locale>?",
scheme_make_immed_prim(string_locale_gt,
"string-locale>?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string<=?",
scheme_make_immed_prim(string_lt_eq,
"string<=?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string>=?",
scheme_make_immed_prim(string_gt_eq,
"string>=?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-ci<?",
scheme_make_immed_prim(string_ci_lt,
"string-ci<?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-locale-ci<?",
scheme_make_immed_prim(string_locale_ci_lt,
"string-locale-ci<?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-ci>?",
scheme_make_immed_prim(string_ci_gt,
"string-ci>?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-locale-ci>?",
scheme_make_immed_prim(string_locale_ci_gt,
"string-locale-ci>?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-ci<=?",
scheme_make_immed_prim(string_ci_lt_eq,
"string-ci<=?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("string-ci>=?",
scheme_make_immed_prim(string_ci_gt_eq,
"string-ci>=?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("substring",
@ -631,7 +631,7 @@ scheme_init_string (Scheme_Startup_Env *env)
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("bytes-set!", p, env);
p = scheme_make_immed_prim(byte_string_eq, "bytes=?", 2, -1);
p = scheme_make_immed_prim(byte_string_eq, "bytes=?", 1, -1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("bytes=?", p, env);
@ -639,12 +639,12 @@ scheme_init_string (Scheme_Startup_Env *env)
scheme_addto_prim_instance("bytes<?",
scheme_make_immed_prim(byte_string_lt,
"bytes<?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("bytes>?",
scheme_make_immed_prim(byte_string_gt,
"bytes>?",
2, -1),
1, -1),
env);
scheme_addto_prim_instance("subbytes",
@ -823,7 +823,7 @@ scheme_init_string (Scheme_Startup_Env *env)
scheme_addto_prim_instance("path<?",
scheme_make_immed_prim(path_lt,
"path<?",
2, -1),
1, -1),
env);
#ifdef MZ_PRECISE_GC

4
racket/src/racket/src/symbol.c
View File

@ -348,7 +348,7 @@ scheme_init_symbol (Scheme_Startup_Env *env)
| SCHEME_PRIM_PRODUCES_BOOL);
scheme_addto_prim_instance("symbol-interned?", p, env);
ADD_FOLDING_PRIM("symbol<?", symbol_lt, 2, -1, 1, env);
ADD_FOLDING_PRIM("symbol<?", symbol_lt, 1, -1, 1, env);
p = scheme_make_folding_prim(string_to_symbol_prim, "string->symbol", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
@ -369,7 +369,7 @@ scheme_init_symbol (Scheme_Startup_Env *env)
scheme_keyword_p_proc = p;
scheme_addto_prim_instance("keyword?", p, env);
ADD_FOLDING_PRIM("keyword<?", keyword_lt, 2, -1, 1, env);
ADD_FOLDING_PRIM("keyword<?", keyword_lt, 1, -1, 1, env);
p = scheme_make_folding_prim(string_to_keyword_prim, "string->keyword", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);