suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

struct-impersonator: make method-style prop:procedure receive impersonated

Browse Source 
When a struct is called as a procedure and the struct is
impersonators, make a method-style `prop:procedure` receive the
impersonated structure as its argument. This change makes a
method-style `prop:procedure` more consistent with a field-index
`prop:procedure. The old behavior, meanwhile, seems to create an
unsoundness in Typed Racket.

Closes #2574
This commit is contained in:
Matthew Flatt 2021-05-06 16:23:07 -06:00
parent 30426fff9d
commit 486ab09587
5 changed files with 159 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
pkgs/racket-test-core/tests/racket/chaperone.rktl
View File

@ -3582,6 +3582,83 @@
(test #t has-impersonator-prop:contracted? group-rows*)
(test 1 'apply (group-rows* #:group 10)))
;; ----------------------------------------
;; More checks on the interaction of procedure and struct impersonators
(let ()
(struct foo ([val #:mutable])
#:property prop:procedure
(λ (self)
(log-error "getting")
(foo-val self)))
(define orig-foo (foo 'original))
(define the-foo
(impersonate-struct
orig-foo
foo-val
(λ (self val) 'impersonated)
set-foo-val!
(λ (self val) (error "cannot set!"))))
(test 'impersonated foo-val the-foo)
(test 'impersonated the-foo))
(let ()
(define chaperoned 0)
(struct bar (proc)
#:property prop:procedure 0)
(define orig-bar (bar (lambda () 'ok)))
(define the-bar
(chaperone-struct
orig-bar
bar-proc
(lambda (self val) (set! chaperoned (add1 chaperoned)) val)))
(test 0 values chaperoned)
(test 'ok the-bar)
(test 1 values chaperoned)
(define proc-bar
(chaperone-procedure orig-bar (lambda () (values))))
(define another-bar
(chaperone-struct
proc-bar
bar-proc
(lambda (self val) (set! chaperoned (add1 chaperoned)) val)))
(test 1 values chaperoned)
(test 'ok another-bar)
(test 2 values chaperoned)
(define-values (prop:tagged tagged? tagged-ref) (make-impersonator-property 'tagged))
(define was-tagged? #f)
(define proc*-bar
(chaperone-procedure* orig-bar (lambda (orig)
(set! was-tagged? (tagged? orig))
(values))))
(define struct*-bar
(chaperone-struct
proc-bar
bar-proc
(lambda (self val) (set! chaperoned (add1 chaperoned)) val)))
(define the*-bar
(chaperone-procedure proc*-bar
(lambda () (values))
prop:tagged #t))
(test #f values was-tagged?)
(test 'ok the*-bar)
(test #t values was-tagged?))
;; ----------------------------------------
;; Check that position-consuming accessor and mutators work with
;; `impersonate-struct`.

5
racket/src/bc/src/eval.c
View File

@ -2560,14 +2560,13 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
UPDATE_THREAD_RSPTR_FOR_ERROR(); /* in case */
v = obj;
obj = scheme_extract_struct_procedure(orig_obj, check_rands, rands, &is_method);
if (is_method) {
/* Have to add an extra argument to the front of rands */
if ((rands == RUNSTACK) && (RUNSTACK != RUNSTACK_START)){
/* Common case: we can just push self onto the front: */
rands = PUSH_RUNSTACK(p, RUNSTACK, 1);
rands[0] = v;
rands[0] = orig_obj;
} else {
int i;
Scheme_Object **a;
@ -2585,7 +2584,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
for (i = num_rands; i--; ) {
a[i + 1] = rands[i];
}
a[0] = v;
a[0] = orig_obj;
rands = a;
}
num_rands++;

2
racket/src/cs/rumble/impersonator.ss
View File

@ -661,7 +661,7 @@
(define (set-impersonator-applicables!)
(let ([add (lambda (rtd)
(struct-property-set! prop:procedure rtd impersonate-apply)
(struct-property-set! prop:procedure rtd 'impersonate-apply)
(struct-property-set! prop:procedure-arity rtd 3))])
(add (record-type-descriptor props-procedure-impersonator))
(add (record-type-descriptor props-procedure-chaperone))

2
racket/src/cs/rumble/parameter.ss
View File

@ -18,7 +18,7 @@
(let dloop ([p (car args)] [v (cadr args)])
(cond
[(impersonator? p)
(dloop (impersonator-val p) (impersonate-apply/parameter p #f (list v)))]
(dloop (impersonator-val p) (impersonate-apply/parameter p p #f (list v)))]
[(derived-parameter? p)
(dloop (derived-parameter-next p) (|#%app| (parameter-guard p) v))]
[else

144
racket/src/cs/rumble/procedure.ss
View File

@ -93,12 +93,12 @@
(#3%$app/no-inline slow-extract-procedure tmp n-args))))
(define (slow-extract-procedure f n-args)
(do-extract-procedure f f n-args #f not-a-procedure))
(do-extract-procedure f f f n-args #f not-a-procedure))
;; Returns a host-Scheme procedure, but first checks arity so that
;; checking and reporting use the right top-level function, and
;; the returned procedure may just report a not-a-procedure error
(define (do-extract-procedure f orig-f n-args success-k fail-k)
(define (do-extract-procedure f self-f orig-f n-args success-k fail-k)
(cond
[(#%procedure? f)
(if (or (not n-args)
@ -117,44 +117,56 @@
(let* ([rtd (record-rtd f)]
[v (struct-property-ref prop:procedure rtd none)])
(cond
[(eq? v none) (fail-k orig-f)]
[(fixnum? v)
(let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond
[(and a n-args (not (bitwise-bit-set? (unsafe-struct*-ref f a) n-args)))
(wrong-arity-wrapper orig-f)]
[else
(do-extract-procedure (unsafe-struct-ref f v) orig-f n-args success-k wrong-arity-wrapper)]))]
[(eq? v 'unsafe)
(do-extract-procedure
(if (chaperone? f)
(unsafe-procedure-chaperone-replace-proc f)
(unsafe-procedure-impersonator-replace-proc f))
orig-f
n-args
success-k
wrong-arity-wrapper)]
[else
(let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond
[(and a n-args (not (bitwise-bit-set? (unsafe-struct*-ref f a) n-args)))
(wrong-arity-wrapper orig-f)]
[else
(do-extract-procedure
v
orig-f
(and n-args (fx+ n-args 1))
(lambda (v)
(let ([proc (case-lambda
[() (v f)]
[(a) (v f a)]
[(a b) (v f a b)]
[(a b c) (v f a b c)]
[args (chez:apply v f args)])])
(if success-k
(success-k proc)
proc)))
wrong-arity-wrapper)]))]))]
[(eq? v none) (fail-k orig-f)]
[(fixnum? v)
(let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond
[(and a n-args (not (bitwise-bit-set? (unsafe-struct*-ref f a) n-args)))
(wrong-arity-wrapper orig-f)]
[else
(let ([new-f (unsafe-struct-ref self-f v)])
(do-extract-procedure new-f new-f orig-f n-args success-k wrong-arity-wrapper))]))]
[(eq? v 'unsafe)
(let ([new-f (if (chaperone? f)
(unsafe-procedure-chaperone-replace-proc f)
(unsafe-procedure-impersonator-replace-proc f))])
(do-extract-procedure
new-f
new-f
orig-f
n-args
success-k
wrong-arity-wrapper))]
[(eq? v 'struct-impersonate-apply)
(do-extract-procedure (impersonator-next f) self-f orig-f n-args success-k fail-k)]
[else
(let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond
[(and a n-args (not (bitwise-bit-set? (unsafe-struct*-ref f a) n-args)))
(wrong-arity-wrapper orig-f)]
[(eq? v 'impersonate-apply)
(let ([proc (lambda args
(impersonate-apply/parameter f self-f #t args))])
(if success-k
(success-k proc)
proc))]
[else
(do-extract-procedure
v
v
orig-f
(and n-args (fx+ n-args 1))
(lambda (v)
(let ([proc (case-lambda
[() (v self-f)]
[(a) (v self-f a)]
[(a b) (v self-f a b)]
[(a b c) (v self-f a b c)]
[args (chez:apply v self-f args)])])
(if success-k
(success-k proc)
proc)))
wrong-arity-wrapper)]))]))]
[else (fail-k orig-f)]))
(define (extract-procedure-name f)
@ -680,21 +692,18 @@
[else
(k #f #f #f)])))
(define (impersonate-apply proc . args)
(impersonate-apply/parameter proc #t args))
;; If `actually-call?` is #f, then don't call the procedure in `proc`,
;; because we're trying to get an inpersonated-parameter value
(define (impersonate-apply/parameter proc actually-call? args)
(define (impersonate-apply/parameter p self-p actually-call? args)
(let ([n (length args)])
(cond
[(not (procedure-arity-includes? (impersonator-val proc) n))
[(not (procedure-arity-includes? (impersonator-val p) n))
;; Let primitive application complain:
(|#%app| (impersonator-val proc) args)]
(|#%app| (impersonator-val p) args)]
[else
;; Loop through wrappers so that `{chaperone,impersonate}-procedure*`
;; wrappers can receive the original `proc` argument
(let loop ([p proc] [args args])
(let loop ([p p] [args args])
(cond
[(or (procedure-impersonator? p)
(procedure-chaperone? p))
@ -723,7 +732,7 @@
(if (if chaperone?
(procedure*-chaperone? p)
(procedure*-impersonator? p))
(apply wrapper proc args)
(apply wrapper self-p args)
(apply wrapper args)))])
;; Set mark, if any, while calling:
(cond
@ -783,7 +792,7 @@
[(fx> nn n)
(raise-wrapper-bad-extra-result-error chaperone? pos (car new-args) next-p wrapper)]
[else
(raise-wrapper-result-arity-error chaperone? proc wrapper n nn)])))))]
(raise-wrapper-result-arity-error chaperone? self-p wrapper n nn)])))))]
[(unsafe-procedure-impersonator? p)
(apply p args)]
[(unsafe-procedure-chaperone? p)
@ -795,15 +804,16 @@
[else
;; If `p` is a structure whose `prop:procedure` value is an
;; integer `i`, then we should extract the field at position
;; `i` from `proc`, not from `p`, so that any interpositions
;; `i` from `self-p`, not from `p`, so that any interpositions
;; on that access are performed.
(let ([v (and (record? p)
(struct-property-ref prop:procedure (record-rtd p) #f))])
(cond
[(integer? v)
(apply (unsafe-struct-ref proc v) args)]
(apply (unsafe-struct-ref self-p v) args)]
[else
(apply p args)]))]))])))
(#%apply (do-extract-procedure p self-p self-p (length args) #f not-a-procedure)
args)]))]))])))
(define (set-procedure-impersonator-hash!)
(record-type-hash-procedure (record-type-descriptor procedure-chaperone)
@ -1061,22 +1071,24 @@
#t)
(let ([register-procedure-impersonator-struct-type!
(lambda (rtd)
(struct-property-set! prop:procedure rtd impersonate-apply))])
(lambda (rtd struct?)
(struct-property-set! prop:procedure rtd (if struct?
'struct-impersonate-apply
'impersonate-apply)))])
(let ([register-procedure-impersonator-struct-type!
(lambda (rtd)
(register-procedure-impersonator-struct-type! rtd)
(lambda (rtd struct?)
(register-procedure-impersonator-struct-type! rtd struct?)
(struct-property-set! prop:procedure-arity rtd 4))])
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-chaperone))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-impersonator))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure*-chaperone))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure*-impersonator))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-chaperone))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-impersonator))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure~-struct-chaperone))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure~-struct-impersonator)))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-undefined-chaperone))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure~-struct-undefined-chaperone)))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-chaperone) #f)
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-impersonator) #f)
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure*-chaperone) #f)
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure*-impersonator) #f)
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-chaperone) #t)
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-impersonator) #t)
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure~-struct-chaperone) #t)
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure~-struct-impersonator) #t))
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-undefined-chaperone) #t)
(register-procedure-impersonator-struct-type! (record-type-descriptor procedure~-struct-undefined-chaperone) #t))
(let ([register-procedure-incomplete-arity!
(lambda (rtd)