From d777cd28d7504845b6d110d8c45b5981a2d80688 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 3 May 2021 20:01:37 -0600 Subject: [PATCH] fix contract checks for number <-> representation bytes ... especially for CS, but there's also one BC correction. Reported in tweet by KenHatesSoftwar. --- .../racket-test-core/tests/racket/number.rktl | 69 ++++++++++++------- racket/src/bc/src/numstr.c | 2 +- racket/src/cs/rumble/number.ss | 54 +++++++++------ 3 files changed, 79 insertions(+), 46 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/number.rktl b/pkgs/racket-test-core/tests/racket/number.rktl index 2f118c53f9..a597c11c2d 100644 --- a/pkgs/racket-test-core/tests/racket/number.rktl +++ b/pkgs/racket-test-core/tests/racket/number.rktl @@ -3331,28 +3331,30 @@ (test (make-bytes (- 11 3 sz) (char->integer #\x)) subbytes bstr (+ 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) -(err/rt-test (integer->integer-bytes 'ack 2 #t)) -(err/rt-test (integer->integer-bytes 10 'ack #t)) -(err/rt-test (integer->integer-bytes 10 20 #t)) -(err/rt-test (integer->integer-bytes 10 2 #t #t 'ack)) -(err/rt-test (integer->integer-bytes 10 2 #t #t #"ack")) ; <-- immutable string -(err/rt-test (integer->integer-bytes 256 1 #t) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes -129 1 #t) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes 257 1 #f) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes -1 1 #f) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes 100000 2 #t) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes 65536 2 #f) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes 32768 2 #t) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes -32769 2 #t) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes (expt 2 32) 4 #f) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes (expt 2 31) 4 #t) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes (sub1 (- (expt 2 31))) 4 #t) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes (expt 2 64) 8 #f) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes (expt 2 63) 4 #t) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes (sub1 (- (expt 2 63))) 8 #t) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes 100 4 #t #t (make-bytes 3)) exn:application:mismatch?) -(err/rt-test (integer->integer-bytes 100 2 #t #t (make-bytes 3) 2) exn:application:mismatch?) +(err/rt-test (integer->integer-bytes 'ack 2 #t) exn:fail:contract? #rx"exact-integer") +(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) exn:fail:contract? #rx"(or/c 1 2 4 8)") +(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") exn:fail:contract? #rx"mutable") +(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? rx:out-of-bounds) +(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? rx:out-of-bounds) +(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? rx:out-of-bounds) +(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? rx:out-of-bounds) +(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? rx:out-of-bounds) +(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? rx:out-of-bounds) +(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? rx:out-of-bounds) +(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? #rx"byte string length is shorter|starting position too large") (map (lambda (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)) +(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 @@ -3427,12 +3439,23 @@ (test s real->floating-point-bytes n 8 #f s) (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 7000000000000000000000000)) (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 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: diff --git a/racket/src/bc/src/numstr.c b/racket/src/bc/src/numstr.c index 785b7bf11f..720254c73a 100644 --- a/racket/src/bc/src/numstr.c +++ b/racket/src/bc/src/numstr.c @@ -2558,7 +2558,7 @@ static Scheme_Object *bytes_to_real (int argc, Scheme_Object *argv[]) if ((slen != 4) && (slen != 8)) 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), NULL); diff --git a/racket/src/cs/rumble/number.ss b/racket/src/cs/rumble/number.ss index 05e9fea585..370fb2becc 100644 --- a/racket/src/cs/rumble/number.ss +++ b/racket/src/cs/rumble/number.ss @@ -156,6 +156,7 @@ (define/who integer->integer-bytes (case-lambda [(num size signed? big-endian? bstr start) + (check who exact-integer? num) (let ([check (lambda (n lo hi) (check who bytes? bstr) (check who exact-nonnegative-integer? start) @@ -201,7 +202,7 @@ [(4) (if signed? (check 4 -2147483648 2147483647) - (check 4 0 8589934591)) + (check 4 0 4294967295)) (if signed? (bytevector-s32-set! bstr start num (if big-endian? (endianness big) @@ -239,8 +240,13 @@ (check who bytes? bstr) (check who exact-nonnegative-integer? start) (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) - [(1) + [(1) (if signed? (bytevector-s8-ref bstr start) (bytevector-u8-ref bstr start))] @@ -260,18 +266,14 @@ (bytevector-u32-ref bstr start (if big-endian? (endianness big) (endianness little))))] - [(8) + [else (if signed? (bytevector-s64-ref bstr start (if big-endian? (endianness big) (endianness little))) (bytevector-u64-ref bstr start (if big-endian? (endianness big) - (endianness little))))] - [else - (raise-arguments-error 'integer-bytes->integer - "length is not 1, 2, 4, or 8 bytes" - "length" (- end start))])] + (endianness little))))])] [(bstr signed?) (integer-bytes->integer bstr signed? (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))] [(bstr signed? big-endian?) @@ -282,19 +284,26 @@ (define/who real->floating-point-bytes (case-lambda [(num size big-endian? bstr start) - (check who bytes? bstr) - (case size - [(4) + (check who real? num) + (check who (lambda (v) (or (eq? v 4) (eq? v 8))) :contract "(or/c 4 8)" size) + (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? (endianness big) (endianness little)))] - [(8) + [else (bytevector-ieee-double-set! bstr start num (if big-endian? (endianness big) - (endianness little)))] - [else - (raise-argument-error 'real->floating-point-bytes - "(or/c 4 8)" size)]) + (endianness little)))]) bstr] [(num size) (real->floating-point-bytes num size (system-big-endian?) @@ -311,19 +320,20 @@ (check who bytes? bstr) (check who exact-nonnegative-integer? start) (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) [(4) (bytevector-ieee-single-ref bstr start (if big-endian? (endianness big) (endianness little)))] - [(8) + [else (bytevector-ieee-double-ref bstr start (if big-endian? (endianness big) - (endianness little)))] - [else - (raise-arguments-error who - "length is not 4 or 8 bytes" - "length" (- end start))])] + (endianness little)))])] [(bstr) (floating-point-bytes->real bstr (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))] [(bstr big-endian?)