cs: fix chaperone-struct
on accessor/mutator taking a position
Closes #2570
This commit is contained in:
parent
247c985702
commit
ef49ccf87a
|
@ -3420,6 +3420,39 @@
|
||||||
(test #t has-impersonator-prop:contracted? group-rows*)
|
(test #t has-impersonator-prop:contracted? group-rows*)
|
||||||
(test 1 'apply (group-rows* #:group 10)))
|
(test 1 'apply (group-rows* #:group 10)))
|
||||||
|
|
||||||
|
;; ----------------------------------------
|
||||||
|
;; Check that position-consuming accessor and mutators work with
|
||||||
|
;; `impersonate-struct`.
|
||||||
|
|
||||||
|
(let ()
|
||||||
|
(define-values (struct:s make-s s? s-ref s-set!)
|
||||||
|
(make-struct-type 's #f 1 0 #f))
|
||||||
|
|
||||||
|
(define a-s (make-s 0))
|
||||||
|
|
||||||
|
(test '(0)
|
||||||
|
s-ref
|
||||||
|
(impersonate-struct
|
||||||
|
a-s
|
||||||
|
s-ref
|
||||||
|
(lambda (k v) (list v))
|
||||||
|
s-set!
|
||||||
|
(lambda (k v) (list v)))
|
||||||
|
0)
|
||||||
|
|
||||||
|
(test (void)
|
||||||
|
s-set!
|
||||||
|
(impersonate-struct
|
||||||
|
a-s
|
||||||
|
s-ref
|
||||||
|
(lambda (k v) (list v))
|
||||||
|
s-set!
|
||||||
|
(lambda (k v) (list v)))
|
||||||
|
0
|
||||||
|
7)
|
||||||
|
|
||||||
|
(test '(7) s-ref a-s 0))
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
||||||
(report-errs)
|
(report-errs)
|
||||||
|
|
|
@ -398,10 +398,16 @@
|
||||||
#t))
|
#t))
|
||||||
|
|
||||||
(define (struct-accessor-procedure-rtd+pos v)
|
(define (struct-accessor-procedure-rtd+pos v)
|
||||||
(with-global-lock* (hashtable-ref struct-field-accessors v #f)))
|
(if (position-based-accessor? v)
|
||||||
|
(cons (position-based-accessor-rtd v)
|
||||||
|
(position-based-accessor-offset v))
|
||||||
|
(with-global-lock* (hashtable-ref struct-field-accessors v #f))))
|
||||||
|
|
||||||
(define (struct-mutator-procedure-rtd+pos v)
|
(define (struct-mutator-procedure-rtd+pos v)
|
||||||
(with-global-lock* (hashtable-ref struct-field-mutators v #f)))
|
(if (position-based-mutator? v)
|
||||||
|
(cons (position-based-mutator-rtd v)
|
||||||
|
(position-based-mutator-offset v))
|
||||||
|
(with-global-lock* (hashtable-ref struct-field-mutators v #f))))
|
||||||
|
|
||||||
;; This indirection prevents the whole-program optimizer from inlining
|
;; This indirection prevents the whole-program optimizer from inlining
|
||||||
;; the `with-glocal-lock*` expansion --- which, at the time of
|
;; the `with-glocal-lock*` expansion --- which, at the time of
|
||||||
|
|
Loading…
Reference in New Issue
Block a user