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

fix contract checks for number <-> representation bytes

Browse Source 
... especially for CS, but there's also one BC correction.

Reported in tweet by KenHatesSoftwar.
This commit is contained in:
Matthew Flatt 2021-05-03 20:01:37 -06:00
parent 9a65aaf444
commit d777cd28d7
3 changed files with 79 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3331,28 +3331,30 @@
(test (make-bytes (- 11 3 sz) (char->integer #\x)) subbytes bstr (+ 3 sz)) (test (make-bytes (- 11 3 sz) (char->integer #\x)) subbytes bstr (+ 3 sz))
(subbytes bstr 3 (+ 3 sz))))) (subbytes bstr 3 (+ 3 sz)))))
(define rx:out-of-bounds #rx"number is out of bounds for size in bytes|integer does not fit into requested")
(arity-test integer->integer-bytes 3 6) (arity-test integer->integer-bytes 3 6)
(err/rt-test (integer->integer-bytes 'ack 2 #t)) (err/rt-test (integer->integer-bytes 'ack 2 #t) exn:fail:contract? #rx"exact-integer")
(err/rt-test (integer->integer-bytes 10 'ack #t)) (err/rt-test (integer->integer-bytes 10 'ack #t) exn:fail:contract? #rx"(or/c 1 2 4 8)")
(err/rt-test (integer->integer-bytes 10 20 #t)) (err/rt-test (integer->integer-bytes 10 20 #t) exn:fail:contract? #rx"(or/c 1 2 4 8)")
(err/rt-test (integer->integer-bytes 10 2 #t #t 'ack)) (err/rt-test (integer->integer-bytes 10 2 #t #t 'ack) exn:fail:contract? #rx"bytes[?]")
(err/rt-test (integer->integer-bytes 10 2 #t #t #"ack")) ; <-- immutable string (err/rt-test (integer->integer-bytes 10 2 #t #t #"ack") exn:fail:contract? #rx"mutable")
(err/rt-test (integer->integer-bytes 256 1 #t) exn:application:mismatch?) (err/rt-test (integer->integer-bytes 256 1 #t) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes -129 1 #t) exn:application:mismatch?) (err/rt-test (integer->integer-bytes -129 1 #t) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes 257 1 #f) exn:application:mismatch?) (err/rt-test (integer->integer-bytes 257 1 #f) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes -1 1 #f) exn:application:mismatch?) (err/rt-test (integer->integer-bytes -1 1 #f) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes 100000 2 #t) exn:application:mismatch?) (err/rt-test (integer->integer-bytes 100000 2 #t) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes 65536 2 #f) exn:application:mismatch?) (err/rt-test (integer->integer-bytes 65536 2 #f) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes 32768 2 #t) exn:application:mismatch?) (err/rt-test (integer->integer-bytes 32768 2 #t) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes -32769 2 #t) exn:application:mismatch?) (err/rt-test (integer->integer-bytes -32769 2 #t) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes (expt 2 32) 4 #f) exn:application:mismatch?) (err/rt-test (integer->integer-bytes (expt 2 32) 4 #f) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes (expt 2 31) 4 #t) exn:application:mismatch?) (err/rt-test (integer->integer-bytes (expt 2 31) 4 #t) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes (sub1 (- (expt 2 31))) 4 #t) exn:application:mismatch?) (err/rt-test (integer->integer-bytes (sub1 (- (expt 2 31))) 4 #t) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes (expt 2 64) 8 #f) exn:application:mismatch?) (err/rt-test (integer->integer-bytes (expt 2 64) 8 #f) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes (expt 2 63) 4 #t) exn:application:mismatch?) (err/rt-test (integer->integer-bytes (expt 2 63) 4 #t) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes (sub1 (- (expt 2 63))) 8 #t) exn:application:mismatch?) (err/rt-test (integer->integer-bytes (sub1 (- (expt 2 63))) 8 #t) exn:application:mismatch? rx:out-of-bounds)
(err/rt-test (integer->integer-bytes 100 4 #t #t (make-bytes 3)) exn:application:mismatch?) (err/rt-test (integer->integer-bytes 100 4 #t #t (make-bytes 3)) exn:application:mismatch? #rx"byte string length is shorter|byte string is too small")
(err/rt-test (integer->integer-bytes 100 2 #t #t (make-bytes 3) 2) exn:application:mismatch?) (err/rt-test (integer->integer-bytes 100 2 #t #t (make-bytes 3) 2) exn:application:mismatch? #rx"byte string length is shorter|starting position too large")
(map (lambda (v) (map (lambda (v)
(let-values ([(n size signed?) (apply values v)]) (let-values ([(n size signed?) (apply values v)])
@ -3378,6 +3380,16 @@
(test s integer->integer-bytes n 4 #f #f s) (test s integer->integer-bytes n 4 #f #f s)
(test s integer->integer-bytes n 4 #f #f)) (test s integer->integer-bytes n 4 #f #f))
(err/rt-test (integer-bytes->integer #f #f) exn:fail:contract? #rx"bytes[?]")
(err/rt-test (integer-bytes->integer #"" #f) exn:fail:contract? #rx"1, 2, 4, or 8")
(err/rt-test (integer-bytes->integer #"1234" #f #f -1) exn:fail:contract? #rx"exact-nonnegative-integer[?]")
(err/rt-test (integer-bytes->integer #"1234" #f #f 'oops) exn:fail:contract? #rx"exact-nonnegative-integer[?]")
(err/rt-test (integer-bytes->integer #"1234" #f #f 2 'oops) exn:fail:contract? #rx"exact-nonnegative-integer[?]")
(err/rt-test (integer-bytes->integer #"1234" #f #f 1) exn:fail:contract? #rx"1, 2, 4, or 8")
(err/rt-test (integer-bytes->integer #"1234" #f #f 1 4) exn:fail:contract? #rx"1, 2, 4, or 8")
(err/rt-test (integer-bytes->integer #"1234" #f #f 6 8) exn:fail:contract? #rx"starting index is out of range")
(err/rt-test (integer-bytes->integer #"1234" #f #f 0 8) exn:fail:contract? #rx"ending index is out of range")
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Used for comparison after loss of precision in 4-byte conversion ;; Used for comparison after loss of precision in 4-byte conversion
@ -3427,12 +3439,23 @@
(test s real->floating-point-bytes n 8 #f s) (test s real->floating-point-bytes n 8 #f s)
(test s real->floating-point-bytes n 8 #f)) (test s real->floating-point-bytes n 8 #f))
(err/rt-test (real->floating-point-bytes 1 -4)) (err/rt-test (real->floating-point-bytes 1 -4) exn:fail:contract? #rx"[(]or/c 4 8[)]")
(err/rt-test (real->floating-point-bytes 1 7)) (err/rt-test (real->floating-point-bytes 1 7))
(err/rt-test (real->floating-point-bytes 1 7000000000000000000000000)) (err/rt-test (real->floating-point-bytes 1 7000000000000000000000000))
(err/rt-test (real->floating-point-bytes 1+2i 8)) (err/rt-test (real->floating-point-bytes 1+2i 8))
(err/rt-test (real->floating-point-bytes 1.0+2.0i 8)) (err/rt-test (real->floating-point-bytes 1.0+2.0i 8))
(err/rt-test (real->floating-point-bytes 1.0 8 #f (make-bytes 7)) exn:application:mismatch?) (err/rt-test (real->floating-point-bytes 1.0 8 #f (make-bytes 7)) exn:application:mismatch?
#rx"byte string length is shorter than starting position plus size")
(err/rt-test (floating-point-bytes->real #f) exn:fail:contract? "bytes")
(err/rt-test (floating-point-bytes->real #f #t) exn:fail:contract? "bytes")
(err/rt-test (floating-point-bytes->real #f #t 0) exn:fail:contract? "bytes")
(err/rt-test (floating-point-bytes->real #f #t 0 2) exn:fail:contract? "bytes")
(err/rt-test (floating-point-bytes->real #"12") exn:fail:contract? "4 or 8")
(err/rt-test (floating-point-bytes->real #"12" #t 3) exn:fail:contract? "starting index is out of range")
(err/rt-test (floating-point-bytes->real #"12" #t 0 2) exn:fail:contract? "4 or 8")
(err/rt-test (floating-point-bytes->real #"12" #t 1 5) exn:fail:contract? "ending index is out of range")
(err/rt-test (floating-point-bytes->real #"1234" #t 1 4) exn:fail:contract? "4 or 8")
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check single-flonum coercisons: ;; Check single-flonum coercisons:

2
racket/src/bc/src/numstr.c
View File

@ -2558,7 +2558,7 @@ static Scheme_Object *bytes_to_real (int argc, Scheme_Object *argv[])
if ((slen != 4) && (slen != 8)) if ((slen != 4) && (slen != 8))
scheme_contract_error("floating-point-bytes->real", scheme_contract_error("floating-point-bytes->real",
"length is not 2, 4, or 8 bytes", "length is not 4 or 8 bytes",
"length", 1, scheme_make_integer(slen), "length", 1, scheme_make_integer(slen),
NULL); NULL);

54
racket/src/cs/rumble/number.ss
View File

@ -156,6 +156,7 @@
(define/who integer->integer-bytes (define/who integer->integer-bytes
(case-lambda (case-lambda
[(num size signed? big-endian? bstr start) [(num size signed? big-endian? bstr start)
(check who exact-integer? num)
(let ([check (lambda (n lo hi) (let ([check (lambda (n lo hi)
(check who bytes? bstr) (check who bytes? bstr)
(check who exact-nonnegative-integer? start) (check who exact-nonnegative-integer? start)
@ -201,7 +202,7 @@
[(4) [(4)
(if signed? (if signed?
(check 4 -2147483648 2147483647) (check 4 -2147483648 2147483647)
(check 4 0 8589934591)) (check 4 0 4294967295))
(if signed? (if signed?
(bytevector-s32-set! bstr start num (if big-endian? (bytevector-s32-set! bstr start num (if big-endian?
(endianness big) (endianness big)
@ -239,8 +240,13 @@
(check who bytes? bstr) (check who bytes? bstr)
(check who exact-nonnegative-integer? start) (check who exact-nonnegative-integer? start)
(check who exact-nonnegative-integer? end) (check who exact-nonnegative-integer? end)
(unless (memq (- end start) '(1 2 4 8))
(raise-arguments-error who
"length is not 1, 2, 4, or 8 bytes"
"length" (- end start)))
(check-range who "index" bstr start end (bytes-length bstr))
(case (- end start) (case (- end start)
[(1) [(1)
(if signed? (if signed?
(bytevector-s8-ref bstr start) (bytevector-s8-ref bstr start)
(bytevector-u8-ref bstr start))] (bytevector-u8-ref bstr start))]
@ -260,18 +266,14 @@
(bytevector-u32-ref bstr start (if big-endian? (bytevector-u32-ref bstr start (if big-endian?
(endianness big) (endianness big)
(endianness little))))] (endianness little))))]
[(8) [else
(if signed? (if signed?
(bytevector-s64-ref bstr start (if big-endian? (bytevector-s64-ref bstr start (if big-endian?
(endianness big) (endianness big)
(endianness little))) (endianness little)))
(bytevector-u64-ref bstr start (if big-endian? (bytevector-u64-ref bstr start (if big-endian?
(endianness big) (endianness big)
(endianness little))))] (endianness little))))])]
[else
(raise-arguments-error 'integer-bytes->integer
"length is not 1, 2, 4, or 8 bytes"
"length" (- end start))])]
[(bstr signed?) [(bstr signed?)
(integer-bytes->integer bstr signed? (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))] (integer-bytes->integer bstr signed? (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))]
[(bstr signed? big-endian?) [(bstr signed? big-endian?)
@ -282,19 +284,26 @@
(define/who real->floating-point-bytes (define/who real->floating-point-bytes
(case-lambda (case-lambda
[(num size big-endian? bstr start) [(num size big-endian? bstr start)
(check who bytes? bstr) (check who real? num)
(case size (check who (lambda (v) (or (eq? v 4) (eq? v 8))) :contract "(or/c 4 8)" size)
[(4) (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" bstr)
(check who exact-nonnegative-integer? start)
(check-range who "index" bstr start #f (bytes-length bstr))
(unless (>= (bytevector-length bstr) (+ start size))
(raise-arguments-error who
"byte string length is shorter than starting position plus size"
"byte string length" (bytevector-length bstr)
"starting position" start
"size" size))
(cond
[(eq? size 4)
(bytevector-ieee-single-set! bstr start num (if big-endian? (bytevector-ieee-single-set! bstr start num (if big-endian?
(endianness big) (endianness big)
(endianness little)))] (endianness little)))]
[(8) [else
(bytevector-ieee-double-set! bstr start num (if big-endian? (bytevector-ieee-double-set! bstr start num (if big-endian?
(endianness big) (endianness big)
(endianness little)))] (endianness little)))])
[else
(raise-argument-error 'real->floating-point-bytes
"(or/c 4 8)" size)])
bstr] bstr]
[(num size) [(num size)
(real->floating-point-bytes num size (system-big-endian?) (real->floating-point-bytes num size (system-big-endian?)
@ -311,19 +320,20 @@
(check who bytes? bstr) (check who bytes? bstr)
(check who exact-nonnegative-integer? start) (check who exact-nonnegative-integer? start)
(check who exact-nonnegative-integer? end) (check who exact-nonnegative-integer? end)
(check-range who "index" bstr start end (bytes-length bstr))
(unless (memq (- end start) '(4 8))
(raise-arguments-error who
"length is not 4 or 8 bytes"
"length" (- end start)))
(case (- end start) (case (- end start)
[(4) [(4)
(bytevector-ieee-single-ref bstr start (if big-endian? (bytevector-ieee-single-ref bstr start (if big-endian?
(endianness big) (endianness big)
(endianness little)))] (endianness little)))]
[(8) [else
(bytevector-ieee-double-ref bstr start (if big-endian? (bytevector-ieee-double-ref bstr start (if big-endian?
(endianness big) (endianness big)
(endianness little)))] (endianness little)))])]
[else
(raise-arguments-error who
"length is not 4 or 8 bytes"
"length" (- end start))])]
[(bstr) [(bstr)
(floating-point-bytes->real bstr (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))] (floating-point-bytes->real bstr (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))]
[(bstr big-endian?) [(bstr big-endian?)