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

add {impersonate,chaperone}-procedure*

Browse Source 
The new variants pass a "self" argument to the wrapper procedure in
the same way that `{impersonate,chaperone}-struct` provides a "self"
argument to redirection procedures.
This commit is contained in:
Matthew Flatt 2014-11-12 09:29:13 -07:00
parent 50a8863169
commit 1681126ed5
13 changed files with 1496 additions and 1256 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "6.1.1.4") (define version "6.1.1.5")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

35
pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl
View File

@ -216,6 +216,28 @@ mark during the call to @racket[wrapper-proc] (which allows tail-calls
of impersonators with respect to wrapping impersonators to be detected within of impersonators with respect to wrapping impersonators to be detected within
@racket[wrapper-proc]).} @racket[wrapper-proc]).}
@defproc[(impersonate-procedure* [proc procedure?]
[wrapper-proc (or/c procedure? #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? impersonator?)]{
Like @racket[impersonate-procedure], except that @racket[wrapper-proc]
receives an additional argument before all other arguments. The
additional argument is the procedure @racket[_orig-proc] that was
original applied.
If the result of @racket[impersonate-procedure*] is applied directly,
then @racket[_orig-proc] is that result. If the result is further
impersonated before being applied, however, @racket[_orig-proc] is the
further impersonator.
An @racket[_orig-proc] argument might be useful so that
@racket[wrapper-proc] can extract @tech{impersonator properties}
that are overridden by further impersonators, for example.
@history[#:added "6.1.1.5"]}
@defproc[(impersonate-struct [v any/c] @defproc[(impersonate-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure? [orig-proc (or/c struct-accessor-procedure?
@ -583,6 +605,19 @@ chaperone procedure (i.e., not counting optional arguments that were
not supplied). The arguments must be ordered according to the sorted not supplied). The arguments must be ordered according to the sorted
order of the supplied arguments' keywords.} order of the supplied arguments' keywords.}
@defproc[(chaperone-procedure* [proc procedure?]
[wrapper-proc (or/c procedure? #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? chaperone?)]{
Like @racket[chaperone-procedure], but @racket[wrapper-proc] receives
an extra argument as with @racket[impersonate-procedure*].
@history[#:added "6.1.1.5"]}
@defproc[(chaperone-struct [v any/c] @defproc[(chaperone-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure? [orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure? struct-mutator-procedure?

107
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

@ -13,10 +13,10 @@
(test #t impersonator? a) (test #t impersonator? a)
(chaperone? a)) (chaperone? a))
(define-syntax-rule (as-chaperone-or-impersonator ([orig impersonator] ...) body ...) (define-syntax-rule (as-chaperone-or-impersonator ([orig impersonator ...] ...) body ...)
(for-each (lambda (orig ...) (for-each (lambda (orig ...)
body ...) body ...)
(list orig impersonator) ...)) (list orig impersonator ...) ...))
;; ---------------------------------------- ;; ----------------------------------------
@ -59,14 +59,24 @@
(let* ([p (lambda (x) x)] (let* ([p (lambda (x) x)]
[p1 (impersonate-procedure p (lambda (y) y))] [p1 (impersonate-procedure p (lambda (y) y))]
[p2 (chaperone-procedure p1 (lambda (y) y))]) [p2 (chaperone-procedure p1 (lambda (y) y))]
[p1* (impersonate-procedure* p (lambda (self y) y))]
[p2* (chaperone-procedure* p1 (lambda (self y) y))])
(test #t impersonator-of? p2 p) (test #t impersonator-of? p2 p)
(test #t impersonator-of? p2 p1) (test #t impersonator-of? p2 p1)
(test #t impersonator? p1) (test #t impersonator? p1)
(test #f chaperone? p1) (test #f chaperone? p1)
(test #t chaperone? p2) (test #t chaperone? p2)
(test #f chaperone-of? p2 p) (test #f chaperone-of? p2 p)
(test #t chaperone-of? p2 p1)) (test #t chaperone-of? p2 p1)
(test #t impersonator-of? p2* p)
(test #t impersonator-of? p2* p1)
(test #t impersonator? p1*)
(test #f chaperone? p1*)
(test #t chaperone? p2*)
(test #f chaperone-of? p2* p)
(test #t chaperone-of? p2* p1))
;; ---------------------------------------- ;; ----------------------------------------
@ -211,14 +221,30 @@
(test #t chaperone?/impersonator (chaperone-procedure (lambda (x) x) (lambda (y) y))) (test #t chaperone?/impersonator (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t impersonator? (impersonate-procedure (lambda (x) x) (lambda (y) y))) (test #t impersonator? (impersonate-procedure (lambda (x) x) (lambda (y) y)))
(test #t impersonator? (impersonate-procedure* (lambda (x) x) (lambda (self y) y)))
(test #t procedure? (chaperone-procedure (lambda (x) x) (lambda (y) y))) (test #t procedure? (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t procedure? (chaperone-procedure* (lambda (x) x) (lambda (self y) y)))
(test #t procedure? (impersonate-procedure (lambda (x) x) (lambda (y) y))) (test #t procedure? (impersonate-procedure (lambda (x) x) (lambda (y) y)))
(test #t procedure? (impersonate-procedure* (lambda (x) x) (lambda (self y) y)))
(test #t (lambda (x) (procedure? x)) (chaperone-procedure (lambda (x) x) (lambda (y) y))) (test #t (lambda (x) (procedure? x)) (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t (lambda (x) (procedure? x)) (impersonate-procedure (lambda (x) x) (lambda (y) y))) (test #t (lambda (x) (procedure? x)) (impersonate-procedure (lambda (x) x) (lambda (y) y)))
(err/rt-test (chaperone-procedure (lambda (x) x) (lambda (y z) y))) (err/rt-test (chaperone-procedure (lambda (x) x) (lambda (y z) y)))
(err/rt-test (impersonate-procedure (lambda (x) x) (lambda (y z) y))) (err/rt-test (impersonate-procedure (lambda (x) x) (lambda (y z) y)))
(err/rt-test (chaperone-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y))) (err/rt-test (chaperone-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(err/rt-test (impersonate-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y))) (err/rt-test (impersonate-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(err/rt-test (chaperone-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(err/rt-test (impersonate-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(err/rt-test (chaperone-procedure* (lambda (x) x) (lambda (y) y)))
(err/rt-test (impersonate-procedure* (lambda (x) x) (lambda (y) y)))
(err/rt-test (chaperone-procedure* (lambda (x) x) (lambda (self z y) y)))
(err/rt-test (impersonate-procedure* (lambda (x) x) (lambda (self z y) y)))
(err/rt-test (chaperone-procedure* (case-lambda [() 0] [(x) x]) (lambda (self y) y)))
(err/rt-test (chaperone-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [() 0] [(self y) y])))
(err/rt-test (impersonate-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [() 0] [(self y) y])))
(err/rt-test (chaperone-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [(self) 0] [(self z y) y])))
(err/rt-test (impersonate-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [(self) 0] [(self z y) y])))
(test #t procedure? (chaperone-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [(self) 0] [(self y) y])))
(test #t procedure? (impersonate-procedure* (case-lambda [() 0] [(x) x]) (case-lambda [(self) 0] [(self y) y])))
(test 88 (impersonate-procedure (lambda (x) x) (lambda (y) 88)) 10) (test 88 (impersonate-procedure (lambda (x) x) (lambda (y) 88)) 10)
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) 88)) 10)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) 88)) 10))
@ -226,9 +252,52 @@
(test 89 (impersonate-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10) (test 89 (impersonate-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10)
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10))
(test 88 (impersonate-procedure* (lambda (x) x) (lambda (self y) 88)) 10)
(letrec ([final (impersonate-procedure*
(impersonate-procedure
(impersonate-procedure* (lambda (x) x)
(lambda (self y)
(test #t eq? self final)
(add1 y)))
(lambda (y)
(add1 y)))
(lambda (self y)
(test #t eq? self final)
(add1 y)))])
(test 13 final 10))
(letrec ([final (impersonate-procedure*
(impersonate-procedure
(impersonate-procedure* (lambda (x) x)
(lambda (self y)
(test #t eq? self final)
(values list (add1 y))))
(lambda (y)
(values list (add1 y))))
(lambda (self y)
(test #t eq? self final)
(values list (add1 y))))])
(test '(((13))) final 10))
(define (chaperone-procedure** a b)
(chaperone-procedure* a (lambda (self . args)
(apply b args))))
(define (impersonate-procedure** a b)
(impersonate-procedure* a (lambda (self . args)
(apply b args))))
(define (chaperone-procedure**/kw a b)
(chaperone-procedure* a (make-keyword-procedure
(lambda (kws kw-args self . args)
(keyword-apply b kws kw-args args)))))
(define (impersonate-procedure**/kw a b)
(impersonate-procedure* a (make-keyword-procedure
(lambda (kws kw-args self . args)
(keyword-apply b kws kw-args args)))))
;; Single argument, no post filter: ;; Single argument, no post filter:
(as-chaperone-or-impersonator (as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure]) ([chaperone-procedure impersonate-procedure
chaperone-procedure**
impersonate-procedure**])
(let* ([f (lambda (x) (list x x))] (let* ([f (lambda (x) (list x x))]
[in #f] [in #f]
[f2 (chaperone-procedure [f2 (chaperone-procedure
@ -243,7 +312,9 @@
;; Multiple arguments, no post filter: ;; Multiple arguments, no post filter:
(as-chaperone-or-impersonator (as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure]) ([chaperone-procedure impersonate-procedure
chaperone-procedure**
impersonate-procedure**])
(let* ([f (lambda (x y) (list x y))] (let* ([f (lambda (x y) (list x y))]
[in #f] [in #f]
[f2 (chaperone-procedure [f2 (chaperone-procedure
@ -258,7 +329,9 @@
;; Single argument, post filter on single value: ;; Single argument, post filter on single value:
(as-chaperone-or-impersonator (as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure]) ([chaperone-procedure impersonate-procedure
chaperone-procedure**
impersonate-procedure**])
(let* ([f (lambda (x) (list x x))] (let* ([f (lambda (x) (list x x))]
[in #f] [in #f]
[out #f] [out #f]
@ -279,7 +352,9 @@
;; Multiple arguments, post filter on multiple values: ;; Multiple arguments, post filter on multiple values:
(as-chaperone-or-impersonator (as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure]) ([chaperone-procedure impersonate-procedure
chaperone-procedure**
impersonate-procedure**])
(let* ([f (lambda (x y z) (values y (list x z)))] (let* ([f (lambda (x y z) (values y (list x z)))]
[in #f] [in #f]
[out #f] [out #f]
@ -300,7 +375,9 @@
;; Optional keyword arguments: ;; Optional keyword arguments:
(as-chaperone-or-impersonator (as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure]) ([chaperone-procedure impersonate-procedure
chaperone-procedure**/kw
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))] (let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f] [in #f]
[f2 (chaperone-procedure [f2 (chaperone-procedure
@ -327,7 +404,9 @@
;; Optional keyword arguments with result chaperone: ;; Optional keyword arguments with result chaperone:
(as-chaperone-or-impersonator (as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure]) ([chaperone-procedure impersonate-procedure
chaperone-procedure**/kw
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))] (let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f] [in #f]
[out #f] [out #f]
@ -360,7 +439,9 @@
;; Required keyword arguments: ;; Required keyword arguments:
(as-chaperone-or-impersonator (as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure]) ([chaperone-procedure impersonate-procedure
chaperone-procedure**/kw
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))] (let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f] [in #f]
[f2 (chaperone-procedure [f2 (chaperone-procedure
@ -387,7 +468,9 @@
;; Required keyword arguments: ;; Required keyword arguments:
(as-chaperone-or-impersonator (as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure]) ([chaperone-procedure impersonate-procedure
chaperone-procedure**/kw
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))] (let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f] [in #f]
[out #f] [out #f]

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

@ -27,6 +27,8 @@
new:procedure-rename new:procedure-rename
new:chaperone-procedure new:chaperone-procedure
new:impersonate-procedure new:impersonate-procedure
new:chaperone-procedure*
new:impersonate-procedure*
(for-syntax kw-expander? kw-expander-impl kw-expander-proc (for-syntax kw-expander? kw-expander-impl kw-expander-proc
syntax-procedure-alias-property syntax-procedure-alias-property
syntax-procedure-converted-arguments-property)) syntax-procedure-converted-arguments-property))
@ -1524,16 +1526,28 @@
(define new:chaperone-procedure (define new:chaperone-procedure
(let ([chaperone-procedure (let ([chaperone-procedure
(lambda (proc wrap-proc . props) (lambda (proc wrap-proc . props)
(do-chaperone-procedure #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))]) (do-chaperone-procedure #f #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
chaperone-procedure)) chaperone-procedure))
(define new:impersonate-procedure (define new:impersonate-procedure
(let ([impersonate-procedure (let ([impersonate-procedure
(lambda (proc wrap-proc . props) (lambda (proc wrap-proc . props)
(do-chaperone-procedure #t impersonate-procedure 'impersonate-procedure proc wrap-proc props))]) (do-chaperone-procedure #t #f impersonate-procedure 'impersonate-procedure proc wrap-proc props))])
impersonate-procedure)) impersonate-procedure))
(define (do-chaperone-procedure is-impersonator? chaperone-procedure name proc wrap-proc props) (define new:chaperone-procedure*
(let ([chaperone-procedure*
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #f #t chaperone-procedure* 'chaperone-procedure proc wrap-proc props))])
chaperone-procedure*))
(define new:impersonate-procedure*
(let ([impersonate-procedure*
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #t #t impersonate-procedure* 'impersonate-procedure proc wrap-proc props))])
impersonate-procedure*))
(define (do-chaperone-procedure is-impersonator? self-arg? chaperone-procedure name proc wrap-proc props)
(let ([n-proc (normalize-proc proc)] (let ([n-proc (normalize-proc proc)]
[n-wrap-proc (normalize-proc wrap-proc)]) [n-wrap-proc (normalize-proc wrap-proc)])
(if (or (not (keyword-procedure? n-proc)) (if (or (not (keyword-procedure? n-proc))
@ -1550,20 +1564,21 @@
(apply chaperone-procedure proc wrap-proc props) (apply chaperone-procedure proc wrap-proc props)
(let-values ([(a) (procedure-arity proc)] (let-values ([(a) (procedure-arity proc)]
[(b) (procedure-arity wrap-proc)] [(b) (procedure-arity wrap-proc)]
[(d) (if self-arg? 1 0)]
[(a-req a-allow) (procedure-keywords proc)] [(a-req a-allow) (procedure-keywords proc)]
[(b-req b-allow) (procedure-keywords wrap-proc)]) [(b-req b-allow) (procedure-keywords wrap-proc)])
(define (includes? a b) (define (includes? a b)
(cond (cond
[(number? b) (cond [(number? b) (cond
[(number? a) (= b a)] [(number? a) (= b (+ a d))]
[(arity-at-least? a) [(arity-at-least? a)
(b . >= . (arity-at-least-value a))] (b . >= . (+ (arity-at-least-value a) d))]
[else [else
(ormap (lambda (a) (includes? a b)) a)])] (ormap (lambda (a) (includes? a b)) a)])]
[(arity-at-least? b) (cond [(arity-at-least? b) (cond
[(number? a) #f] [(number? a) #f]
[(arity-at-least? a) [(arity-at-least? a)
((arity-at-least-value b) . >= . (arity-at-least-value a))] ((arity-at-least-value b) . >= . (+ (arity-at-least-value a) d))]
[else (ormap (lambda (a) (includes? b a)) a)])] [else (ormap (lambda (a) (includes? b a)) a)])]
[else (andmap (lambda (b) (includes? a b)) b)])) [else (andmap (lambda (b) (includes? a b)) b)]))
@ -1586,54 +1601,61 @@
"original procedure" proc)) "original procedure" proc))
(let*-values ([(kw-chaperone) (let*-values ([(kw-chaperone)
(let ([p (keyword-procedure-proc n-wrap-proc)]) (let ([p (keyword-procedure-proc n-wrap-proc)])
(case-lambda ;; `extra-arg ...` will be `self-proc` if `self-arg?`:
[(kws args . rest) (define-syntax gen-wrapper
(call-with-values (lambda () (apply p kws args rest)) (syntax-rules ()
(lambda results [(_ extra-arg ...)
(let* ([len (length results)] (case-lambda
[alen (length rest)]) [(extra-arg ... kws args . rest)
(unless (<= (+ alen 1) len (+ alen 2)) (call-with-values (lambda () (apply p kws args extra-arg ... rest))
(raise-arguments-error (lambda results
'|keyword procedure chaperone| (let* ([len (length results)]
"wrong number of results from wrapper procedure" [alen (length rest)])
"expected minimum number of results" (+ alen 1) (unless (<= (+ alen 1) len (+ alen 2))
"expected maximum number of results" (+ alen 2) (raise-arguments-error
"received number of results" len '|keyword procedure chaperone|
"wrapper procedure" wrap-proc)) "wrong number of results from wrapper procedure"
(let ([extra? (= len (+ alen 2))]) "expected minimum number of results" (+ alen 1)
(let ([new-args ((if extra? cadr car) results)]) "expected maximum number of results" (+ alen 2)
(unless (and (list? new-args) "received number of results" len
(= (length new-args) (length args))) "wrapper procedure" wrap-proc))
(raise-arguments-error (let ([extra? (= len (+ alen 2))])
'|keyword procedure chaperone| (let ([new-args ((if extra? cadr car) results)])
(format (unless (and (list? new-args)
"expected a list of keyword-argument values as first result~a from wrapper procedure" (= (length new-args) (length args)))
(if (= len alen) (raise-arguments-error
"" '|keyword procedure chaperone|
" (after the result-wrapper procedure)")) (format
"first result" new-args "expected a list of keyword-argument values as first result~a from wrapper procedure"
"wrapper procedure" wrap-proc)) (if (= len alen)
(for-each ""
(lambda (kw new-arg arg) " (after the result-wrapper procedure)"))
(unless is-impersonator? "first result" new-args
(unless (chaperone-of? new-arg arg) "wrapper procedure" wrap-proc))
(raise-arguments-error (for-each
'|keyword procedure chaperone| (lambda (kw new-arg arg)
(format (unless is-impersonator?
"~a keyword result is not a chaperone of original argument from chaperoning procedure" (unless (chaperone-of? new-arg arg)
kw) (raise-arguments-error
"result" new-arg '|keyword procedure chaperone|
"wrapper procedure" wrap-proc)))) (format
kws "~a keyword result is not a chaperone of original argument from chaperoning procedure"
new-args kw)
args)) "result" new-arg
(if extra? "wrapper procedure" wrap-proc))))
(apply values (car results) kws (cdr results)) kws
(apply values kws results))))))] new-args
;; The following case exists only to make sure that the arity of args))
;; any procedure passed to `make-keyword-args' is covered (if extra?
;; bu this procedure's arity. (apply values (car results) kws (cdr results))
[other (error "shouldn't get here")]))] (apply values kws results))))))]
;; The following case exists only to make sure that the arity of
;; any procedure passed to `make-keyword-args' is covered
;; by this procedure's arity.
[other (error "shouldn't get here")])]))
(if self-arg?
(gen-wrapper self-proc)
(gen-wrapper)))]
[(new-proc chap-accessor) [(new-proc chap-accessor)
(let wrap ([proc proc] [n-proc n-proc]) (let wrap ([proc proc] [n-proc n-proc])
(cond (cond
@ -1664,16 +1686,24 @@
(chaperone-procedure (chaperone-procedure
proc proc
(make-keyword-procedure (make-keyword-procedure
(lambda (kws kw-args self . args) (let ()
;; Chain to `kw-chaperone', pulling out the self ;; `extra-arg ...` will be `self-proc` if `self-arg?`:
;; argument, and then putting it back: (define-syntax gen-proc
(define len (length args)) (syntax-rules ()
(call-with-values [(_ extra-arg ...)
(lambda () (apply kw-chaperone kws kw-args args)) (lambda (extra-arg ... kws kw-args self . args)
(lambda results ;; Chain to `kw-chaperone', pulling out the self
(if (= (length results) (add1 len)) ;; argument, and then putting it back:
(apply values (car results) self (cdr results)) (define len (length args))
(apply values (car results) (cadr results) self (cddr results)))))))))) (call-with-values
(lambda () (apply kw-chaperone extra-arg ... kws kw-args args))
(lambda results
(if (= (length results) (add1 len))
(apply values (car results) self (cdr results))
(apply values (car results) (cadr results) self (cddr results))))))]))
(if self-arg?
(gen-proc proc-self)
(gen-proc)))))))
new-procedure-ref)])] new-procedure-ref)])]
[(okp? n-proc) [(okp? n-proc)
(values (values
@ -1721,7 +1751,7 @@
new-proc new-proc
(apply chaperone-struct new-proc (apply chaperone-struct new-proc
;; chaperone-struct insists on having at least one selector: ;; chaperone-struct insists on having at least one selector:
chap-accessor (lambda (s v) v) chap-accessor #f
props))))))) props)))))))
(define (normalize-proc proc) (define (normalize-proc proc)

3
racket/collects/racket/private/pre-base.rkt
View File

@ -175,12 +175,15 @@
(rename new:procedure-rename procedure-rename) (rename new:procedure-rename procedure-rename)
(rename new:chaperone-procedure chaperone-procedure) (rename new:chaperone-procedure chaperone-procedure)
(rename new:impersonate-procedure impersonate-procedure) (rename new:impersonate-procedure impersonate-procedure)
(rename new:chaperone-procedure* chaperone-procedure*)
(rename new:impersonate-procedure* impersonate-procedure*)
(rename new:collection-path collection-path) (rename new:collection-path collection-path)
(rename new:collection-file-path collection-file-path) (rename new:collection-file-path collection-file-path)
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure (all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure
procedure-arity procedure-reduce-arity raise-arity-error procedure-arity procedure-reduce-arity raise-arity-error
procedure->method procedure-rename procedure->method procedure-rename
chaperone-procedure impersonate-procedure chaperone-procedure impersonate-procedure
chaperone-procedure* impersonate-procedure*
assq assv assoc assq assv assoc
prop:incomplete-arity prop:method-arity-error) prop:incomplete-arity prop:method-arity-error)
(all-from "reqprov.rkt") (all-from "reqprov.rkt")

4
racket/src/racket/include/scheme.h
View File

@ -1214,6 +1214,10 @@ typedef struct Scheme_Thread {
} k; } k;
} ku; } ku;
/* To pass the current procedure from one chaperone
layer to the next: */
Scheme_Object *self_for_proc_chaperone;
short suspend_break; short suspend_break;
short external_break; short external_break;

2300
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

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

@ -1377,6 +1377,8 @@ static Scheme_Object **evacuate_runstack(int num_rands, Scheme_Object **rands, S
static Scheme_Object *do_eval_k_readjust_mark(void) static Scheme_Object *do_eval_k_readjust_mark(void)
{ {
Scheme_Thread *p = scheme_current_thread;
p->self_for_proc_chaperone = p->ku.k.p3;
MZ_CONT_MARK_POS -= 2; /* undo increment in do_eval_stack_overflow() */ MZ_CONT_MARK_POS -= 2; /* undo increment in do_eval_stack_overflow() */
return do_eval_k(); return do_eval_k();
} }
@ -1405,6 +1407,9 @@ static Scheme_Object *do_eval_stack_overflow(Scheme_Object *obj, int num_rands,
p->ku.k.p2 = (void *)rands; p->ku.k.p2 = (void *)rands;
p->ku.k.i2 = get_value; p->ku.k.i2 = get_value;
p->ku.k.p3 = p->self_for_proc_chaperone;
p->self_for_proc_chaperone = NULL;
/* In case we got here via scheme_force_value_same_mark(), in case /* In case we got here via scheme_force_value_same_mark(), in case
overflow handling causes the thread to sleep, and in case another overflow handling causes the thread to sleep, and in case another
thread tries to get this thread's continuation marks: ensure tha thread tries to get this thread's continuation marks: ensure tha

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

@ -188,6 +188,8 @@ static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[]); static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]);
@ -608,6 +610,16 @@ scheme_init_fun (Scheme_Env *env)
"impersonate-procedure", "impersonate-procedure",
2, -1), 2, -1),
env); env);
scheme_add_global_constant("chaperone-procedure*",
scheme_make_prim_w_arity(chaperone_procedure_star,
"chaperone-procedure*",
2, -1),
env);
scheme_add_global_constant("impersonate-procedure*",
scheme_make_prim_w_arity(impersonate_procedure_star,
"impersonate-procedure*",
2, -1),
env);
scheme_add_global_constant("primitive?", scheme_add_global_constant("primitive?",
scheme_make_folding_prim(primitive_p, scheme_make_folding_prim(primitive_p,
@ -3049,15 +3061,17 @@ static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty,
return scheme_make_struct_instance(scheme_reduced_procedure_struct, 4, a); return scheme_make_struct_instance(scheme_reduced_procedure_struct, 4, a);
} }
static int is_subarity(Scheme_Object *req, Scheme_Object *orig) static int is_subarity(Scheme_Object *req, Scheme_Object *orig, int req_delta)
{ {
Scheme_Object *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp; Scheme_Object *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp, *rd;
if (!SCHEME_PAIRP(orig) && !SCHEME_NULLP(orig)) if (!SCHEME_PAIRP(orig) && !SCHEME_NULLP(orig))
orig = scheme_make_pair(orig, scheme_null); orig = scheme_make_pair(orig, scheme_null);
if (!SCHEME_PAIRP(req) && !SCHEME_NULLP(req)) if (!SCHEME_PAIRP(req) && !SCHEME_NULLP(req))
req = scheme_make_pair(req, scheme_null); req = scheme_make_pair(req, scheme_null);
rd = scheme_make_integer(req_delta);
while (!SCHEME_NULLP(req)) { while (!SCHEME_NULLP(req)) {
ra = SCHEME_CAR(req); ra = SCHEME_CAR(req);
if (SCHEME_CHAPERONE_STRUCTP(ra) if (SCHEME_CHAPERONE_STRUCTP(ra)
@ -3075,12 +3089,12 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
oa = SCHEME_CAR(ol); oa = SCHEME_CAR(ol);
if (SCHEME_INTP(ra) || SCHEME_BIGNUMP(ra)) { if (SCHEME_INTP(ra) || SCHEME_BIGNUMP(ra)) {
if (SCHEME_INTP(oa) || SCHEME_BIGNUMP(oa)) { if (SCHEME_INTP(oa) || SCHEME_BIGNUMP(oa)) {
if (scheme_equal(ra, oa)) if (scheme_equal(scheme_bin_plus(ra, rd), oa))
break; break;
} else { } else {
/* orig is arity-at-least */ /* orig is arity-at-least */
oa = ((Scheme_Structure *)oa)->slots[0]; oa = ((Scheme_Structure *)oa)->slots[0];
if (scheme_bin_lt_eq(oa, ra)) if (scheme_bin_lt_eq(oa, scheme_bin_plus(ra, rd)))
break; break;
} }
} else { } else {
@ -3100,10 +3114,10 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
/* check [lo, hi] vs oa: */ /* check [lo, hi] vs oa: */
ara = SCHEME_CAR(lra); ara = SCHEME_CAR(lra);
if (SCHEME_FALSEP(SCHEME_CDR(ara)) if (SCHEME_FALSEP(SCHEME_CDR(ara))
|| scheme_bin_lt_eq(oa, SCHEME_CDR(ara))) { || scheme_bin_lt_eq(oa, scheme_bin_plus(SCHEME_CDR(ara), rd))) {
if (scheme_bin_gt_eq(oa, SCHEME_CAR(ara))) { if (scheme_bin_gt_eq(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
/* oa is in the range [lo, hi]: */ /* oa is in the range [lo, hi]: */
if (scheme_equal(oa, SCHEME_CAR(ara))) { if (scheme_equal(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
/* the range is [oa, hi] */ /* the range is [oa, hi] */
if (at_least) { if (at_least) {
/* oa is arity-at least, so drop from here */ /* oa is arity-at least, so drop from here */
@ -3112,7 +3126,7 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
else else
ra = scheme_null; ra = scheme_null;
} else { } else {
if (scheme_equal(oa, SCHEME_CDR(ara))) { if (scheme_equal(oa, scheme_bin_plus(SCHEME_CDR(ara), rd))) {
/* the range is [oa, oa], so drop it */ /* the range is [oa, oa], so drop it */
if (prev) if (prev)
SCHEME_CDR(prev) = SCHEME_CDR(lra); SCHEME_CDR(prev) = SCHEME_CDR(lra);
@ -3121,12 +3135,14 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
} else { } else {
/* change range to [ao+1, hi] */ /* change range to [ao+1, hi] */
tmp = scheme_bin_plus(oa, scheme_make_integer(1)); tmp = scheme_bin_plus(oa, scheme_make_integer(1));
tmp = scheme_bin_minus(tmp, rd);
SCHEME_CAR(ara) = tmp; SCHEME_CAR(ara) = tmp;
} }
} }
} else if (scheme_equal(oa, SCHEME_CAR(ara))) { } else if (scheme_equal(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
/* the range is [lo, oa], where lo < oa */ /* the range is [lo, oa], where lo < oa */
tmp = scheme_bin_minus(oa, scheme_make_integer(1)); tmp = scheme_bin_minus(oa, scheme_make_integer(1));
tmp = scheme_bin_minus(tmp, rd);
SCHEME_CDR(ara) = tmp; SCHEME_CDR(ara) = tmp;
if (at_least) if (at_least)
SCHEME_CDR(lra) = scheme_null; SCHEME_CDR(lra) = scheme_null;
@ -3134,13 +3150,16 @@ static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
/* split the range */ /* split the range */
if (at_least) { if (at_least) {
tmp = scheme_bin_minus(oa, scheme_make_integer(1)); tmp = scheme_bin_minus(oa, scheme_make_integer(1));
tmp = scheme_bin_minus(tmp, rd);
SCHEME_CDR(ara) = tmp; SCHEME_CDR(ara) = tmp;
SCHEME_CDR(lra) = scheme_null; SCHEME_CDR(lra) = scheme_null;
} else { } else {
pr = scheme_make_pair(scheme_make_pair(scheme_bin_plus(oa, scheme_make_integer(1)), tmp = scheme_bin_plus(oa, scheme_make_integer(1));
SCHEME_CDR(ara)), tmp = scheme_bin_minus(tmp, rd);
pr = scheme_make_pair(scheme_make_pair(tmp, SCHEME_CDR(ara)),
SCHEME_CDR(lra)); SCHEME_CDR(lra));
tmp = scheme_bin_minus(oa, scheme_make_integer(1)); tmp = scheme_bin_minus(oa, scheme_make_integer(1));
tmp = scheme_bin_minus(tmp, rd);
SCHEME_CDR(ara) = tmp; SCHEME_CDR(ara) = tmp;
SCHEME_CDR(lra) = pr; SCHEME_CDR(lra) = pr;
} }
@ -3227,7 +3246,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
orig = get_or_check_arity(argv[0], -1, NULL, 1); orig = get_or_check_arity(argv[0], -1, NULL, 1);
aty = clone_arity(argv[1], 0, -1); aty = clone_arity(argv[1], 0, -1);
if (!is_subarity(aty, orig)) { if (!is_subarity(aty, orig, 0)) {
scheme_contract_error("procedure-reduce-arity", scheme_contract_error("procedure-reduce-arity",
"arity of procedure does not include requested arity", "arity of procedure does not include requested arity",
"procedure", 1, argv[0], "procedure", 1, argv[0],
@ -3382,7 +3401,8 @@ static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])
} }
static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating, static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating,
int is_impersonator, int argc, Scheme_Object *argv[]) int is_impersonator, int pass_self,
int argc, Scheme_Object *argv[])
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0], *orig, *naya, *r, *app_mark; Scheme_Object *val = argv[0], *orig, *naya, *r, *app_mark;
@ -3402,12 +3422,13 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
else { else {
naya = get_or_check_arity(argv[1], -1, NULL, 1); naya = get_or_check_arity(argv[1], -1, NULL, 1);
if (!is_subarity(orig, naya)) if (!is_subarity(orig, naya, pass_self ? 1 : 0))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: arity of wrapper procedure does not cover arity of original procedure\n" "%s: arity of wrapper procedure does not cover arity of original procedure%s\n"
" wrapper: %V\n" " wrapper: %V\n"
" original: %V", " original: %V",
name, name,
(pass_self ? " (adding an extra argument)": ""),
argv[1], argv[1],
argv[0]); argv[0]);
} }
@ -3439,8 +3460,12 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
px->prev = argv[0]; px->prev = argv[0];
px->props = props; px->props = props;
/* put procedure with known-good arity (to speed checking) in a vector: */ /* Put the procedure along with known-good arity (to speed checking;
r = scheme_make_vector(3, scheme_make_integer(-1)); initialized to -1) in a vector. An odd-sized vector makes the
chaperone recognized as a procedure chaperone, and a size of 5
(instead of 3) indicates that the wrapper procedure accepts a
"self" argument: */
r = scheme_make_vector((pass_self ? 5 : 3), scheme_make_integer(-1));
SCHEME_VEC_ELS(r)[0] = argv[1]; SCHEME_VEC_ELS(r)[0] = argv[1];
SCHEME_VEC_ELS(r)[2] = app_mark; SCHEME_VEC_ELS(r)[2] = app_mark;
@ -3456,12 +3481,22 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]) static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[])
{ {
return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, argc, argv); return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, 0, argc, argv);
} }
static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[]) static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[])
{ {
return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, argc, argv); return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, 0, argc, argv);
}
static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("chaperone-procedure*", "chaperoning", 0, 1, argc, argv);
}
static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("impersonate-procedure*", "impersonating", 1, 1, argc, argv);
} }
static Scheme_Object *apply_chaperone_k(void) static Scheme_Object *apply_chaperone_k(void)
@ -3539,11 +3574,12 @@ Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Ob
#define MAX_QUICK_CHAP_ARGV 5 #define MAX_QUICK_CHAP_ARGV 5
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks) Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks)
/* checks & 0x2 => no tail; checks == 0x3 => no tail or multiple; */ /* auto_val => no need to actually call the function (but handle further chaperoning);
checks & 0x2 => no tail; checks == 0x3 => no tail or multiple */
{ {
const char *what; const char *what;
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark; Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark, *self_proc;
int c, i, need_restore = 0; int c, i, need_restore = 0;
int need_pop_mark; int need_pop_mark;
Scheme_Cont_Frame_Data cframe; Scheme_Cont_Frame_Data cframe;
@ -3575,6 +3611,15 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} }
px = (Scheme_Chaperone *)o; px = (Scheme_Chaperone *)o;
{
Scheme_Thread *p = scheme_current_thread;
self_proc = p->self_for_proc_chaperone;
if (self_proc)
p->self_for_proc_chaperone = NULL;
else
self_proc = o;
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
what = "chaperone"; what = "chaperone";
else else
@ -3618,11 +3663,29 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} else } else
need_pop_mark = 0; need_pop_mark = 0;
if (SCHEME_VEC_SIZE(px->redirects) > 3) {
/* wrapper wants the "self" argument */
c = argc+1;
if (c <= MAX_QUICK_CHAP_ARGV)
argv2 = a2;
else
argv2 = MALLOC_N(Scheme_Object *, MAX_QUICK_CHAP_ARGV);
for (i = 0; i < argc; i++) {
argv2[i+1] = argv[i];
}
argv2[0] = self_proc;
} else {
/* wrapper doesn't need the extra "self" argument */
c = argc;
argv2 = argv;
}
v = SCHEME_VEC_ELS(px->redirects)[0]; v = SCHEME_VEC_ELS(px->redirects)[0];
if (SAME_TYPE(SCHEME_TYPE(v), scheme_native_closure_type)) if (SAME_TYPE(SCHEME_TYPE(v), scheme_native_closure_type))
v = _apply_native(v, argc, argv); v = _apply_native(v, c, argv2);
else else
v = _scheme_apply_multi(v, argc, argv); v = _scheme_apply_multi(v, c, argv2);
if (v == SCHEME_MULTIPLE_VALUES) { if (v == SCHEME_MULTIPLE_VALUES) {
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread; GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
c = p->ku.multiple.count; c = p->ku.multiple.count;
@ -3700,6 +3763,10 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
/* No filter for the result, so tail call: */ /* No filter for the result, so tail call: */
if (app_mark) if (app_mark)
scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark)); scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
if (SCHEME_CHAPERONEP(px->prev)) {
/* commuincate `self_proc` to the next layer: */
scheme_current_thread->self_for_proc_chaperone = self_proc;
}
if (auto_val) { if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev)) if (SCHEME_CHAPERONEP(px->prev))
return do_apply_chaperone(px->prev, c, argv2, auto_val, 0); return do_apply_chaperone(px->prev, c, argv2, auto_val, 0);
@ -3749,6 +3816,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
}else }else
need_pop_mark = 0; need_pop_mark = 0;
if (SCHEME_CHAPERONEP(px->prev)) {
/* commuincate `self_proc` to the next layer: */
scheme_current_thread->self_for_proc_chaperone = self_proc;
}
if (auto_val) { if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev)) if (SCHEME_CHAPERONEP(px->prev))
result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val, 0); result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val, 0);

4
racket/src/racket/src/mzmark_type.inc
View File

@ -1861,6 +1861,8 @@ static int thread_val_MARK(void *p, struct NewGC *gc) {
gcMARK2(pr->ku.k.p4, gc); gcMARK2(pr->ku.k.p4, gc);
gcMARK2(pr->ku.k.p5, gc); gcMARK2(pr->ku.k.p5, gc);
gcMARK2(pr->self_for_proc_chaperone, gc);
gcMARK2(pr->list_stack, gc); gcMARK2(pr->list_stack, gc);
gcMARK2(pr->kill_data, gc); gcMARK2(pr->kill_data, gc);
@ -1976,6 +1978,8 @@ static int thread_val_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(pr->ku.k.p4, gc); gcFIXUP2(pr->ku.k.p4, gc);
gcFIXUP2(pr->ku.k.p5, gc); gcFIXUP2(pr->ku.k.p5, gc);
gcFIXUP2(pr->self_for_proc_chaperone, gc);
gcFIXUP2(pr->list_stack, gc); gcFIXUP2(pr->list_stack, gc);
gcFIXUP2(pr->kill_data, gc); gcFIXUP2(pr->kill_data, gc);

2
racket/src/racket/src/mzmarksrc.c
View File

@ -768,6 +768,8 @@ thread_val {
gcMARK2(pr->ku.k.p4, gc); gcMARK2(pr->ku.k.p4, gc);
gcMARK2(pr->ku.k.p5, gc); gcMARK2(pr->ku.k.p5, gc);
gcMARK2(pr->self_for_proc_chaperone, gc);
gcMARK2(pr->list_stack, gc); gcMARK2(pr->list_stack, gc);
gcMARK2(pr->kill_data, gc); gcMARK2(pr->kill_data, gc);

4
racket/src/racket/src/schminc.h
View File

@ -12,9 +12,9 @@
finally, set EXPECTED_PRIM_COUNT to the right value and finally, set EXPECTED_PRIM_COUNT to the right value and
USE_COMPILED_STARTUP to 1 and `make' again. */ USE_COMPILED_STARTUP to 1 and `make' again. */
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 0
#define EXPECTED_PRIM_COUNT 1127 #define EXPECTED_PRIM_COUNT 1129
#define EXPECTED_UNSAFE_COUNT 106 #define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_FLFXNUM_COUNT 69 #define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45 #define EXPECTED_EXTFL_COUNT 45

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "6.1.1.4" #define MZSCHEME_VERSION "6.1.1.5"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 1 #define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)