cs: repair position-based struct accessor/mutator
Fix error checking and reporting for position-based struct accessors and mutators. Also, fix mutability recording for prefab structure types that have auto fields. Related to racket/typed-racket#902
This commit is contained in:
Matthew Flatt
parent
40045ce1a6
commit
05dfd85853
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -292,15 +292,31 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user