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

fix the interaction of chaperones, keywords, and the whole zoo of reflective procedure operations

Browse Source 
svn: r18711
This commit is contained in:
Matthew Flatt 2010-04-01 13:14:50 +00:00
parent 853db0ae55
commit b2d65a1b95
25 changed files with 526 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

213
collects/scheme/private/kw.ss
View File

@ -14,9 +14,10 @@
(#%provide new-lambda new-λ (#%provide new-lambda new-λ
new-define new-define
new-app new-app
(rename *make-keyword-procedure make-keyword-procedure) make-keyword-procedure
keyword-apply keyword-apply
procedure-keywords procedure-keywords
new:procedure-reduce-arity
procedure-reduce-keyword-arity procedure-reduce-keyword-arity
new-prop:procedure new-prop:procedure
new:procedure->method new:procedure->method
@ -25,7 +26,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(define-values (struct:keyword-procedure make-keyword-procedure keyword-procedure? (define-values (struct:keyword-procedure mk-kw-proc keyword-procedure?
keyword-procedure-ref keyword-procedure-set!) keyword-procedure-ref keyword-procedure-set!)
(make-struct-type 'keyword-procedure #f 4 0 #f (make-struct-type 'keyword-procedure #f 4 0 #f
(list (cons prop:checked-procedure #t)) (list (cons prop:checked-procedure #t))
@ -113,7 +114,7 @@
struct:okp struct:okp
0 0 #f)) 0 0 #f))
(define-values (prop:named-keyword-procedure named-keyword-procedure? keyword-procedure-name) (define-values (prop:named-keyword-procedure named-keyword-procedure? keyword-procedure-name+fail)
(make-struct-type-property 'named-keyword-procedure)) (make-struct-type-property 'named-keyword-procedure))
;; Constructor generator for a procedure with a required keyword. ;; Constructor generator for a procedure with a required keyword.
@ -123,13 +124,15 @@
;; the right arity, and that sends all arguments to `missing-kw'. ;; the right arity, and that sends all arguments to `missing-kw'.
(define (make-required name fail-proc method?) (define (make-required name fail-proc method?)
(let-values ([(s: mk ? -ref -set!) (let-values ([(s: mk ? -ref -set!)
(make-struct-type (string->symbol (format "procedure:~a" name)) (make-struct-type (or name 'unknown)
(if method? (if method?
struct:keyword-method struct:keyword-method
struct:keyword-procedure) struct:keyword-procedure)
0 0 #f 0 0 #f
(list (cons prop:arity-string generate-arity-string) (list (cons prop:arity-string
(cons prop:named-keyword-procedure name)) generate-arity-string)
(cons prop:named-keyword-procedure
(cons name fail-proc)))
(current-inspector) fail-proc)]) (current-inspector) fail-proc)])
mk)) mk))
@ -140,21 +143,19 @@
;; ---------------------------------------- ;; ----------------------------------------
(define *make-keyword-procedure (define make-keyword-procedure
(letrec ([make-keyword-procedure (case-lambda
(case-lambda [(proc) (make-keyword-procedure
[(proc) (make-keyword-procedure proc
proc (lambda args
(lambda args (apply proc null null args)))]
(apply proc null null args)))] [(proc plain-proc)
[(proc plain-proc) (make-optional-keyword-procedure
(make-optional-keyword-procedure (make-keyword-checker null #f (procedure-arity proc))
(make-keyword-checker null #f (procedure-arity proc)) proc
proc null
null #f
#f plain-proc)]))
plain-proc)])])
make-keyword-procedure))
(define (keyword-apply proc kws kw-vals . normal-argss) (define (keyword-apply proc kws kw-vals . normal-argss)
(let ([type-error (let ([type-error
@ -943,7 +944,7 @@
raise-type-error 'x "x" 0 'x raise-type-error 'x "x" 0 'x
(append args (apply append (map list kws kw-args))))))] (append args (apply append (map list kws kw-args))))))]
[proc-name (lambda (p) (or (and (named-keyword-procedure? p) [proc-name (lambda (p) (or (and (named-keyword-procedure? p)
(keyword-procedure-name p)) (car (keyword-procedure-name+fail p)))
(object-name p) (object-name p)
p))]) p))])
(raise (raise
@ -986,13 +987,6 @@
[(null? (cdr kws)) #t] [(null? (cdr kws)) #t]
[(keyword<? (car kws) (cadr kws)) (loop (cdr kws))] [(keyword<? (car kws) (cadr kws)) (loop (cdr kws))]
[else #f]))) [else #f])))
(define (subset? a b)
(cond
[(null? a) #t]
[(null? b) #f]
[(eq? (car a) (car b)) (subset? (cdr a) (cdr b))]
[(keyword<? (car a) (car b)) #f]
[else (subset? a (cdr b))]))
(unless (and (list? req-kw) (andmap keyword? req-kw) (unless (and (list? req-kw) (andmap keyword? req-kw)
(sorted? req-kw)) (sorted? req-kw))
@ -1054,7 +1048,7 @@
;; Some keywords are required, so "plain" proc is ;; Some keywords are required, so "plain" proc is
;; irrelevant; we build a new one that wraps `missing-kws'. ;; irrelevant; we build a new one that wraps `missing-kws'.
((make-required (or (and (named-keyword-procedure? proc) ((make-required (or (and (named-keyword-procedure? proc)
(keyword-procedure-name proc)) (car (keyword-procedure-name+fail proc)))
(object-name proc)) (object-name proc))
(procedure-reduce-arity (procedure-reduce-arity
missing-kw missing-kw
@ -1065,11 +1059,45 @@
new-kw-proc new-kw-proc
req-kw req-kw
allowed-kw)))))) allowed-kw))))))
(define new:procedure-reduce-arity
(let ([procedure-reduce-arity
(lambda (proc arity)
(if (and (procedure? proc)
(keyword-procedure? proc)
(not (okp? proc))
(not (null? arity)))
(raise-mismatch-error 'procedure-reduce-arity
"procedure has required keyword arguments: "
proc)
(procedure-reduce-arity proc arity)))])
procedure-reduce-arity))
(define new:procedure->method (define new:procedure->method
(let ([procedure->method (let ([procedure->method
(lambda (proc) (lambda (proc)
(procedure->method proc))]) (if (keyword-procedure? proc)
(cond
[(okm? proc) proc]
[(keyword-method? proc) proc]
[(okp? proc) (make-optional-keyword-method
(keyword-procedure-checker proc)
(keyword-procedure-proc proc)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)
(okp-ref proc 0))]
[else
;; Constructor must be from `make-required', but not a method.
;; Make a new variant that's a method:
(let* ([name+fail (keyword-procedure-name+fail proc)]
[mk (make-required (car name+fail) (cdr name+fail) #t)])
(mk
(keyword-procedure-checker proc)
(keyword-procedure-proc proc)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)))])
;; Not a keyword-accepting procedure:
(procedure->method proc)))])
procedure->method)) procedure->method))
(define new:procedure-rename (define new:procedure-rename
@ -1078,11 +1106,130 @@
(if (not (and (keyword-procedure? proc) (if (not (and (keyword-procedure? proc)
(symbol? name))) (symbol? name)))
(procedure-rename proc name) (procedure-rename proc name)
(procedure-rename proc name)))]) ;; Rename a keyword procedure:
(cond
[(okp? proc)
((if (okm? proc)
make-optional-keyword-procedure
make-optional-keyword-method)
(keyword-procedure-checker proc)
(keyword-procedure-proc proc)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)
(procedure-rename (okp-ref proc 0) name))]
[else
;; Constructor must be from `make-required':
(let* ([name+fail (keyword-procedure-name+fail proc)]
[mk (make-required name (cdr name+fail) (keyword-method? proc))])
(mk
(keyword-procedure-checker proc)
(keyword-procedure-proc proc)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)))])))])
procedure-rename)) procedure-rename))
(define new:chaperone-procedure (define new:chaperone-procedure
(let ([chaperone-procedure (let ([chaperone-procedure
(lambda (proc wrap-proc . props) (lambda (proc wrap-proc . props)
(apply chaperone-procedure proc wrap-proc props))]) (if (or (not (keyword-procedure? proc))
(not (procedure? wrap-proc)))
(apply chaperone-procedure proc wrap-proc props)
(let-values ([(a) (procedure-arity proc)]
[(b) (procedure-arity wrap-proc)]
[(a-req a-allow) (procedure-keywords proc)]
[(b-req b-allow) (procedure-keywords wrap-proc)])
(define (includes? a b)
(cond
[(number? b) (cond
[(number? a) (= b a)]
[(arity-at-least? a)
(b . >= . (arity-at-least-value a))]
[else
(ormap (lambda (b a) (includes? a b))
a)])]
[(arity-at-least? b) (cond
[(number? a) #f]
[(arity-at-least? a)
((arity-at-least-value b) . >= . (arity-at-least-value a))]
[else (ormap (lambda (b a) (includes? b a))
a)])]
[else (andmap (lambda (b) (includes? a b)) b)]))
(unless (includes? b a)
;; Let core report error:
(apply chaperone-procedure proc wrap-proc props))
(unless (subset? b-req a-req)
(raise-mismatch-error
'chaperone-procedure
"chaperoning procedure requires more keywords than original procedure: "
proc))
(unless (or (not b-allow)
(and a-allow
(subset? a-allow b-allow)))
(raise-mismatch-error
'chaperone-procedure
"chaperoning procedure does not accept all keywords of original procedure: "
proc))
(let* ([kw-chaperone
(let ([p (keyword-procedure-proc wrap-proc)])
(lambda (kws args . rest)
(call-with-values (lambda () (apply p kws args rest))
(lambda results
(let ([len (length results)]
[alen (length rest)])
(unless (<= (+ alen 1) len (+ alen 2))
(raise-mismatch-error
'|keyword procedure chaperone|
(format
"expected ~a or ~a results, received ~a results from chaperoning procedure: "
(+ alen 1)
(+ 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))))))]
[new-proc
(cond
[(okp? proc)
(make-optional-keyword-procedure
(keyword-procedure-checker proc)
(chaperone-procedure (keyword-procedure-proc proc)
kw-chaperone)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)
(chaperone-procedure (okp-ref proc 0)
(okp-ref wrap-proc 0)))]
[else
;; Constructor must be from `make-required':
(let* ([name+fail (keyword-procedure-name+fail proc)]
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc))])
(mk
(keyword-procedure-checker proc)
(chaperone-procedure (keyword-procedure-proc proc) kw-chaperone)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)))])])
(if (null? props)
new-proc
(apply chaperone-struct new-proc
;; chaperone-struct insists on having at least one selector:
keyword-procedure-allowed values
props))))))])
chaperone-procedure))) chaperone-procedure)))

3
collects/scheme/private/pre-base.ss
View File

@ -73,11 +73,12 @@
(rename module-begin #%module-begin) (rename module-begin #%module-begin)
(rename norm:procedure-arity procedure-arity) (rename norm:procedure-arity procedure-arity)
(rename norm:raise-arity-error raise-arity-error) (rename norm:raise-arity-error raise-arity-error)
(rename new:procedure-reduce-arity procedure-reduce-arity)
(rename new:procedure->method procedure->method) (rename new:procedure->method procedure->method)
(rename new:procedure-rename procedure-rename) (rename new:procedure-rename procedure-rename)
(rename new:chaperone-procedure chaperone-procedure) (rename new:chaperone-procedure chaperone-procedure)
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure (all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure
procedure-arity raise-arity-error procedure-arity procedure-reduce-arity raise-arity-error
procedure->method procedure-rename procedure->method procedure-rename
chaperone-procedure) chaperone-procedure)
(all-from "reqprov.ss") (all-from "reqprov.ss")

5
collects/scribblings/inside/eval.scrbl
View File

@ -186,7 +186,10 @@ to create new namespaces.}
[int c] [int c]
[Scheme_Object** args])]{ [Scheme_Object** args])]{
Applies the procedure @var{f} to the given arguments.} Applies the procedure @var{f} to the given arguments.
Beware that the procedure can mutate @var{args} if it is the same as
the result of @cpp{scheme_current_argument_stack}.}
@function[(Scheme_Object* scheme_apply_multi @function[(Scheme_Object* scheme_apply_multi
[Scheme_Object* f] [Scheme_Object* f]

13
collects/scribblings/inside/procedures.scrbl
View File

@ -17,7 +17,9 @@ of arguments passed to the function will be checked using the arity
information. (The arity information provided to information. (The arity information provided to
@cpp{scheme_make_prim_w_arity} is also used for the Scheme @cpp{scheme_make_prim_w_arity} is also used for the Scheme
@scheme[arity] procedure.) The procedure implementation is not allowed @scheme[arity] procedure.) The procedure implementation is not allowed
to mutate the input array of arguments, although it may mutate the to mutate the input array of arguments; as an exception, the procedure
can mutate the array if it is the same a the result of
@cpp{scheme_current_argument_stack}. The procedure may mutate the
arguments themselves when appropriate (e.g., a fill in a vector arguments themselves when appropriate (e.g., a fill in a vector
argument). argument).
@ -129,3 +131,12 @@ The form of @var{prim} is defined by:
Creates a closed primitive procedure value without arity information. Creates a closed primitive procedure value without arity information.
This function is provided for backward compatibility only.} This function is provided for backward compatibility only.}
@function[(Scheme_Object** scheme_current_argument_stack)]{
Returns a pointer to an internal stack for argument passing. When the
argument array passed to a procedure corresponds to the current
argument stack address, the procedure is allowed to modify the
array. In particular, it might clear out pointers in the argument
array to allow the arguments to be reclaimed by the memory manager (if
they are not otherwise accessible).}

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

@ -89,24 +89,39 @@ from @scheme[v1] through one of the chaperone constructors (e.g.,
(and/c procedure? chaperone?)]{ (and/c procedure? chaperone?)]{
Returns a chaperoned procedure that has the same arity, name, and Returns a chaperoned procedure that has the same arity, name, and
other attributes as @scheme[proc]. The arity of @scheme[wrapper-proc] other attributes as @scheme[proc]. When the chaperoned procedure is
must include the arity of @scheme[proc]; when the chaperoned procedure applied, the arguments are first passed to @scheme[wrapper-proc], and
is applied, the arguments are first passed to @scheme[wrapper-proc]. then the results from @scheme[wrapper-proc] are passed to
@scheme[proc]. The @scheme[wrapper-proc] can also supply a procedure
that processes the results of @scheme[proc].
The result of @scheme[wrapper-proc] must be either the same number of The arity of @scheme[wrapper-proc] must include the arity of
values as supplied to it or one more than the number of supplied @scheme[proc]. The allowed keyword arguments of @scheme[wrapper-proc]
values. For each supplied value, the corresponding result must be the must be a superset of the allowed keywords of @scheme[proc]. The
same or a chaperone of (in the sense of @scheme[chaperone-of?]) the required keyword arguments of @scheme[wrapper-proc] must be a subset
supplied value. The additional result, if any, must be a procedure of the required keywords of @scheme[proc].
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.
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 If @scheme[wrapper-proc] returns the same number of values as it is
given (i.e., it does not return a procedure to chaperone given (i.e., it does not return a procedure to chaperone
@scheme[proc]'s result), then @scheme[proc] is called in @tech{tail @scheme[proc]'s result), then @scheme[proc] is called in @tech{tail
position} with respect to the call to the chaperone. 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.
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
or override chaperone-property values of @scheme[proc].} or override chaperone-property values of @scheme[proc].}

9
collects/scribblings/reference/procedures.scrbl
View File

@ -176,8 +176,13 @@ when @scheme[procedure-arity] is applied to the generated
procedure, it returns a value that is @scheme[equal?] to procedure, it returns a value that is @scheme[equal?] to
@scheme[arity]. @scheme[arity].
If the @scheme[arity] specification allows arguments that are not If the @scheme[arity] specification allows arguments that are not in
in @scheme[(procedure-arity proc)], the @exnraise[exn:fail:contract]. @scheme[(procedure-arity proc)], the @exnraise[exn:fail:contract]. If
@scheme[proc] accepts keyword argument, either the keyword arguments
must be all optional (and they are not accepted in by the
arity-reduced procedure) or @scheme[arity] must be the empty list
(which makes a procedure that cannot be called); otherwise, the
@exnraise[exn:fail:contract].
@examples[ @examples[
(define my+ (procedure-reduce-arity + 2)) (define my+ (procedure-reduce-arity + 2))

7
collects/scribblings/reference/struct-inspectors.scrbl
View File

@ -150,8 +150,11 @@ The name (if any) of a procedure is always a symbol. The
name. name.
The name of a @tech{structure}, @tech{structure type}, @tech{structure The name of a @tech{structure}, @tech{structure type}, @tech{structure
type property} is always a symbol. If a @tech{structure} is not a type property} is always a symbol. If a @tech{structure} is a
procedure, its name matches the name of the @tech{structure type} that procedure as implemented by one of its fields (i.e., the
@scheme[prop:procedure] property value for the structure's type is an
integer), then its name is the implementing procedure's name;
otherwise, its name matches the name of the @tech{structure type} that
it instantiates. it instantiates.
The name of a @tech{regexp value} is a string or byte string. Passing The name of a @tech{regexp value} is a string or byte string. Passing

2
collects/tests/future/random-future.ss
View File

@ -182,7 +182,7 @@ Errors/exceptions and other kinds of control?
(gen-exp))])) (gen-exp))]))
(define-namespace-anchor ns-here) (define-namespace-anchor ns-here)
(let ([seed (+ 1 (random (expt 2 30)))]) (let ([seed 595933061 #;(+ 1 (random (expt 2 30)))])
(printf "DrDr Ignore! random-seed ~s\n" seed) (printf "DrDr Ignore! random-seed ~s\n" seed)
(random-seed seed)) (random-seed seed))

50
collects/tests/mzscheme/chaperone.ss
View File

@ -172,6 +172,56 @@
(test (vector 'a 'b 'c) values in) (test (vector 'a 'b 'c) values in)
(test (vector 'b '(a c)) values out)) (test (vector 'b '(a c)) values out))
;; Optional keyword arguments:
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f]
[f2 (chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x))))])
(test '(1 a b) f 1)
(test '(1 a b) f2 1)
(test '(1 2 b) f 1 #:a 2)
(test '(1 2 b) f2 1 #:a 2)
(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]
[f2 (chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(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 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)

338
collects/tests/mzscheme/procs.ss
View File

@ -65,160 +65,190 @@
(,f_0_2+ ,(list 0 (make-arity-at-least 2)) () ()) (,f_0_2+ ,(list 0 (make-arity-at-least 2)) () ())
(,f1:+ 1 () #f))) (,f1:+ 1 () #f)))
(for-each (lambda (p) (let ()
(let ([a (cadr p)]) (define (try-combos procs add-chaperone)
(test a procedure-arity (car p)) (for-each (lambda (p)
(test-values (list (caddr p) (cadddr p)) (let ([a (cadr p)])
(lambda () (test a procedure-arity (car p))
(procedure-keywords (car p)))) (test-values (list (caddr p) (cadddr p))
(let ([1-ok? (let loop ([a a]) (lambda ()
(or (equal? a 1) (procedure-keywords (car p))))
(and (arity-at-least? a) (let ([1-ok? (let loop ([a a])
((arity-at-least-value a) . <= . 1)) (or (equal? a 1)
(and (list? a) (and (arity-at-least? a)
(ormap loop a))))]) ((arity-at-least-value a) . <= . 1))
(test 1-ok? procedure-arity-includes? (car p) 1) (and (list? a)
(let ([allowed (cadddr p)] (ormap loop a))))])
[required (caddr p)]) (test 1-ok? procedure-arity-includes? (car p) 1)
;; If some keyword is required, make sure that a plain ;; While we're here test renaming, etc.:
;; application fails: (test 'other object-name (procedure-rename (car p) 'other))
(unless (null? required) (test (procedure-arity (car p)) procedure-arity (procedure-rename (car p) 'other))
(err/rt-test (test (procedure-arity (car p)) procedure-arity (procedure->method (car p)))
(apply (car p) (make-list (procedure-arity (car p)) #\0)))) (unless (null? (list-tail p 4))
;; Other tests: (test (object-name (list-ref p 4)) object-name (car p)))
(if 1-ok? (let ([allowed (cadddr p)]
(cond [required (caddr p)])
[(equal? allowed '()) ;; If some keyword is required, make sure that a plain
(test (let ([auto (cddddr p)]) ;; application fails:
(cond (unless (null? required)
[(equal? auto '((#:a #:b))) '(1 0 1)] (err/rt-test
[(equal? auto '((#:a))) '(1 0)] (apply (car p) (make-list (procedure-arity (car p)) #\0))))
[(equal? auto '((#:a))) '(1 0)] ;; Other tests:
[else '(1)])) (if 1-ok?
(car p) 1) (cond
(err/rt-test ((car p) 1 #:a 0)) [(equal? allowed '())
(err/rt-test ((car p) 1 #:b 0)) (test (let ([auto (let ([q (cddddr p)])
(err/rt-test ((car p) 1 #:a 0 #:b 0))] (if (null? q)
[(equal? allowed '(#:a)) q
(test (if (pair? (cddddr p)) (cdr q)))])
'(10 20 1) ; dropped #:b (cond
'(10 20)) [(equal? auto '((#:a #:b))) '(1 0 1)]
(car p) 10 #:a 20) [(equal? auto '((#:a))) '(1 0)]
(err/rt-test ((car p) 1 #:b 0)) [(equal? auto '((#:a))) '(1 0)]
(err/rt-test ((car p) 1 #:a 0 #:b 0))] [else '(1)]))
[(equal? allowed '(#:b)) (car p) 1)
(test '(10.0 20.0) (car p) 10.0 #:b 20.0) (err/rt-test ((car p) 1 #:a 0))
(err/rt-test ((car p) 1 #:a 0)) (err/rt-test ((car p) 1 #:b 0))
(err/rt-test ((car p) 1 #:a 0 #:b 0))] (err/rt-test ((car p) 1 #:a 0 #:b 0))]
[(equal? allowed '(#:a #:b)) [(equal? allowed '(#:a))
(test '(100 200 300) (car p) 100 #:b 300 #:a 200) (test (if (and (pair? (cddddr p))
(err/rt-test ((car p) 1 #:a 0 #:b 0 #:c 3))] (pair? (cddddr (cdr p))))
[(equal? allowed #f) '(10 20 1) ; dropped #:b
(test '(1 2 3) (car p) 1 #:b 3 #:a 2)]) '(10 20))
(begin (car p) 10 #:a 20)
;; Try just 1: (err/rt-test ((car p) 1 #:b 0))
(err/rt-test ((car p) 1)) (err/rt-test ((car p) 1 #:a 0 #:b 0))]
;; Try with right keyword args, to make sure the by-position [(equal? allowed '(#:b))
;; arity is checked: (test '(10.0 20.0) (car p) 10.0 #:b 20.0)
(cond (err/rt-test ((car p) 1 #:a 0))
[(equal? allowed '()) (err/rt-test ((car p) 1 #:a 0 #:b 0))]
(void)] [(equal? allowed '(#:a #:b))
[(equal? allowed '(#:a)) (test '(100 200 300) (car p) 100 #:b 300 #:a 200)
(err/rt-test ((car p) 1 #:a 1))] (err/rt-test ((car p) 1 #:a 0 #:b 0 #:c 3))]
[(equal? allowed '(#:b)) [(equal? allowed #f)
(err/rt-test ((car p) 1 #:b 1))] (test '(1 2 3) (car p) 1 #:b 3 #:a 2)])
[(equal? allowed '(#:a #:b)) (begin
(err/rt-test ((car p) 1 #:a 1 #:b 1))] ;; Try just 1:
[(equal? allowed #f) (err/rt-test ((car p) 1))
(err/rt-test ((car p) 1 #:a 1 #:b 1))]))))))) ;; Try with right keyword args, to make sure the by-position
(append procs ;; arity is checked:
;; reduce to arity 1 or nothing: (cond
(map (lambda (p) [(equal? allowed '())
(let ([p (car p)]) (void)]
(let-values ([(req allowed) (procedure-keywords p)]) [(equal? allowed '(#:a))
(if (null? allowed) (err/rt-test ((car p) 1 #:a 1))]
(if (procedure-arity-includes? p 1) [(equal? allowed '(#:b))
(list (procedure-reduce-arity p 1) 1 req allowed) (err/rt-test ((car p) 1 #:b 1))]
(list (procedure-reduce-arity p '()) '() req allowed)) [(equal? allowed '(#:a #:b))
(if (procedure-arity-includes? p 1) (err/rt-test ((car p) 1 #:a 1 #:b 1))]
(list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed) [(equal? allowed #f)
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed)))))) (err/rt-test ((car p) 1 #:a 1 #:b 1))])))))))
procs) (map
;; reduce to arity 0 or nothing: add-chaperone
(map (lambda (p) (append procs
(let ([p (car p)]) ;; reduce to arity 1 or nothing:
(let-values ([(req allowed) (procedure-keywords p)]) (map (lambda (p)
(if (null? allowed) (let ([p (car p)])
(if (procedure-arity-includes? p 0) (let-values ([(req allowed) (procedure-keywords p)])
(list (procedure-reduce-arity p 0) 0 req allowed) (if (null? allowed)
(list (procedure-reduce-arity p '()) '() req allowed)) (if (procedure-arity-includes? p 1)
(if (procedure-arity-includes? p 0) (list (procedure-reduce-arity p 1) 1 req allowed p)
(list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed) (list (procedure-reduce-arity p '()) '() req allowed p))
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed)))))) (if (procedure-arity-includes? p 1)
procs) (list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed p)
;; reduce to arity 1 or nothing --- no keywords: (list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p))))))
(map (lambda (p) procs)
(let ([p (car p)]) ;; reduce to arity 0 or nothing:
(let-values ([(req allowed) (procedure-keywords p)]) (map (lambda (p)
(if (and (procedure-arity-includes? p 1) (let ([p (car p)])
(null? req)) (let-values ([(req allowed) (procedure-keywords p)])
(list* (procedure-reduce-arity p 1) 1 '() '() (if (null? allowed)
(if (null? allowed) (if (procedure-arity-includes? p 0)
null (list (procedure-reduce-arity p 0) 0 req allowed p)
(list allowed))) (list (procedure-reduce-arity p '()) '() req allowed p))
(list (procedure-reduce-arity p '()) '() '() '()))))) (if (procedure-arity-includes? p 0)
procs) (list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed p)
;; reduce to arity 0 or nothing --- no keywords: (list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p))))))
(map (lambda (p) procs)
(let ([p (car p)]) ;; reduce to arity 1 or nothing --- no keywords:
(let-values ([(req allowed) (procedure-keywords p)]) (map (lambda (p)
(if (and (procedure-arity-includes? p 0) (let ([p (car p)])
(null? req)) (let-values ([(req allowed) (procedure-keywords p)])
(list (procedure-reduce-arity p 0) 0 '() '()) (if (and (procedure-arity-includes? p 1)
(list (procedure-reduce-arity p '()) '() '() '()))))) (null? req))
procs) (list* (procedure-reduce-arity p 1) 1 '() '() p
;; make #:a required, if possible: (if (null? allowed)
(map (lambda (p) null
(let-values ([(req allowed) (procedure-keywords (car p))]) (list allowed)))
(let ([new-req (if (member '#:a req) (list (procedure-reduce-arity p '()) '() '() '() p)))))
req procs)
(cons '#:a req))]) ;; reduce to arity 0 or nothing --- no keywords:
(list (procedure-reduce-keyword-arity (map (lambda (p)
(car p) (let ([p (car p)])
(cadr p) (let-values ([(req allowed) (procedure-keywords p)])
new-req (if (and (procedure-arity-includes? p 0)
allowed) (null? req))
(cadr p) (list (procedure-reduce-arity p 0) 0 '() '() p)
new-req (list (procedure-reduce-arity p '()) '() '() '() p)))))
allowed)))) procs)
(filter (lambda (p) ;; make #:a required, if possible:
(let-values ([(req allowed) (procedure-keywords (car p))]) (map (lambda (p)
(or (not allowed) (let-values ([(req allowed) (procedure-keywords (car p))])
(memq '#:a allowed)))) (let ([new-req (if (member '#:a req)
procs)) req
;; remove #:b, if allowed and not required: (cons '#:a req))])
(map (lambda (p) (list (procedure-reduce-keyword-arity
(let-values ([(req allowed) (procedure-keywords (car p))]) (car p)
(let ([new-allowed (if allowed (cadr p)
(remove '#:b allowed) new-req
'(#:a))]) allowed)
(list* (procedure-reduce-keyword-arity (cadr p)
(car p) new-req
(cadr p) allowed
req (car p)))))
new-allowed) (filter (lambda (p)
(cadr p) (let-values ([(req allowed) (procedure-keywords (car p))])
req (or (not allowed)
new-allowed (memq '#:a allowed))))
(if allowed procs))
(list allowed) ;; remove #:b, if allowed and not required:
'()))))) (map (lambda (p)
(filter (lambda (p) (let-values ([(req allowed) (procedure-keywords (car p))])
(let-values ([(req allowed) (procedure-keywords (car p))]) (let ([new-allowed (if allowed
(and (or (not allowed) (remove '#:b allowed)
(memq '#:b allowed)) '(#:a))])
(not (memq '#:b req))))) (list* (procedure-reduce-keyword-arity
procs)))) (car p)
(cadr p)
req
new-allowed)
(cadr p)
req
new-allowed
(car p)
(if allowed
(list allowed)
'())))))
(filter (lambda (p)
(let-values ([(req allowed) (procedure-keywords (car p))])
(and (or (not allowed)
(memq '#:b allowed))
(not (memq '#:b req)))))
procs))))))
(try-combos procs values)
(let ([add-chaperone (lambda (p)
(cons
(chaperone-procedure
(car p)
(make-keyword-procedure
(lambda (kws kw-args . rest)
(if (null? kws)
(apply values rest)
(apply values kw-args rest)))))
(cdr p)))])
(try-combos procs add-chaperone)
(try-combos (map add-chaperone procs) values)
(try-combos (map add-chaperone procs) add-chaperone)))
;; ---------------------------------------- ;; ----------------------------------------

3
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 4.2.5.3
Added chaperones
Version 4.2.5, March 2010 Version 4.2.5, March 2010
Added scheme/future, enabled by default on main platforms Added scheme/future, enabled by default on main platforms
Changed module to wrap each body expression in a prompt Changed module to wrap each body expression in a prompt

3
src/mred/gc2/Makefile.in
View File

@ -215,7 +215,8 @@ xsrc/wx_xbm.cc: $(WXDIR)/utils/image/src/wx_xbm.cc $(XFORMDEP)
MACXPRECOMP = macxsrc/xform_precomp.h MACXPRECOMP = macxsrc/xform_precomp.h
MACXPRECOMPDEP = MACXPRECOMPDEP =
macxsrc/xform_precomp.h : $(XFORMDEP) $(srcdir)/macprecomp.cxx $(srcdir)/../../mzscheme/src/schvers.h macxsrc/xform_precomp.h : $(XFORMDEP) $(srcdir)/macprecomp.cxx $(srcdir)/../../mzscheme/src/schvers.h \
$(srcdir)/../../mzscheme/src/schemef.h
env XFORM_PRECOMP=yes $(XFORMXX) $(MACXPRECOMP) $(srcdir)/macprecomp.cxx env XFORM_PRECOMP=yes $(XFORMXX) $(MACXPRECOMP) $(srcdir)/macprecomp.cxx
@INCLUDEDEP@ macprecomp.dd @INCLUDEDEP@ macprecomp.dd

1
src/mzscheme/include/mzscheme.exp
View File

@ -151,6 +151,7 @@ _scheme_apply_known_prim_closure
_scheme_apply_known_prim_closure_multi _scheme_apply_known_prim_closure_multi
_scheme_apply_prim_closure _scheme_apply_prim_closure
_scheme_apply_prim_closure_multi _scheme_apply_prim_closure_multi
scheme_current_argument_stack
scheme_call_with_prompt scheme_call_with_prompt
scheme_call_with_prompt_multi scheme_call_with_prompt_multi
_scheme_call_with_prompt _scheme_call_with_prompt

1
src/mzscheme/include/mzscheme3m.exp
View File

@ -151,6 +151,7 @@ _scheme_apply_known_prim_closure
_scheme_apply_known_prim_closure_multi _scheme_apply_known_prim_closure_multi
_scheme_apply_prim_closure _scheme_apply_prim_closure
_scheme_apply_prim_closure_multi _scheme_apply_prim_closure_multi
scheme_current_argument_stack
scheme_call_with_prompt scheme_call_with_prompt
scheme_call_with_prompt_multi scheme_call_with_prompt_multi
_scheme_call_with_prompt _scheme_call_with_prompt

1
src/mzscheme/include/mzwin.def
View File

@ -145,6 +145,7 @@ EXPORTS
scheme_eval_string_multi_with_prompt scheme_eval_string_multi_with_prompt
scheme_eval_string_all_with_prompt scheme_eval_string_all_with_prompt
scheme_eval_module_string scheme_eval_module_string
scheme_current_argument_stack
scheme_call_with_prompt scheme_call_with_prompt
scheme_call_with_prompt_multi scheme_call_with_prompt_multi
scheme_values scheme_values

1
src/mzscheme/include/mzwin3m.def
View File

@ -145,6 +145,7 @@ EXPORTS
scheme_eval_string_multi_with_prompt scheme_eval_string_multi_with_prompt
scheme_eval_string_all_with_prompt scheme_eval_string_all_with_prompt
scheme_eval_module_string scheme_eval_module_string
scheme_current_argument_stack
scheme_call_with_prompt scheme_call_with_prompt
scheme_call_with_prompt_multi scheme_call_with_prompt_multi
scheme_values scheme_values

5
src/mzscheme/src/error.c
View File

@ -991,7 +991,10 @@ static char *make_arity_expect_string(const char *name, int namelen,
} else { } else {
Scheme_Object *v; Scheme_Object *v;
int is_method; int is_method;
v = scheme_extract_struct_procedure((Scheme_Object *)name, -1, NULL, &is_method); v = (Scheme_Object *)name;
if (SCHEME_CHAPERONEP(v))
v = SCHEME_CHAPERONE_VAL(v);
v = scheme_extract_struct_procedure(v, -1, NULL, &is_method);
if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v)) if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v))
break; break;
name = (const char *)v; name = (const char *)v;

5
src/mzscheme/src/eval.c
View File

@ -9941,6 +9941,11 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
#endif #endif
} }
Scheme_Object **scheme_current_argument_stack()
{
return MZ_RUNSTACK;
}
/*========================================================================*/ /*========================================================================*/
/* eval/compile/expand starting points */ /* eval/compile/expand starting points */
/*========================================================================*/ /*========================================================================*/

31
src/mzscheme/src/fun.c
View File

@ -3352,6 +3352,8 @@ Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a)
/* Either use struct name, or extract proc, depending /* Either use struct name, or extract proc, depending
whether it's method-style */ whether it's method-style */
int is_method; int is_method;
if (SCHEME_CHAPERONEP(a))
a = SCHEME_CHAPERONE_VAL(a);
b = scheme_extract_struct_procedure(a, -1, NULL, &is_method); b = scheme_extract_struct_procedure(a, -1, NULL, &is_method);
if (!is_method && SCHEME_PROCP(b)) { if (!is_method && SCHEME_PROCP(b)) {
a = b; a = b;
@ -4074,8 +4076,23 @@ static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Obje
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val) Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val)
{ {
Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *v, *a[1], *a2[1], **argv2, *post, *result_v; Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v;
int c, i; int c, i, need_restore = 0;
if (argv == MZ_RUNSTACK) {
/* Pushing onto the runstack ensures that px->redirects won't
modify argv. */
if (MZ_RUNSTACK > MZ_RUNSTACK_START) {
--MZ_RUNSTACK;
*MZ_RUNSTACK = NULL;
need_restore = 1;
} else {
/* Can't push! Just allocate a copy. */
argv2 = MALLOC_N(Scheme_Object *, argc);
memcpy(argv2, argv, sizeof(Scheme_Object*) * argc);
argv = argv2;
}
}
v = _scheme_apply_multi(px->redirects, argc, argv); v = _scheme_apply_multi(px->redirects, argc, argv);
if (v == SCHEME_MULTIPLE_VALUES) { if (v == SCHEME_MULTIPLE_VALUES) {
@ -4114,6 +4131,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
return NULL; return NULL;
} }
if (need_restore) {
/* As a step toward space safety, even clear out the arguments
form the runstack: */
MZ_RUNSTACK++;
for (i = 0; i < argc; i++) {
argv[i] = NULL;
}
} else
argv = NULL;
if (c == argc) { if (c == argc) {
/* No filter for the result, so tail call: */ /* No filter for the result, so tail call: */
if (auto_val) { if (auto_val) {

2
src/mzscheme/src/print.c
View File

@ -2091,6 +2091,8 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_utf8_string(pp, "procedure:", 0, 10); print_utf8_string(pp, "procedure:", 0, 10);
name = ((Scheme_Structure *)obj)->slots[2]; name = ((Scheme_Structure *)obj)->slots[2];
} else { } else {
if (SCHEME_PROCP(obj))
print_utf8_string(pp, "procedure:", 0, 10);
name = SCHEME_STRUCT_NAME_SYM(obj); name = SCHEME_STRUCT_NAME_SYM(obj);
} }

2
src/mzscheme/src/schemef.h
View File

@ -298,6 +298,8 @@ MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator, int ar
MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator, int argc, MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator, int argc,
Scheme_Object **argv); Scheme_Object **argv);
MZ_EXTERN Scheme_Object **scheme_current_argument_stack();
MZ_EXTERN Scheme_Object *scheme_call_with_prompt(Scheme_Closed_Prim f, void *data); MZ_EXTERN Scheme_Object *scheme_call_with_prompt(Scheme_Closed_Prim f, void *data);
MZ_EXTERN Scheme_Object *scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data); MZ_EXTERN Scheme_Object *scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data);
MZ_EXTERN Scheme_Object *_scheme_call_with_prompt(Scheme_Closed_Prim f, void *data); MZ_EXTERN Scheme_Object *_scheme_call_with_prompt(Scheme_Closed_Prim f, void *data);

1
src/mzscheme/src/schemex.h
View File

@ -243,6 +243,7 @@ Scheme_Object *(*_scheme_apply_prim_closure)(Scheme_Object *rator, int argc,
Scheme_Object **argv); Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_prim_closure_multi)(Scheme_Object *rator, int argc, Scheme_Object *(*_scheme_apply_prim_closure_multi)(Scheme_Object *rator, int argc,
Scheme_Object **argv); Scheme_Object **argv);
Scheme_Object **(*scheme_current_argument_stack)();
Scheme_Object *(*scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data); Scheme_Object *(*scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data);
Scheme_Object *(*scheme_call_with_prompt_multi)(Scheme_Closed_Prim f, void *data); Scheme_Object *(*scheme_call_with_prompt_multi)(Scheme_Closed_Prim f, void *data);
Scheme_Object *(*_scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data); Scheme_Object *(*_scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data);

1
src/mzscheme/src/schemex.inc
View File

@ -159,6 +159,7 @@
scheme_extension_table->_scheme_apply_known_prim_closure_multi = _scheme_apply_known_prim_closure_multi; scheme_extension_table->_scheme_apply_known_prim_closure_multi = _scheme_apply_known_prim_closure_multi;
scheme_extension_table->_scheme_apply_prim_closure = _scheme_apply_prim_closure; scheme_extension_table->_scheme_apply_prim_closure = _scheme_apply_prim_closure;
scheme_extension_table->_scheme_apply_prim_closure_multi = _scheme_apply_prim_closure_multi; scheme_extension_table->_scheme_apply_prim_closure_multi = _scheme_apply_prim_closure_multi;
scheme_extension_table->scheme_current_argument_stack = scheme_current_argument_stack;
scheme_extension_table->scheme_call_with_prompt = scheme_call_with_prompt; scheme_extension_table->scheme_call_with_prompt = scheme_call_with_prompt;
scheme_extension_table->scheme_call_with_prompt_multi = scheme_call_with_prompt_multi; scheme_extension_table->scheme_call_with_prompt_multi = scheme_call_with_prompt_multi;
scheme_extension_table->_scheme_call_with_prompt = _scheme_call_with_prompt; scheme_extension_table->_scheme_call_with_prompt = _scheme_call_with_prompt;

1
src/mzscheme/src/schemexm.h
View File

@ -159,6 +159,7 @@
#define _scheme_apply_known_prim_closure_multi (scheme_extension_table->_scheme_apply_known_prim_closure_multi) #define _scheme_apply_known_prim_closure_multi (scheme_extension_table->_scheme_apply_known_prim_closure_multi)
#define _scheme_apply_prim_closure (scheme_extension_table->_scheme_apply_prim_closure) #define _scheme_apply_prim_closure (scheme_extension_table->_scheme_apply_prim_closure)
#define _scheme_apply_prim_closure_multi (scheme_extension_table->_scheme_apply_prim_closure_multi) #define _scheme_apply_prim_closure_multi (scheme_extension_table->_scheme_apply_prim_closure_multi)
#define scheme_current_argument_stack (scheme_extension_table->scheme_current_argument_stack)
#define scheme_call_with_prompt (scheme_extension_table->scheme_call_with_prompt) #define scheme_call_with_prompt (scheme_extension_table->scheme_call_with_prompt)
#define scheme_call_with_prompt_multi (scheme_extension_table->scheme_call_with_prompt_multi) #define scheme_call_with_prompt_multi (scheme_extension_table->scheme_call_with_prompt_multi)
#define _scheme_call_with_prompt (scheme_extension_table->_scheme_call_with_prompt) #define _scheme_call_with_prompt (scheme_extension_table->_scheme_call_with_prompt)

2
src/mzscheme/src/struct.c
View File

@ -4347,7 +4347,7 @@ static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv)
if (!SCHEME_PROCP(argv[0])) if (!SCHEME_PROCP(argv[0]))
scheme_wrong_type("procedure-extract-target", "procedure", 0, argc, argv); scheme_wrong_type("procedure-extract-target", "procedure", 0, argc, argv);
if (SCHEME_CHAPERONE_STRUCTP(argv[0])) { if (SCHEME_STRUCTP(argv[0])) { /* don't allow chaperones */
/* Don't expose arity reducer: */ /* Don't expose arity reducer: */
if (scheme_reduced_procedure_struct if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, argv[0])) && scheme_is_struct_instance(scheme_reduced_procedure_struct, argv[0]))