fix the interaction of chaperones, keywords, and the whole zoo of reflective procedure operations
svn: r18711
This commit is contained in:
Matthew Flatt
parent
853db0ae55
commit
b2d65a1b95
|
|
@ -14,9 +14,10 @@
|
|||
(#%provide new-lambda new-λ
|
||||
new-define
|
||||
new-app
|
||||
(rename *make-keyword-procedure make-keyword-procedure)
|
||||
make-keyword-procedure
|
||||
keyword-apply
|
||||
procedure-keywords
|
||||
new:procedure-reduce-arity
|
||||
procedure-reduce-keyword-arity
|
||||
new-prop:procedure
|
||||
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!)
|
||||
(make-struct-type 'keyword-procedure #f 4 0 #f
|
||||
(list (cons prop:checked-procedure #t))
|
||||
|
|
@ -113,7 +114,7 @@
|
|||
struct:okp
|
||||
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))
|
||||
|
||||
;; Constructor generator for a procedure with a required keyword.
|
||||
|
|
@ -123,13 +124,15 @@
|
|||
;; the right arity, and that sends all arguments to `missing-kw'.
|
||||
(define (make-required name fail-proc method?)
|
||||
(let-values ([(s: mk ? -ref -set!)
|
||||
(make-struct-type (string->symbol (format "procedure:~a" name))
|
||||
(make-struct-type (or name 'unknown)
|
||||
(if method?
|
||||
struct:keyword-method
|
||||
struct:keyword-procedure)
|
||||
0 0 #f
|
||||
(list (cons prop:arity-string generate-arity-string)
|
||||
(cons prop:named-keyword-procedure name))
|
||||
(list (cons prop:arity-string
|
||||
generate-arity-string)
|
||||
(cons prop:named-keyword-procedure
|
||||
(cons name fail-proc)))
|
||||
(current-inspector) fail-proc)])
|
||||
mk))
|
||||
|
||||
|
|
@ -140,21 +143,19 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define *make-keyword-procedure
|
||||
(letrec ([make-keyword-procedure
|
||||
(case-lambda
|
||||
[(proc) (make-keyword-procedure
|
||||
proc
|
||||
(lambda args
|
||||
(apply proc null null args)))]
|
||||
[(proc plain-proc)
|
||||
(make-optional-keyword-procedure
|
||||
(make-keyword-checker null #f (procedure-arity proc))
|
||||
proc
|
||||
null
|
||||
#f
|
||||
plain-proc)])])
|
||||
make-keyword-procedure))
|
||||
(define make-keyword-procedure
|
||||
(case-lambda
|
||||
[(proc) (make-keyword-procedure
|
||||
proc
|
||||
(lambda args
|
||||
(apply proc null null args)))]
|
||||
[(proc plain-proc)
|
||||
(make-optional-keyword-procedure
|
||||
(make-keyword-checker null #f (procedure-arity proc))
|
||||
proc
|
||||
null
|
||||
#f
|
||||
plain-proc)]))
|
||||
|
||||
(define (keyword-apply proc kws kw-vals . normal-argss)
|
||||
(let ([type-error
|
||||
|
|
@ -943,7 +944,7 @@
|
|||
raise-type-error 'x "x" 0 'x
|
||||
(append args (apply append (map list kws kw-args))))))]
|
||||
[proc-name (lambda (p) (or (and (named-keyword-procedure? p)
|
||||
(keyword-procedure-name p))
|
||||
(car (keyword-procedure-name+fail p)))
|
||||
(object-name p)
|
||||
p))])
|
||||
(raise
|
||||
|
|
@ -986,13 +987,6 @@
|
|||
[(null? (cdr kws)) #t]
|
||||
[(keyword<? (car kws) (cadr kws)) (loop (cdr kws))]
|
||||
[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)
|
||||
(sorted? req-kw))
|
||||
|
|
@ -1054,7 +1048,7 @@
|
|||
;; Some keywords are required, so "plain" proc is
|
||||
;; irrelevant; we build a new one that wraps `missing-kws'.
|
||||
((make-required (or (and (named-keyword-procedure? proc)
|
||||
(keyword-procedure-name proc))
|
||||
(car (keyword-procedure-name+fail proc)))
|
||||
(object-name proc))
|
||||
(procedure-reduce-arity
|
||||
missing-kw
|
||||
|
|
@ -1065,11 +1059,45 @@
|
|||
new-kw-proc
|
||||
req-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
|
||||
(let ([procedure->method
|
||||
(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))
|
||||
|
||||
(define new:procedure-rename
|
||||
|
|
@ -1078,11 +1106,130 @@
|
|||
(if (not (and (keyword-procedure? proc)
|
||||
(symbol? 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))
|
||||
|
||||
(define new:chaperone-procedure
|
||||
(let ([chaperone-procedure
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -73,11 +73,12 @@
|
|||
(rename module-begin #%module-begin)
|
||||
(rename norm:procedure-arity procedure-arity)
|
||||
(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-rename procedure-rename)
|
||||
(rename new:chaperone-procedure chaperone-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
|
||||
chaperone-procedure)
|
||||
(all-from "reqprov.ss")
|
||||
|
|
|
|||
|
|
@ -186,7 +186,10 @@ to create new namespaces.}
|
|||
[int c]
|
||||
[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
|
||||
[Scheme_Object* f]
|
||||
|
|
|
|||
|
|
@ -17,7 +17,9 @@ of arguments passed to the function will be checked using the arity
|
|||
information. (The arity information provided to
|
||||
@cpp{scheme_make_prim_w_arity} is also used for the Scheme
|
||||
@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
|
||||
argument).
|
||||
|
||||
|
|
@ -129,3 +131,12 @@ The form of @var{prim} is defined by:
|
|||
|
||||
Creates a closed primitive procedure value without arity information.
|
||||
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).}
|
||||
|
|
|
|||
|
|
@ -89,24 +89,39 @@ from @scheme[v1] through one of the chaperone constructors (e.g.,
|
|||
(and/c procedure? chaperone?)]{
|
||||
|
||||
Returns a chaperoned procedure that has the same arity, name, and
|
||||
other attributes as @scheme[proc]. The arity of @scheme[wrapper-proc]
|
||||
must include the arity of @scheme[proc]; when the chaperoned procedure
|
||||
is applied, the arguments are first passed to @scheme[wrapper-proc].
|
||||
other attributes as @scheme[proc]. When the chaperoned procedure is
|
||||
applied, the arguments are first passed to @scheme[wrapper-proc], and
|
||||
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
|
||||
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.
|
||||
The arity of @scheme[wrapper-proc] must include the arity of
|
||||
@scheme[proc]. The allowed keyword arguments of @scheme[wrapper-proc]
|
||||
must be a superset of the allowed keywords of @scheme[proc]. The
|
||||
required keyword arguments of @scheme[wrapper-proc] must be a subset
|
||||
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.
|
||||
|
||||
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
|
||||
to @scheme[procedure-chaperone] must be even) add chaperone properties
|
||||
or override chaperone-property values of @scheme[proc].}
|
||||
|
|
|
|||
|
|
@ -176,8 +176,13 @@ when @scheme[procedure-arity] is applied to the generated
|
|||
procedure, it returns a value that is @scheme[equal?] to
|
||||
@scheme[arity].
|
||||
|
||||
If the @scheme[arity] specification allows arguments that are not
|
||||
in @scheme[(procedure-arity proc)], the @exnraise[exn:fail:contract].
|
||||
If the @scheme[arity] specification allows arguments that are not in
|
||||
@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[
|
||||
(define my+ (procedure-reduce-arity + 2))
|
||||
|
|
|
|||
|
|
@ -150,8 +150,11 @@ The name (if any) of a procedure is always a symbol. The
|
|||
name.
|
||||
|
||||
The name of a @tech{structure}, @tech{structure type}, @tech{structure
|
||||
type property} is always a symbol. If a @tech{structure} is not a
|
||||
procedure, its name matches the name of the @tech{structure type} that
|
||||
type property} is always a symbol. If a @tech{structure} is a
|
||||
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.
|
||||
|
||||
The name of a @tech{regexp value} is a string or byte string. Passing
|
||||
|
|
|
|||
|
|
@ -182,7 +182,7 @@ Errors/exceptions and other kinds of control?
|
|||
(gen-exp))]))
|
||||
|
||||
(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)
|
||||
(random-seed seed))
|
||||
|
||||
|
|
|
|||
|
|
@ -172,6 +172,56 @@
|
|||
(test (vector 'a 'b 'c) values in)
|
||||
(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 y))) 1))
|
||||
(err/rt-test ((chaperone-procedure (lambda (x) (values x x)) (lambda (y) y))) 1)
|
||||
|
|
|
|||
|
|
@ -65,160 +65,190 @@
|
|||
(,f_0_2+ ,(list 0 (make-arity-at-least 2)) () ())
|
||||
(,f1:+ 1 () #f)))
|
||||
|
||||
(for-each (lambda (p)
|
||||
(let ([a (cadr p)])
|
||||
(test a procedure-arity (car p))
|
||||
(test-values (list (caddr p) (cadddr p))
|
||||
(lambda ()
|
||||
(procedure-keywords (car p))))
|
||||
(let ([1-ok? (let loop ([a a])
|
||||
(or (equal? a 1)
|
||||
(and (arity-at-least? a)
|
||||
((arity-at-least-value a) . <= . 1))
|
||||
(and (list? a)
|
||||
(ormap loop a))))])
|
||||
(test 1-ok? procedure-arity-includes? (car p) 1)
|
||||
(let ([allowed (cadddr p)]
|
||||
[required (caddr p)])
|
||||
;; If some keyword is required, make sure that a plain
|
||||
;; application fails:
|
||||
(unless (null? required)
|
||||
(err/rt-test
|
||||
(apply (car p) (make-list (procedure-arity (car p)) #\0))))
|
||||
;; Other tests:
|
||||
(if 1-ok?
|
||||
(cond
|
||||
[(equal? allowed '())
|
||||
(test (let ([auto (cddddr p)])
|
||||
(cond
|
||||
[(equal? auto '((#:a #:b))) '(1 0 1)]
|
||||
[(equal? auto '((#:a))) '(1 0)]
|
||||
[(equal? auto '((#:a))) '(1 0)]
|
||||
[else '(1)]))
|
||||
(car p) 1)
|
||||
(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))]
|
||||
[(equal? allowed '(#:a))
|
||||
(test (if (pair? (cddddr p))
|
||||
'(10 20 1) ; dropped #:b
|
||||
'(10 20))
|
||||
(car p) 10 #:a 20)
|
||||
(err/rt-test ((car p) 1 #:b 0))
|
||||
(err/rt-test ((car p) 1 #:a 0 #:b 0))]
|
||||
[(equal? allowed '(#:b))
|
||||
(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 #:b 0))]
|
||||
[(equal? allowed '(#:a #:b))
|
||||
(test '(100 200 300) (car p) 100 #:b 300 #:a 200)
|
||||
(err/rt-test ((car p) 1 #:a 0 #:b 0 #:c 3))]
|
||||
[(equal? allowed #f)
|
||||
(test '(1 2 3) (car p) 1 #:b 3 #:a 2)])
|
||||
(begin
|
||||
;; Try just 1:
|
||||
(err/rt-test ((car p) 1))
|
||||
;; Try with right keyword args, to make sure the by-position
|
||||
;; arity is checked:
|
||||
(cond
|
||||
[(equal? allowed '())
|
||||
(void)]
|
||||
[(equal? allowed '(#:a))
|
||||
(err/rt-test ((car p) 1 #:a 1))]
|
||||
[(equal? allowed '(#:b))
|
||||
(err/rt-test ((car p) 1 #:b 1))]
|
||||
[(equal? allowed '(#:a #:b))
|
||||
(err/rt-test ((car p) 1 #:a 1 #:b 1))]
|
||||
[(equal? allowed #f)
|
||||
(err/rt-test ((car p) 1 #:a 1 #:b 1))])))))))
|
||||
(append procs
|
||||
;; reduce to arity 1 or nothing:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (null? allowed)
|
||||
(if (procedure-arity-includes? p 1)
|
||||
(list (procedure-reduce-arity p 1) 1 req allowed)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed))
|
||||
(if (procedure-arity-includes? p 1)
|
||||
(list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed)
|
||||
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed))))))
|
||||
procs)
|
||||
;; reduce to arity 0 or nothing:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (null? allowed)
|
||||
(if (procedure-arity-includes? p 0)
|
||||
(list (procedure-reduce-arity p 0) 0 req allowed)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed))
|
||||
(if (procedure-arity-includes? p 0)
|
||||
(list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed)
|
||||
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed))))))
|
||||
procs)
|
||||
;; reduce to arity 1 or nothing --- no keywords:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (and (procedure-arity-includes? p 1)
|
||||
(null? req))
|
||||
(list* (procedure-reduce-arity p 1) 1 '() '()
|
||||
(if (null? allowed)
|
||||
null
|
||||
(list allowed)))
|
||||
(list (procedure-reduce-arity p '()) '() '() '())))))
|
||||
procs)
|
||||
;; reduce to arity 0 or nothing --- no keywords:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (and (procedure-arity-includes? p 0)
|
||||
(null? req))
|
||||
(list (procedure-reduce-arity p 0) 0 '() '())
|
||||
(list (procedure-reduce-arity p '()) '() '() '())))))
|
||||
procs)
|
||||
;; make #:a required, if possible:
|
||||
(map (lambda (p)
|
||||
(let-values ([(req allowed) (procedure-keywords (car p))])
|
||||
(let ([new-req (if (member '#:a req)
|
||||
req
|
||||
(cons '#:a req))])
|
||||
(list (procedure-reduce-keyword-arity
|
||||
(car p)
|
||||
(cadr p)
|
||||
new-req
|
||||
allowed)
|
||||
(cadr p)
|
||||
new-req
|
||||
allowed))))
|
||||
(filter (lambda (p)
|
||||
(let-values ([(req allowed) (procedure-keywords (car p))])
|
||||
(or (not allowed)
|
||||
(memq '#:a allowed))))
|
||||
procs))
|
||||
;; remove #:b, if allowed and not required:
|
||||
(map (lambda (p)
|
||||
(let-values ([(req allowed) (procedure-keywords (car p))])
|
||||
(let ([new-allowed (if allowed
|
||||
(remove '#:b allowed)
|
||||
'(#:a))])
|
||||
(list* (procedure-reduce-keyword-arity
|
||||
(car p)
|
||||
(cadr p)
|
||||
req
|
||||
new-allowed)
|
||||
(cadr p)
|
||||
req
|
||||
new-allowed
|
||||
(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))))
|
||||
(let ()
|
||||
(define (try-combos procs add-chaperone)
|
||||
(for-each (lambda (p)
|
||||
(let ([a (cadr p)])
|
||||
(test a procedure-arity (car p))
|
||||
(test-values (list (caddr p) (cadddr p))
|
||||
(lambda ()
|
||||
(procedure-keywords (car p))))
|
||||
(let ([1-ok? (let loop ([a a])
|
||||
(or (equal? a 1)
|
||||
(and (arity-at-least? a)
|
||||
((arity-at-least-value a) . <= . 1))
|
||||
(and (list? a)
|
||||
(ormap loop a))))])
|
||||
(test 1-ok? procedure-arity-includes? (car p) 1)
|
||||
;; While we're here test renaming, etc.:
|
||||
(test 'other object-name (procedure-rename (car p) 'other))
|
||||
(test (procedure-arity (car p)) procedure-arity (procedure-rename (car p) 'other))
|
||||
(test (procedure-arity (car p)) procedure-arity (procedure->method (car p)))
|
||||
(unless (null? (list-tail p 4))
|
||||
(test (object-name (list-ref p 4)) object-name (car p)))
|
||||
(let ([allowed (cadddr p)]
|
||||
[required (caddr p)])
|
||||
;; If some keyword is required, make sure that a plain
|
||||
;; application fails:
|
||||
(unless (null? required)
|
||||
(err/rt-test
|
||||
(apply (car p) (make-list (procedure-arity (car p)) #\0))))
|
||||
;; Other tests:
|
||||
(if 1-ok?
|
||||
(cond
|
||||
[(equal? allowed '())
|
||||
(test (let ([auto (let ([q (cddddr p)])
|
||||
(if (null? q)
|
||||
q
|
||||
(cdr q)))])
|
||||
(cond
|
||||
[(equal? auto '((#:a #:b))) '(1 0 1)]
|
||||
[(equal? auto '((#:a))) '(1 0)]
|
||||
[(equal? auto '((#:a))) '(1 0)]
|
||||
[else '(1)]))
|
||||
(car p) 1)
|
||||
(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))]
|
||||
[(equal? allowed '(#:a))
|
||||
(test (if (and (pair? (cddddr p))
|
||||
(pair? (cddddr (cdr p))))
|
||||
'(10 20 1) ; dropped #:b
|
||||
'(10 20))
|
||||
(car p) 10 #:a 20)
|
||||
(err/rt-test ((car p) 1 #:b 0))
|
||||
(err/rt-test ((car p) 1 #:a 0 #:b 0))]
|
||||
[(equal? allowed '(#:b))
|
||||
(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 #:b 0))]
|
||||
[(equal? allowed '(#:a #:b))
|
||||
(test '(100 200 300) (car p) 100 #:b 300 #:a 200)
|
||||
(err/rt-test ((car p) 1 #:a 0 #:b 0 #:c 3))]
|
||||
[(equal? allowed #f)
|
||||
(test '(1 2 3) (car p) 1 #:b 3 #:a 2)])
|
||||
(begin
|
||||
;; Try just 1:
|
||||
(err/rt-test ((car p) 1))
|
||||
;; Try with right keyword args, to make sure the by-position
|
||||
;; arity is checked:
|
||||
(cond
|
||||
[(equal? allowed '())
|
||||
(void)]
|
||||
[(equal? allowed '(#:a))
|
||||
(err/rt-test ((car p) 1 #:a 1))]
|
||||
[(equal? allowed '(#:b))
|
||||
(err/rt-test ((car p) 1 #:b 1))]
|
||||
[(equal? allowed '(#:a #:b))
|
||||
(err/rt-test ((car p) 1 #:a 1 #:b 1))]
|
||||
[(equal? allowed #f)
|
||||
(err/rt-test ((car p) 1 #:a 1 #:b 1))])))))))
|
||||
(map
|
||||
add-chaperone
|
||||
(append procs
|
||||
;; reduce to arity 1 or nothing:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (null? allowed)
|
||||
(if (procedure-arity-includes? p 1)
|
||||
(list (procedure-reduce-arity p 1) 1 req allowed p)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed p))
|
||||
(if (procedure-arity-includes? p 1)
|
||||
(list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed p)
|
||||
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p))))))
|
||||
procs)
|
||||
;; reduce to arity 0 or nothing:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (null? allowed)
|
||||
(if (procedure-arity-includes? p 0)
|
||||
(list (procedure-reduce-arity p 0) 0 req allowed p)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed p))
|
||||
(if (procedure-arity-includes? p 0)
|
||||
(list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed p)
|
||||
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p))))))
|
||||
procs)
|
||||
;; reduce to arity 1 or nothing --- no keywords:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (and (procedure-arity-includes? p 1)
|
||||
(null? req))
|
||||
(list* (procedure-reduce-arity p 1) 1 '() '() p
|
||||
(if (null? allowed)
|
||||
null
|
||||
(list allowed)))
|
||||
(list (procedure-reduce-arity p '()) '() '() '() p)))))
|
||||
procs)
|
||||
;; reduce to arity 0 or nothing --- no keywords:
|
||||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (and (procedure-arity-includes? p 0)
|
||||
(null? req))
|
||||
(list (procedure-reduce-arity p 0) 0 '() '() p)
|
||||
(list (procedure-reduce-arity p '()) '() '() '() p)))))
|
||||
procs)
|
||||
;; make #:a required, if possible:
|
||||
(map (lambda (p)
|
||||
(let-values ([(req allowed) (procedure-keywords (car p))])
|
||||
(let ([new-req (if (member '#:a req)
|
||||
req
|
||||
(cons '#:a req))])
|
||||
(list (procedure-reduce-keyword-arity
|
||||
(car p)
|
||||
(cadr p)
|
||||
new-req
|
||||
allowed)
|
||||
(cadr p)
|
||||
new-req
|
||||
allowed
|
||||
(car p)))))
|
||||
(filter (lambda (p)
|
||||
(let-values ([(req allowed) (procedure-keywords (car p))])
|
||||
(or (not allowed)
|
||||
(memq '#:a allowed))))
|
||||
procs))
|
||||
;; remove #:b, if allowed and not required:
|
||||
(map (lambda (p)
|
||||
(let-values ([(req allowed) (procedure-keywords (car p))])
|
||||
(let ([new-allowed (if allowed
|
||||
(remove '#:b allowed)
|
||||
'(#:a))])
|
||||
(list* (procedure-reduce-keyword-arity
|
||||
(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)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,6 @@
|
|||
Version 4.2.5.3
|
||||
Added chaperones
|
||||
|
||||
Version 4.2.5, March 2010
|
||||
Added scheme/future, enabled by default on main platforms
|
||||
Changed module to wrap each body expression in a prompt
|
||||
|
|
|
|||
|
|
@ -215,7 +215,8 @@ xsrc/wx_xbm.cc: $(WXDIR)/utils/image/src/wx_xbm.cc $(XFORMDEP)
|
|||
MACXPRECOMP = macxsrc/xform_precomp.h
|
||||
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
|
||||
|
||||
@INCLUDEDEP@ macprecomp.dd
|
||||
|
|
|
|||
|
|
@ -151,6 +151,7 @@ _scheme_apply_known_prim_closure
|
|||
_scheme_apply_known_prim_closure_multi
|
||||
_scheme_apply_prim_closure
|
||||
_scheme_apply_prim_closure_multi
|
||||
scheme_current_argument_stack
|
||||
scheme_call_with_prompt
|
||||
scheme_call_with_prompt_multi
|
||||
_scheme_call_with_prompt
|
||||
|
|
|
|||
|
|
@ -151,6 +151,7 @@ _scheme_apply_known_prim_closure
|
|||
_scheme_apply_known_prim_closure_multi
|
||||
_scheme_apply_prim_closure
|
||||
_scheme_apply_prim_closure_multi
|
||||
scheme_current_argument_stack
|
||||
scheme_call_with_prompt
|
||||
scheme_call_with_prompt_multi
|
||||
_scheme_call_with_prompt
|
||||
|
|
|
|||
|
|
@ -145,6 +145,7 @@ EXPORTS
|
|||
scheme_eval_string_multi_with_prompt
|
||||
scheme_eval_string_all_with_prompt
|
||||
scheme_eval_module_string
|
||||
scheme_current_argument_stack
|
||||
scheme_call_with_prompt
|
||||
scheme_call_with_prompt_multi
|
||||
scheme_values
|
||||
|
|
|
|||
|
|
@ -145,6 +145,7 @@ EXPORTS
|
|||
scheme_eval_string_multi_with_prompt
|
||||
scheme_eval_string_all_with_prompt
|
||||
scheme_eval_module_string
|
||||
scheme_current_argument_stack
|
||||
scheme_call_with_prompt
|
||||
scheme_call_with_prompt_multi
|
||||
scheme_values
|
||||
|
|
|
|||
|
|
@ -991,7 +991,10 @@ static char *make_arity_expect_string(const char *name, int namelen,
|
|||
} else {
|
||||
Scheme_Object *v;
|
||||
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))
|
||||
break;
|
||||
name = (const char *)v;
|
||||
|
|
|
|||
|
|
@ -9941,6 +9941,11 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
|
|||
#endif
|
||||
}
|
||||
|
||||
Scheme_Object **scheme_current_argument_stack()
|
||||
{
|
||||
return MZ_RUNSTACK;
|
||||
}
|
||||
|
||||
/*========================================================================*/
|
||||
/* eval/compile/expand starting points */
|
||||
/*========================================================================*/
|
||||
|
|
|
|||
|
|
@ -3352,6 +3352,8 @@ Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a)
|
|||
/* Either use struct name, or extract proc, depending
|
||||
whether it's method-style */
|
||||
int is_method;
|
||||
if (SCHEME_CHAPERONEP(a))
|
||||
a = SCHEME_CHAPERONE_VAL(a);
|
||||
b = scheme_extract_struct_procedure(a, -1, NULL, &is_method);
|
||||
if (!is_method && SCHEME_PROCP(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_Chaperone *px = (Scheme_Chaperone *)o;
|
||||
Scheme_Object *v, *a[1], *a2[1], **argv2, *post, *result_v;
|
||||
int c, i;
|
||||
Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v;
|
||||
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);
|
||||
if (v == SCHEME_MULTIPLE_VALUES) {
|
||||
|
|
@ -4114,6 +4131,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
|
|||
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) {
|
||||
/* No filter for the result, so tail call: */
|
||||
if (auto_val) {
|
||||
|
|
|
|||
|
|
@ -2091,6 +2091,8 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
|
|||
print_utf8_string(pp, "procedure:", 0, 10);
|
||||
name = ((Scheme_Structure *)obj)->slots[2];
|
||||
} else {
|
||||
if (SCHEME_PROCP(obj))
|
||||
print_utf8_string(pp, "procedure:", 0, 10);
|
||||
name = SCHEME_STRUCT_NAME_SYM(obj);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
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_multi(Scheme_Closed_Prim f, void *data);
|
||||
MZ_EXTERN Scheme_Object *_scheme_call_with_prompt(Scheme_Closed_Prim f, void *data);
|
||||
|
|
|
|||
|
|
@ -243,6 +243,7 @@ Scheme_Object *(*_scheme_apply_prim_closure)(Scheme_Object *rator, int argc,
|
|||
Scheme_Object **argv);
|
||||
Scheme_Object *(*_scheme_apply_prim_closure_multi)(Scheme_Object *rator, int argc,
|
||||
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_multi)(Scheme_Closed_Prim f, void *data);
|
||||
Scheme_Object *(*_scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data);
|
||||
|
|
|
|||
|
|
@ -159,6 +159,7 @@
|
|||
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_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_multi = scheme_call_with_prompt_multi;
|
||||
scheme_extension_table->_scheme_call_with_prompt = _scheme_call_with_prompt;
|
||||
|
|
|
|||
|
|
@ -159,6 +159,7 @@
|
|||
#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_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_multi (scheme_extension_table->scheme_call_with_prompt_multi)
|
||||
#define _scheme_call_with_prompt (scheme_extension_table->_scheme_call_with_prompt)
|
||||
|
|
|
|||
|
|
@ -4347,7 +4347,7 @@ static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv)
|
|||
if (!SCHEME_PROCP(argv[0]))
|
||||
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: */
|
||||
if (scheme_reduced_procedure_struct
|
||||
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, argv[0]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user