diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 866108d921..0c6968e16e 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.5.0.14") +(define version "7.5.0.15") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl index ae1f88a1a1..4995cb23b2 100644 --- a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl +++ b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl @@ -310,12 +310,21 @@ always returns a fixnum).} @defproc[(unsafe-bytes-length [bstr bytes?]) fixnum?] @defproc[(unsafe-bytes-ref [bstr bytes?] [k fixnum?]) byte?] @defproc[(unsafe-bytes-set! [bstr (and/c bytes? (not/c immutable?))] [k fixnum?] [b byte?]) void?] +@defproc[(unsafe-bytes-copy! [dest (and/c bytes? (not/c immutable?))] + [dest-start fixnum?] + [src bytes?] + [src-start fixnum? 0] + [src-end fixnum? (bytes-length src)]) + void?] )]{ -Unsafe versions of @racket[bytes-length], @racket[bytes-ref], and -@racket[bytes-set!]. A bytes's size can never be larger than a +Unsafe versions of @racket[bytes-length], @racket[bytes-ref], +@racket[bytes-set!], and @racket[bytes-copy!]. +A bytes's size can never be larger than a @tech{fixnum} (so even @racket[bytes-length] always returns a -fixnum).} +fixnum). + +@history[#:changed "7.5.0.15" @elem{Added @racket[unsafe-bytes-copy!].}]} @deftogether[( diff --git a/pkgs/racket-test-core/tests/racket/basic.rktl b/pkgs/racket-test-core/tests/racket/basic.rktl index 41a78cccda..a7ee010554 100644 --- a/pkgs/racket-test-core/tests/racket/basic.rktl +++ b/pkgs/racket-test-core/tests/racket/basic.rktl @@ -1168,13 +1168,26 @@ (test (bytes 97 0 98) bytes-copy (bytes 97 0 98)) (bytes-fill! s (char->integer #\x)) (test #"xxxxx" 'bytes-fill! s) +(let ([bstr (make-bytes 10)]) + (test (void) bytes-copy! bstr 1 #"testing" 2 6) + (test #"\0stin\0\0\0\0\0" values bstr) + (test (void) bytes-copy! bstr 0 #"testing") + (test #"testing\0\0\0" values bstr)) (arity-test bytes-copy 1 1) (arity-test bytes-fill! 2 2) (err/rt-test (bytes-copy 'blah)) (err/rt-test (bytes-fill! 'sym 1)) (err/rt-test (bytes-fill! #"static" 1)) (err/rt-test (bytes-fill! (bytes-copy #"oops") #\5)) - +(err/rt-test (bytes-copy! (bytes-copy #"oops") #\5)) +(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 -1)) +(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" #f)) +(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" -1)) +(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" 1 #f)) +(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" 1 0)) +(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" 1 17)) +(err/rt-test (bytes-copy! (bytes-copy #"o") 0 #"src")) +(err/rt-test (bytes-copy! (bytes-copy #"o") 0 #"src" 1)) (test #t bytes=? #"a" #"a" #"a") (test #t bytes=? #"a" #"a") (test #t bytes=? #"a") diff --git a/pkgs/racket-test-core/tests/racket/unsafe.rktl b/pkgs/racket-test-core/tests/racket/unsafe.rktl index c559e614d1..b374ab4d59 100644 --- a/pkgs/racket-test-core/tests/racket/unsafe.rktl +++ b/pkgs/racket-test-core/tests/racket/unsafe.rktl @@ -594,6 +594,12 @@ #:post (lambda (x) (list x (bytes-ref v 2))) #:literal-ok? #f)) + (let ([bstr (make-bytes 10)]) + (test (void) unsafe-bytes-copy! bstr 1 #"testing" 2 6) + (test #"\0stin\0\0\0\0\0" values bstr) + (test (void) unsafe-bytes-copy! bstr 0 #"testing") + (test #"testing\0\0\0" values bstr)) + (test-bin #\5 'unsafe-string-ref "157" 1) (test-un 3 'unsafe-string-length "157") (let ([v (string #\0 #\3 #\7)]) diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index cdec7945ce..db407e75b9 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/racket/src/cs/primitive/kernel.ss @@ -69,7 +69,7 @@ [bytes-convert-end (known-procedure/no-prompt 30)] [bytes-converter? (known-procedure/pure/folding 2)] [bytes-copy (known-procedure/no-prompt 2)] - [bytes-copy! (known-procedure/no-prompt 56)] + [bytes-copy! (known-procedure/has-unsafe 56 'unsafe-bytes-copy!)] [bytes-fill! (known-procedure/no-prompt 4)] [bytes-length (known-procedure/has-unsafe 2 'unsafe-bytes-length)] [bytes-open-converter (known-procedure/no-prompt 4)] diff --git a/racket/src/cs/primitive/unsafe.ss b/racket/src/cs/primitive/unsafe.ss index 618d767b70..cf72ba9dfb 100644 --- a/racket/src/cs/primitive/unsafe.ss +++ b/racket/src/cs/primitive/unsafe.ss @@ -8,10 +8,11 @@ [unsafe-add-global-finalizer (known-procedure 4)] [unsafe-add-post-custodian-shutdown (known-procedure 2)] [unsafe-add-collect-callbacks (known-procedure 4)] - [unsafe-box*-cas! (known-procedure 8)] + [unsafe-box*-cas! (known-procedure/succeeds 8)] [unsafe-bytes-length (known-procedure/pure 2)] - [unsafe-bytes-ref (known-procedure 4)] - [unsafe-bytes-set! (known-procedure 8)] + [unsafe-bytes-ref (known-procedure/succeeds 4)] + [unsafe-bytes-set! (known-procedure/succeeds 8)] + [unsafe-bytes-copy! (known-procedure/succeeds 56)] [unsafe-call-in-os-thread (known-procedure 2)] [unsafe-call-with-composable-continuation/no-wind (known-procedure 4)] [unsafe-car (known-procedure/pure 2)] @@ -44,12 +45,12 @@ [unsafe-extflmin (known-procedure/pure 4)] [unsafe-extflsqrt (known-procedure/pure 2)] [unsafe-extflvector-length (known-procedure/pure 2)] - [unsafe-extflvector-ref (known-procedure 4)] - [unsafe-extflvector-set! (known-procedure 8)] - [unsafe-f64vector-ref (known-procedure 4)] - [unsafe-f64vector-set! (known-procedure 8)] - [unsafe-f80vector-ref (known-procedure 4)] - [unsafe-f80vector-set! (known-procedure 8)] + [unsafe-extflvector-ref (known-procedure/succeeds 4)] + [unsafe-extflvector-set! (known-procedure/succeeds 8)] + [unsafe-f64vector-ref (known-procedure/succeeds 4)] + [unsafe-f64vector-set! (known-procedure/succeeds 8)] + [unsafe-f80vector-ref (known-procedure/succeeds 4)] + [unsafe-f80vector-set! (known-procedure/succeeds 8)] [unsafe-file-descriptor->port (known-procedure 8)] [unsafe-file-descriptor->semaphore (known-procedure 4)] [unsafe-fl* (known-procedure/pure/folding-unsafe -1 'fl*)] @@ -70,8 +71,8 @@ [unsafe-flreal-part (known-procedure/pure/folding-unsafe 2 'flreal-part)] [unsafe-flsqrt (known-procedure/pure/folding-unsafe 2 'flsqrt)] [unsafe-flvector-length (known-procedure/pure/folding-unsafe 2 'flvector-length)] - [unsafe-flvector-ref (known-procedure 4)] - [unsafe-flvector-set! (known-procedure 8)] + [unsafe-flvector-ref (known-procedure/succeeds 4)] + [unsafe-flvector-set! (known-procedure/succeeds 8)] [unsafe-fx* (known-procedure/pure/folding-unsafe -1 'fx*)] [unsafe-fx+ (known-procedure/pure/folding-unsafe -1 'fx+)] [unsafe-fx- (known-procedure/pure/folding-unsafe -2 'fx-)] @@ -152,23 +153,23 @@ [unsafe-start-atomic (known-procedure 1)] [unsafe-start-breakable-atomic (known-procedure 1)] [unsafe-string-length (known-procedure/pure 2)] - [unsafe-string-ref (known-procedure/pure 4)] - [unsafe-string-set! (known-procedure/pure 8)] + [unsafe-string-ref (known-procedure/succeeds 4)] + [unsafe-string-set! (known-procedure/succeeds 8)] [unsafe-struct*-cas! (known-procedure 16)] - [unsafe-struct*-ref (known-procedure/pure 4)] - [unsafe-struct*-set! (known-procedure/pure 8)] - [unsafe-struct-ref (known-procedure/pure 4)] - [unsafe-struct-set! (known-procedure/pure 8)] + [unsafe-struct*-ref (known-procedure/succeeds 4)] + [unsafe-struct*-set! (known-procedure/succeeds 8)] + [unsafe-struct-ref (known-procedure/succeeds 4)] + [unsafe-struct-set! (known-procedure/succeeds 8)] [unsafe-thread-at-root (known-procedure 2)] - [unsafe-u16vector-ref (known-procedure 4)] - [unsafe-u16vector-set! (known-procedure 8)] + [unsafe-u16vector-ref (known-procedure/succeeds 4)] + [unsafe-u16vector-set! (known-procedure/succeeds 8)] [unsafe-unbox (known-procedure 2)] - [unsafe-unbox* (known-procedure 2)] + [unsafe-unbox* (known-procedure/succeeds 2)] [unsafe-undefined (known-constant)] - [unsafe-vector*-cas! (known-procedure 16)] + [unsafe-vector*-cas! (known-procedure/succeeds 16)] [unsafe-vector*-length (known-procedure/pure 2)] - [unsafe-vector*-ref (known-procedure 4)] - [unsafe-vector*-set! (known-procedure 8)] + [unsafe-vector*-ref (known-procedure/succeeds 4)] + [unsafe-vector*-set! (known-procedure/succeeds 8)] [unsafe-vector-length (known-procedure/pure 2)] [unsafe-vector-ref (known-procedure 4)] [unsafe-vector-set! (known-procedure 8)] diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index f7f870d7d2..e9194218d5 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -670,6 +670,7 @@ unsafe-bytes-length unsafe-bytes-ref unsafe-bytes-set! + unsafe-bytes-copy! unsafe-undefined check-not-unsafe-undefined diff --git a/racket/src/cs/rumble/bytes.ss b/racket/src/cs/rumble/bytes.ss index 2d9b6bb8c6..37c5b61623 100644 --- a/racket/src/cs/rumble/bytes.ss +++ b/racket/src/cs/rumble/bytes.ss @@ -51,21 +51,33 @@ (define/who bytes-copy! (case-lambda [(dest d-start src) - (bytes-copy! dest d-start src 0 (bytes-length src))] + (bytes-copy! dest d-start src 0 (and (bytevector? src) (bytevector-length src)))] [(dest d-start src s-start) - (bytes-copy! dest d-start src s-start (bytes-length src))] + (bytes-copy! dest d-start src s-start (and (bytevector? src) (bytevector-length src)))] [(dest d-start src s-start s-end) - (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" dest) - (check who exact-nonnegative-integer? d-start) - (check who bytes? src) - (check who exact-nonnegative-integer? s-start) - (check who exact-nonnegative-integer? s-end) - (let ([d-len (bytevector-length dest)]) - (check-range who "byte string" dest d-start #f d-len) - (check-range who "byte string" src s-start s-end (bytevector-length src)) - (let ([s-len (fx- s-end s-start)]) - (check-space who "byte string" d-start d-len s-len) - (bytevector-copy! src s-start dest d-start s-len)))])) + ;; start with fast, inlined checks for valid calls, then use + ;; slower tests with consistent reporting if fast tests fail + (cond + [(and (mutable-bytevector? dest) + (bytevector? src) + (fixnum? d-start) + (fixnum? s-start) + (fixnum? s-end) + (fx<= 0 d-start (fx+ d-start (fx- s-end s-start)) (bytevector-length dest)) + (fx<= 0 s-start s-end (bytevector-length src))) + (bytevector-copy! src s-start dest d-start (fx- s-end s-start))] + [else + (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" dest) + (check who exact-nonnegative-integer? d-start) + (check who bytes? src) + (check who exact-nonnegative-integer? s-start) + (check who exact-nonnegative-integer? s-end) + (let ([d-len (bytevector-length dest)]) + (check-range who "byte string" dest d-start #f d-len) + (check-range who "byte string" src s-start s-end (bytevector-length src)) + (let ([s-len (fx- s-end s-start)]) + (check-space who "byte string" d-start d-len s-len) + (bytevector-copy! src s-start dest d-start s-len)))])])) (define/who (bytes-fill! bstr b) (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" bstr) diff --git a/racket/src/cs/rumble/unsafe.ss b/racket/src/cs/rumble/unsafe.ss index cd43f8c3c0..7f98dc4010 100644 --- a/racket/src/cs/rumble/unsafe.ss +++ b/racket/src/cs/rumble/unsafe.ss @@ -89,6 +89,15 @@ (define unsafe-bytes-ref (unsafe-primitive bytevector-u8-ref)) (define unsafe-bytes-set! (unsafe-primitive bytevector-u8-set!)) +(define unsafe-bytes-copy! + (case-lambda + [(dest d-start src) + (unsafe-bytes-copy! dest d-start src 0 (bytevector-length src))] + [(dest d-start src s-start) + (unsafe-bytes-copy! dest d-start src s-start (bytevector-length src))] + [(dest d-start src s-start s-end) + (bytevector-copy! src s-start dest d-start (fx- s-end s-start))])) + (define unsafe-string-length (unsafe-primitive string-length)) (define unsafe-string-ref (unsafe-primitive string-ref)) (define unsafe-string-set! (unsafe-primitive string-set!)) diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index 94e098a1ea..543d24cc3a 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -14,7 +14,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1463 +#define EXPECTED_PRIM_COUNT 1464 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 6acbdea775..3e0d656571 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 5 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 14 +#define MZSCHEME_VERSION_W 15 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x diff --git a/racket/src/racket/src/vector.c b/racket/src/racket/src/vector.c index cdc5bc1e51..712af9aee4 100644 --- a/racket/src/racket/src/vector.c +++ b/racket/src/racket/src/vector.c @@ -66,6 +66,7 @@ static Scheme_Object *unsafe_string_set (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_bytes_len (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_bytes_ref (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_bytes_set (int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_bytes_copy_bang (int argc, Scheme_Object *argv[]); void scheme_init_vector (Scheme_Startup_Env *env) @@ -350,6 +351,12 @@ scheme_init_unsafe_vector (Scheme_Startup_Env *env) scheme_addto_prim_instance("unsafe-bytes-set!", p, env); scheme_unsafe_bytes_set_proc = p; + scheme_addto_prim_instance("unsafe-bytes-copy!", + scheme_make_prim_w_arity(unsafe_bytes_copy_bang, + "unsafe-bytes-copy!", + 3, 5), + env); + scheme_addto_prim_instance("unsafe-impersonate-vector", scheme_make_prim_w_arity(unsafe_impersonate_vector, "unsafe-impersonate-vector", @@ -1331,3 +1338,30 @@ static Scheme_Object *unsafe_bytes_set (int argc, Scheme_Object *argv[]) SCHEME_BYTE_STR_VAL(argv[0])[SCHEME_INT_VAL(argv[1])] = (char)SCHEME_INT_VAL(argv[2]); return scheme_void; } + +static Scheme_Object *unsafe_bytes_copy_bang (int argc, Scheme_Object *argv[]) +{ + Scheme_Object *s1, *s2; + intptr_t istart, ifinish; + intptr_t ostart; + + s1 = argv[0]; + ostart = SCHEME_INT_VAL(argv[1]); + s2 = argv[2]; + if (argc > 3) { + istart = SCHEME_INT_VAL(argv[3]); + if (argc > 4) + ifinish = SCHEME_INT_VAL(argv[4]); + else + ifinish = SCHEME_BYTE_STRLEN_VAL(s2); + } else { + istart = 0; + ifinish = SCHEME_BYTE_STRLEN_VAL(s2); + } + + memmove(SCHEME_BYTE_STR_VAL(s1) XFORM_OK_PLUS ostart, + SCHEME_BYTE_STR_VAL(s2) XFORM_OK_PLUS istart, + (ifinish - istart)); + + return scheme_void; +}