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)
len)
wrap-proc))
(let ([new-args (car results)])
(unless (and (list? new-args)
(= (length new-args) (length args)))
(raise-mismatch-error
'|keyword procedure chaperone|
"expected a list of keyword-argument values as first result from chaperoning procedure: "
wrap-proc))
(for-each
(lambda (kw new-arg arg)
(unless (chaperone-of? new-arg arg)
(raise-mismatch-error
'|keyword procedure chaperone|
(format
"~a keyword result is not a chaperone of original argument from chaperoning procedure: "
kw)
wrap-proc)))
kws
new-args
args))
(apply values kws results))))))]
(let ([extra? (= len (+ alen 2))])
(let ([new-args ((if extra? cadr car) results)])
(unless (and (list? new-args)
(= (length new-args) (length args)))
(raise-mismatch-error
'|keyword procedure chaperone|
(format
"expected a list of keyword-argument values as first result~a from chaperoning procedure: "
(if (= len alen)
""
" (after the result chaperoning procedure)"))
wrap-proc))
(for-each
(lambda (kw new-arg arg)
(unless (chaperone-of? new-arg arg)
(raise-mismatch-error
'|keyword procedure chaperone|
(format
"~a keyword result is not a chaperone of original argument from chaperoning procedure: "
kw)
wrap-proc)))
kws
new-args
args))
(if extra?
(apply values (car results) kws (cdr results))
(apply values kws results))))))))]
[new-proc
(cond
[(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]
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
corresponding result must be the same or a chaperone of (in the sense
of @scheme[chaperone-of?]) the supplied value. The additional result,
if any, must be a procedure that accepts as many results as produced
by @scheme[proc]; it must return the same number of results, each of
which is the same or a chaperone of the corresponding original result.
If @scheme[wrapper-proc] returns the same number of values as it is
given (i.e., it does not 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.
than the number of supplied values, where an extra result is supplied
before the others. For each supplied value, the corresponding result
must be the same or a chaperone of (in the sense of
@scheme[chaperone-of?]) the supplied value. The additional result, if
any, that precedes the chaperoned values must be a procedure that
accepts as many results as produced by @scheme[proc]; it must return
the same number of results, each of which is the same or a chaperone
of the corresponding original result. If @scheme[wrapper-proc]
returns the same number of values as it is given (i.e., it does not
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]
must return an additional value before any other values. The
additional value must be a list of chaperones of the keyword arguments
that were supplied to the chaperoned procedure (i.e., not counting
optional arguments that were not supplied). The arguments must be
ordered according to the sorted order of the supplied arguments'
keywords.
must return an additional value before any other values but after the
result-chaperoning procedure (if any). The additional value must be a
list of chaperones of the keyword arguments that were supplied to the
chaperoned procedure (i.e., not counting optional arguments that were
not supplied). The arguments must be ordered according to the sorted
order of the supplied arguments' keywords.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[procedure-chaperone] must be even) add chaperone properties

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

@ -143,9 +143,10 @@
f
(lambda (x)
(set! in x)
(values x (lambda (y)
(set! out y)
y))))])
(values (lambda (y)
(set! out y)
y)
x)))])
(test '(10 10) f 10)
(test #f values in)
(test #f values out)
@ -161,10 +162,10 @@
f
(lambda (x y z)
(set! in (vector x y z))
(values x y z
(lambda (y z)
(values (lambda (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 #f values in)
(test #f values out)
@ -197,6 +198,37 @@
(test 'f object-name 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:
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f]
@ -222,6 +254,35 @@
(test 'f object-name 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 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)
(lambda (z)
(set! pre z)
(values z (lambda (r)
(set! post r)
r))))]
(values (lambda (r)
(set! post r)
r)
z)))]
[a2 (if rev?
(chaperone-struct a3 a-y (lambda (a v) (set! get v) v))
a2)])
@ -632,10 +694,10 @@
r)]
[(v)
(set! pre-cd? #t)
(values v
(lambda (x)
(values (lambda (x)
(set! post-cd? #t)
(void)))]))])
(void))
v)]))])
(test #t parameter? cd1)
(test #t parameter? cd2)
(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) {
post = argv2[0];
memmove(argv2, argv2 + 1, sizeof(Scheme_Object*)*c);
} else
post = NULL;
for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(argv2[i], argv[i])) {
if (argc == 1)
@ -4163,7 +4168,6 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
}
} else {
/* Last element is a filter for the result(s) */
post = argv2[argc];
if (!SCHEME_PROCP(post))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure chaperone: %V: expected <procedure> as last result, produced: %V",