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

fix impersonator-prop:application-mark for keyword arguments

Browse Source 
Closes #1836
This commit is contained in:
Matthew Flatt 2021-04-28 17:51:05 -06:00
parent 387f5dc3ba
commit bd94ac6b27
2 changed files with 66 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3005,6 +3005,50 @@
((wrap (lambda (x) (+ ((wrap (lambda (x) x)) x) 0))) 42))
(test '(#f #f) values msgs))
;; Make sure that `impersonator-prop:application-mark'
;; works with keyword-based procedures:
(let ()
(define (f x #:y y)
(call-with-immediate-continuation-mark
'z
(lambda (val)
(list val
(continuation-mark-set->list (current-continuation-marks) 'z)))))
(define g (chaperone-procedure
f
(lambda (a #:y y)
(values (lambda (r) r)
(list y)
a))
impersonator-prop:application-mark
(cons 'z 12)))
(test '(#f ()) 'kw-y-f (f 10 #:y 3))
(test '(12 (12)) 'kw-y-g (g 10 #:y 3))
(void))
(let ()
(define (f x #:y [y 'no])
(call-with-immediate-continuation-mark
'z
(lambda (val)
(list val
(continuation-mark-set->list (current-continuation-marks) 'z)))))
(define g (chaperone-procedure
f
(lambda (a #:y [y 'no])
(if (eq? y 'no)
(values (lambda (r) r)
a)
(values (lambda (r) r)
(list y)
a)))
impersonator-prop:application-mark
(cons 'z 12)))
(test '(#f ()) 'kw-no-y-f (f 10))
(test '(12 (12)) 'kw-no-y-g (g 10))
(test '(#f ()) 'kw-y-f (f 10 #:y 3))
(test '(12 (12)) 'kw-y-g (g 10 #:y 3))
(void))
;; ----------------------------------------
;; Check that supplying a procedure `to make-keyword-procedure' that

33
racket/collects/racket/private/kw.rkt
View File

@ -1882,7 +1882,18 @@
(apply chaperone-procedure proc wrap-proc props)
(begin
(chaperone-arity-match-checking self-arg? name proc wrap-proc props)
(let*-values ([(kw-chaperone)
(let*-values ([(mark-prop) (let loop ([props props])
(cond
[(null? props) #f]
[(eq? (car props) impersonator-prop:application-mark)
(cadr props)]
[else (loop (cddr props))]))]
[(chaperone-procedure/add-mark)
(lambda (proc wrap-proc)
(if mark-prop
(chaperone-procedure proc wrap-proc impersonator-prop:application-mark mark-prop)
(chaperone-procedure proc wrap-proc)))]
[(kw-chaperone)
(let ([p (keyword-procedure-proc n-wrap-proc)])
;; `extra-arg ...` will be `self-proc` if `self-arg?`:
(define-syntax gen-wrapper
@ -1971,7 +1982,7 @@
(if (okp? n-proc)
;; All keyword arguments are optional, so need to
;; chaperone as a plain procedure, too:
(chaperone-procedure proc wrap-proc)
(chaperone-procedure/add-mark proc wrap-proc)
;; Some keyword is required:
proc)
new-procedure-ref
@ -2020,22 +2031,22 @@
make-optional-keyword-method-impersonator
make-optional-keyword-procedure-impersonator)
(keyword-procedure-checker n-proc)
(chaperone-procedure (keyword-procedure-proc n-proc)
kw-chaperone)
(chaperone-procedure/add-mark (keyword-procedure-proc n-proc)
kw-chaperone)
(keyword-procedure-required n-proc)
(keyword-procedure-allowed n-proc)
(chaperone-procedure (okp-ref n-proc 0)
(okp-ref n-wrap-proc 0))
(chaperone-procedure/add-mark (okp-ref n-proc 0)
(okp-ref n-wrap-proc 0))
n-proc)
(chaperone-struct
proc
keyword-procedure-proc
(lambda (self proc)
(chaperone-procedure proc kw-chaperone))
(chaperone-procedure/add-mark proc kw-chaperone))
(make-struct-field-accessor okp-ref 0)
(lambda (self proc)
(chaperone-procedure proc
(okp-ref n-wrap-proc 0)))))
(chaperone-procedure/add-mark proc
(okp-ref n-wrap-proc 0)))))
keyword-procedure-proc)]
[else
(values
@ -2045,7 +2056,7 @@
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? n-proc) #t)])
(mk
(keyword-procedure-checker n-proc)
(chaperone-procedure (keyword-procedure-proc n-proc) kw-chaperone)
(chaperone-procedure/add-mark (keyword-procedure-proc n-proc) kw-chaperone)
(keyword-procedure-required n-proc)
(keyword-procedure-allowed n-proc)
n-proc))
@ -2053,7 +2064,7 @@
n-proc
keyword-procedure-proc
(lambda (self proc)
(chaperone-procedure proc kw-chaperone))))
(chaperone-procedure/add-mark proc kw-chaperone))))
keyword-procedure-proc)]))])
(if (null? props)
new-proc