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

move result-chaperoning procedure to start of chaperioning procedure's results

Browse Source
This commit is contained in:
Matthew Flatt 2010-05-04 13:56:21 -06:00
parent 9350df36b6
commit 8af4134991
4 changed files with 124 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1186,26 +1186,33 @@
(+ alen 2) (+ alen 2)
len) len)
wrap-proc)) wrap-proc))
(let ([new-args (car results)]) (let ([extra? (= len (+ alen 2))])
(unless (and (list? new-args) (let ([new-args ((if extra? cadr car) results)])
(= (length new-args) (length args))) (unless (and (list? new-args)
(raise-mismatch-error (= (length new-args) (length args)))
'|keyword procedure chaperone| (raise-mismatch-error
"expected a list of keyword-argument values as first result from chaperoning procedure: " '|keyword procedure chaperone|
wrap-proc)) (format
(for-each "expected a list of keyword-argument values as first result~a from chaperoning procedure: "
(lambda (kw new-arg arg) (if (= len alen)
(unless (chaperone-of? new-arg arg) ""
(raise-mismatch-error " (after the result chaperoning procedure)"))
'|keyword procedure chaperone| wrap-proc))
(format (for-each
"~a keyword result is not a chaperone of original argument from chaperoning procedure: " (lambda (kw new-arg arg)
kw) (unless (chaperone-of? new-arg arg)
wrap-proc))) (raise-mismatch-error
kws '|keyword procedure chaperone|
new-args (format
args)) "~a keyword result is not a chaperone of original argument from chaperoning procedure: "
(apply values kws results))))))] kw)
wrap-proc)))
kws
new-args
args))
(if extra?
(apply values (car results) kws (cdr results))
(apply values kws results))))))))]
[new-proc [new-proc
(cond (cond
[(okp? proc) [(okp? proc)

34
collects/scribblings/reference/chaperones.scrbl
View File

@ -103,24 +103,26 @@ of the required keywords of @scheme[proc].
For applications without keywords, the result of @scheme[wrapper-proc] For applications without keywords, the result of @scheme[wrapper-proc]
must be either the same number of values as supplied to it or one more must be either the same number of values as supplied to it or one more
than the number of supplied values. For each supplied value, the than the number of supplied values, where an extra result is supplied
corresponding result must be the same or a chaperone of (in the sense before the others. For each supplied value, the corresponding result
of @scheme[chaperone-of?]) the supplied value. The additional result, must be the same or a chaperone of (in the sense of
if any, must be a procedure that accepts as many results as produced @scheme[chaperone-of?]) the supplied value. The additional result, if
by @scheme[proc]; it must return the same number of results, each of any, that precedes the chaperoned values must be a procedure that
which is the same or a chaperone of the corresponding original result. accepts as many results as produced by @scheme[proc]; it must return
If @scheme[wrapper-proc] returns the same number of values as it is the same number of results, each of which is the same or a chaperone
given (i.e., it does not return a procedure to chaperone of the corresponding original result. If @scheme[wrapper-proc]
@scheme[proc]'s result), then @scheme[proc] is called in @tech{tail returns the same number of values as it is given (i.e., it does not
position} with respect to the call to the chaperone. return a procedure to chaperone @scheme[proc]'s result), then
@scheme[proc] is called in @tech{tail position} with respect to the
call to the chaperone.
For applications that include keyword arguments, @scheme[wrapper-proc] For applications that include keyword arguments, @scheme[wrapper-proc]
must return an additional value before any other values. The must return an additional value before any other values but after the
additional value must be a list of chaperones of the keyword arguments result-chaperoning procedure (if any). The additional value must be a
that were supplied to the chaperoned procedure (i.e., not counting list of chaperones of the keyword arguments that were supplied to the
optional arguments that were not supplied). The arguments must be chaperoned procedure (i.e., not counting optional arguments that were
ordered according to the sorted order of the supplied arguments' not supplied). The arguments must be ordered according to the sorted
keywords. order of the supplied arguments' keywords.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[procedure-chaperone] must be even) add chaperone properties to @scheme[procedure-chaperone] must be even) add chaperone properties

86
collects/tests/racket/chaperone.rktl
View File

@ -143,9 +143,10 @@
f f
(lambda (x) (lambda (x)
(set! in x) (set! in x)
(values x (lambda (y) (values (lambda (y)
(set! out y) (set! out y)
y))))]) y)
x)))])
(test '(10 10) f 10) (test '(10 10) f 10)
(test #f values in) (test #f values in)
(test #f values out) (test #f values out)
@ -161,10 +162,10 @@
f f
(lambda (x y z) (lambda (x y z)
(set! in (vector x y z)) (set! in (vector x y z))
(values x y z (values (lambda (y z)
(lambda (y z)
(set! out (vector y z)) (set! out (vector y z))
(values y z)))))]) (values y z))
x y z)))])
(test-values '(b (a c)) (lambda () (f 'a 'b 'c))) (test-values '(b (a c)) (lambda () (f 'a 'b 'c)))
(test #f values in) (test #f values in)
(test #f values out) (test #f values out)
@ -197,6 +198,37 @@
(test 'f object-name f2) (test 'f object-name f2)
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))) (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2))))
;; Optional keyword arguments with result chaperone:
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f]
[out #f]
[f2 (chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(set! in (list x a b))
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(lambda (z) (set! out z) z)
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x))))])
(test '(1 a b) f 1)
(test '(#f #f) list in out)
(test '(1 a b) f2 1)
(test '((1 nope nope) #f) list in out)
(test '(1 2 b) f 1 #:a 2)
(test '(1 2 b) f2 1 #:a 2)
(test '((1 2 nope) (1 2 b)) list in out)
(test '(1 a 3) f 1 #:b 3)
(test '(1 a 3) f2 1 #:b 3)
(test '(1 2 3) f 1 #:a 2 #:b 3)
(test '(1 2 3) f2 1 #:a 2 #:b 3)
(test 1 procedure-arity f2)
(test 'f object-name f2)
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2))))
;; Required keyword arguments: ;; Required keyword arguments:
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))] (let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f] [in #f]
@ -222,6 +254,35 @@
(test 'f object-name f2) (test 'f object-name f2)
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))) (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))))
;; Required keyword arguments:
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f]
[out #f]
[f2 (chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(set! in (list x a b))
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(lambda (z) (set! out z) z)
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x))))])
(err/rt-test (f 1))
(err/rt-test (f2 1))
(err/rt-test (f 1 #:a 2))
(err/rt-test (f2 1 #:a 2))
(test '(1 a 3) f 1 #:b 3)
(test '(1 a 3) f2 1 #:b 3)
(test '((1 nope 3) (1 a 3)) list in out)
(test '(1 2 3) f 1 #:a 2 #:b 3)
(test '(1 2 3) f2 1 #:a 2 #:b 3)
(test 1 procedure-arity f2)
(test 'f object-name f2)
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))))
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y y))) 1)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y y))) 1))
(err/rt-test ((chaperone-procedure (lambda (x) (values x x)) (lambda (y) y))) 1) (err/rt-test ((chaperone-procedure (lambda (x) (values x x)) (lambda (y) y))) 1)
@ -358,9 +419,10 @@
[a3 (chaperone-procedure (if linear? a2 a1) [a3 (chaperone-procedure (if linear? a2 a1)
(lambda (z) (lambda (z)
(set! pre z) (set! pre z)
(values z (lambda (r) (values (lambda (r)
(set! post r) (set! post r)
r))))] r)
z)))]
[a2 (if rev? [a2 (if rev?
(chaperone-struct a3 a-y (lambda (a v) (set! get v) v)) (chaperone-struct a3 a-y (lambda (a v) (set! get v) v))
a2)]) a2)])
@ -632,10 +694,10 @@
r)] r)]
[(v) [(v)
(set! pre-cd? #t) (set! pre-cd? #t)
(values v (values (lambda (x)
(lambda (x)
(set! post-cd? #t) (set! post-cd? #t)
(void)))]))]) (void))
v)]))])
(test #t parameter? cd1) (test #t parameter? cd1)
(test #t parameter? cd2) (test #t parameter? cd2)
(test '(#f #f #f #f) list pre-cd? post-cd? got-cd? post-got-cd?) (test '(#f #f #f #f) list pre-cd? post-cd? got-cd? post-got-cd?)

6
src/racket/src/fun.c
View File

@ -4118,6 +4118,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} }
if ((c == argc) || (c == (argc + 1))) { if ((c == argc) || (c == (argc + 1))) {
if (c > argc) {
post = argv2[0];
memmove(argv2, argv2 + 1, sizeof(Scheme_Object*)*c);
} else
post = NULL;
for (i = 0; i < argc; i++) { for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(argv2[i], argv[i])) { if (!scheme_chaperone_of(argv2[i], argv[i])) {
if (argc == 1) if (argc == 1)
@ -4163,7 +4168,6 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} }
} else { } else {
/* Last element is a filter for the result(s) */ /* Last element is a filter for the result(s) */
post = argv2[argc];
if (!SCHEME_PROCP(post)) if (!SCHEME_PROCP(post))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure chaperone: %V: expected <procedure> as last result, produced: %V", "procedure chaperone: %V: expected <procedure> as last result, produced: %V",