diff --git a/pkgs/racket-test-core/tests/racket/struct.rktl b/pkgs/racket-test-core/tests/racket/struct.rktl index e93aa05c71..bd65d80bf0 100644 --- a/pkgs/racket-test-core/tests/racket/struct.rktl +++ b/pkgs/racket-test-core/tests/racket/struct.rktl @@ -1309,7 +1309,55 @@ (test 8 procedure-arity a)) ;; ---------------------------------------- -;; Make sure that non-typical `make-sytruct-type` patterns are +;; Make sure all checking and good error messages are in place for +;; position-based accessors and mutators: + +(let () + (define-values (struct:s make-s s? s-ref s-set!) + (make-struct-type 's #f 3 0 #f null (current-inspector) #f '(0 1 2))) + + (define s (make-s 1 2 3)) + + (test 1 s-ref s 0) + (test 2 s-ref s 1) + (test 3 s-ref s 2) + + (err/rt-test (s-ref 's 0) exn:fail:contract? #rx"^s-ref:.* expected: s[?]") + (err/rt-test (s-ref s -1) exn:fail:contract? #rx"^s-ref:.* expected: exact-nonnegative-integer[?]") + (err/rt-test (s-ref s 'no) exn:fail:contract? #rx"^s-ref:.* expected: exact-nonnegative-integer[?]") + (err/rt-test (s-ref s 3) exn:fail:contract? #rx"s-ref: index too large") + (err/rt-test (s-ref s (expt 2 100)) exn:fail:contract? #rx"s-ref: index too large") + + (err/rt-test (s-set! 's 0 'v) exn:fail:contract? #rx"^s-set!:.* expected: s[?]") + (err/rt-test (s-set! s -1 'v) exn:fail:contract? #rx"^s-set!:.* expected: exact-nonnegative-integer[?]") + (err/rt-test (s-set! s 'no 'v) exn:fail:contract? #rx"^s-set!:.* expected: exact-nonnegative-integer[?]") + (err/rt-test (s-set! s 3 'v) exn:fail:contract? #rx"s-set!: index too large") + (err/rt-test (s-set! s (expt 2 100) 'v) exn:fail:contract? #rx"s-set!: index too large") + (err/rt-test (s-set! s 0 'v) exn:fail:contract? #rx"s-set!: cannot modify value of immutable field") + (err/rt-test (s-set! s 1 'v) exn:fail:contract? #rx"s-set!: cannot modify value of immutable field") + (err/rt-test (s-set! s 2 'v) exn:fail:contract? #rx"s-set!: cannot modify value of immutable field")) + +(let () + (define-values (struct:s make-s s? s-ref s-set!) + (make-struct-type 's #f 3 0 #f null (current-inspector) #f '())) + + (define s (make-s 1 2 3)) + + (test (void) s-set! s 0 10) + (test (void) s-set! s 1 20) + (test (void) s-set! s 2 30) + (test 10 s-ref s 0) + (test 20 s-ref s 1) + (test 30 s-ref s 2) + + (err/rt-test (s-set! 's 0 'v) exn:fail:contract? #rx"^s-set!:.* expected: s[?]") + (err/rt-test (s-set! s -1 'v) exn:fail:contract? #rx"^s-set!:.* expected: exact-nonnegative-integer[?]") + (err/rt-test (s-set! s 'no 'v) exn:fail:contract? #rx"^s-set!:.* expected: exact-nonnegative-integer[?]") + (err/rt-test (s-set! s 3 'v) exn:fail:contract? #rx"s-set!: index too large") + (err/rt-test (s-set! s (expt 2 100) 'v) exn:fail:contract? #rx"s-set!: index too large")) + +;; ---------------------------------------- +;; Make sure that non-typical `make-struct-type` patterns are ;; not transformed incorrectly by the compiler (test '(1 2) 'not-acc/ref diff --git a/racket/src/cs/rumble/prefab.ss b/racket/src/cs/rumble/prefab.ss index 14cddc6629..0762181d8c 100644 --- a/racket/src/cs/rumble/prefab.ss +++ b/racket/src/cs/rumble/prefab.ss @@ -292,16 +292,32 @@ name (cons name l)))) -(define (prefab-key-mutables prefab-key) - (if (pair? prefab-key) - (if (vector? (cadr prefab-key)) - (cadr prefab-key) - (if (and (pair? (cddr prefab-key)) - (vector? (caddr prefab-key))) - (caddr prefab-key) - '#())) - '#())) - +;; assuming a normalized key, which means it has no +;; non-auto count +(define (prefab-key-mutables prefab-key init+auto-count) + (let ([vec (if (pair? prefab-key) + (if (vector? (cadr prefab-key)) + (cadr prefab-key) + (if (pair? (cddr prefab-key)) + (if (vector? (caddr prefab-key)) + (caddr prefab-key) + '#()) + '#())) + '#())] + [auto (if (pair? prefab-key) + (if (pair? (cadr prefab-key)) + (caadr prefab-key) + 0) + 0)]) + (if (eqv? auto 0) + vec + (list->vector + (append (vector->list vec) + (let loop ([auto auto] [pos (fx- init+auto-count auto 1)]) + (if (fx= auto 0) + '() + (cons pos (loop (fx- auto 1) (fx+ pos 1)))))))))) + (define (encode-prefab-key+count-as-symbol prefab-key+count) ;; The symbol has to be uninterned, because we're going to attach ;; properties to it, and an interned symbol with properties is never diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss index 15375db0ec..e49895ad9b 100644 --- a/racket/src/cs/rumble/procedure.ss +++ b/racket/src/cs/rumble/procedure.ss @@ -948,50 +948,77 @@ (struct-property-set! prop:procedure (record-type-descriptor position-based-accessor) (lambda (pba s p) - (cond - [(and (record? s (position-based-accessor-rtd pba)) - (fixnum? p) - (fx>= p 0) - (fx< p (position-based-accessor-field-count pba))) - (unsafe-struct*-ref s (+ p (position-based-accessor-offset pba)))] - [(and (impersonator? s) - (record? (impersonator-val s) (position-based-accessor-rtd pba)) - (fixnum? p) - (fx>= p 0) - (fx< p (position-based-accessor-field-count pba))) - (impersonate-ref (lambda (s) - (unsafe-struct*-ref s (+ p (position-based-accessor-offset pba)))) - (position-based-accessor-rtd pba) - p - s - #f #f)] - [else (error 'struct-ref "bad access")]))) + (let ([rtd (position-based-accessor-rtd pba)]) + (cond + [(and (record? s rtd) + (fixnum? p) + (fx>= p 0) + (fx< p (position-based-accessor-field-count pba))) + (unsafe-struct*-ref s (+ p (position-based-accessor-offset pba)))] + [(and (impersonator? s) + (record? (impersonator-val s) rtd) + (fixnum? p) + (fx>= p 0) + (fx< p (position-based-accessor-field-count pba))) + (impersonate-ref (lambda (s) + (unsafe-struct*-ref s (+ p (position-based-accessor-offset pba)))) + rtd + p + s + #f #f)] + [else + (let ([who (position-based-accessor-name pba)]) + (unless (or (record? s rtd) + (and (impersonator? s) + (record? (impersonator-val s) rtd))) + (raise-argument-error who + (string-append (symbol->string (record-type-name rtd)) "?") + s)) + (check who exact-nonnegative-integer? p) + (check-accessor-or-mutator-index who rtd p) + ;; just in case: + (error who "bad access"))])))) (struct-property-set! prop:procedure (record-type-descriptor position-based-mutator) (lambda (pbm s p v) - (cond - [(and (record? s (position-based-mutator-rtd pbm)) - (fixnum? p) - (fx>= p 0) - (< p (position-based-mutator-field-count pbm))) - (unsafe-struct-set! s (+ p (position-based-mutator-offset pbm)) v)] - [(and (impersonator? s) - (record? (impersonator-val s) (position-based-mutator-rtd pbm)) - (fixnum? p) - (fx>= p 0) - (< p (position-based-mutator-field-count pbm))) - (let ([abs-pos (+ p (position-based-mutator-offset pbm))]) - (impersonate-set! (lambda (s v) - (unsafe-struct-set! s abs-pos v)) - (position-based-mutator-rtd pbm) - p - abs-pos - s - v - #f #f))] - [else - (error 'struct-set! "bad assignment")]))) + (let ([rtd (position-based-mutator-rtd pbm)]) + (cond + [(and (record? s (position-based-mutator-rtd pbm)) + (fixnum? p) + (fx>= p 0) + (< p (position-based-mutator-field-count pbm)) + (struct-type-field-mutable? rtd p)) + (unsafe-struct-set! s (+ p (position-based-mutator-offset pbm)) v)] + [(and (impersonator? s) + (record? (impersonator-val s) (position-based-mutator-rtd pbm)) + (fixnum? p) + (fx>= p 0) + (< p (position-based-mutator-field-count pbm)) + (struct-type-field-mutable? rtd p)) + (let ([abs-pos (+ p (position-based-mutator-offset pbm))]) + (impersonate-set! (lambda (s v) + (unsafe-struct-set! s abs-pos v)) + (position-based-mutator-rtd pbm) + p + abs-pos + s + v + #f #f))] + [else + (let ([who (position-based-mutator-name pbm)]) + (unless (or (record? s rtd) + (and (impersonator? s) + (record? (impersonator-val s) rtd))) + (raise-argument-error who + (string-append (symbol->string (record-type-name rtd)) "?") + s)) + (check who exact-nonnegative-integer? p) + (check-accessor-or-mutator-index who rtd p) + (unless (struct-type-field-mutable? rtd p) + (cannot-modify-by-pos-error who s p)) + ;; just in case: + (error who "bad assignment"))])))) (struct-property-set! prop:procedure (record-type-descriptor named-procedure) diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss index adaf8c79d0..f7bacc0072 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/racket/src/cs/rumble/struct.ss @@ -670,7 +670,7 @@ ;; All fields must be reported as mutable, because ;; we might need to mutate to create cyclic data: (sub1 (bitwise-arithmetic-shift-left 1 total-count)))] - [mutables (prefab-key-mutables prefab-key)]) + [mutables (prefab-key-mutables prefab-key total-count)]) (with-global-lock (cond [(prefab-ref prefab-key+count code) @@ -766,16 +766,19 @@ (p v a) (impersonate-set! p rtd pos abs-pos v a rec-name (or name 'field)))) (lambda (v a) - (raise-arguments-error name - "cannot modify value of immutable field in structure" - "structure" v - "field index" pos))) + (cannot-modify-by-pos-error name v pos))) name)]) (register-struct-field-mutator! wrap-p rtd pos) wrap-p))] [(pbm pos) (make-struct-field-mutator pbm pos #f)])) +(define (cannot-modify-by-pos-error name v pos) + (raise-arguments-error name + "cannot modify value of immutable field in structure" + "structure" v + "field index" pos)) + ;; Takes constructor arguments and adds auto-argument values. ;; Receives and returns `args` is in reverse order. (define (args-insert args fields-count auto-count auto-val pfa)