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

Merge remote-tracking branch 'upstream/master'

Browse Source
This commit is contained in:
Georges Dupéron 2016-01-19 19:16:46 +01:00
commit c850778f7a
49 changed files with 3414 additions and 2046 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.4.0.1") (define version "6.4.0.4")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

9
pkgs/racket-doc/scribblings/raco/setup.scrbl
View File

@ -366,8 +366,8 @@ Optional @filepath{info.rkt} fields trigger additional actions by
(list src-string flags category name out-k) (list src-string flags category name out-k)
(list src-string flags category name out-k order-n)] (list src-string flags category name out-k order-n)]
[flags (list mode-symbol ...)] [flags (list mode-symbol ...)]
[category (list category-symbol) [category (list category-string-or-symbol)
(list category-symbol sort-number)] (list category-string-or-symbol sort-number)]
[name string [name string
#f] #f]
] ]
@ -542,7 +542,10 @@ Optional @filepath{info.rkt} fields trigger additional actions by
source file need not be present. Moving documentation into place source file need not be present. Moving documentation into place
may require no movement at all, depending on the way that the may require no movement at all, depending on the way that the
enclosing collection is installed, but movement includes adding a enclosing collection is installed, but movement includes adding a
@filepath{synced.rktd} file to represent the installation.} @filepath{synced.rktd} file to represent the installation.
@history[#:changed "6.4" @elem{Allow a category to be a string
instead of a symbol.}]}
@item{@as-index{@racketidfont{release-note-files}} : @racket[(listof (cons/c string? (cons/c string? list?)))] --- @item{@as-index{@racketidfont{release-note-files}} : @racket[(listof (cons/c string? (cons/c string? list?)))] ---
A list of release-notes text files to link from the main documentation pages. A list of release-notes text files to link from the main documentation pages.

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

@ -783,7 +783,6 @@ or structure type.
#:changed "6.1.1.8" @elem{Added optional @racket[struct-type] #:changed "6.1.1.8" @elem{Added optional @racket[struct-type]
argument.}]} argument.}]}
@defproc[(chaperone-vector [vec vector?] @defproc[(chaperone-vector [vec vector?]
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)] [ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)] [set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]

20
pkgs/racket-doc/scribblings/reference/procedures.scrbl
View File

@ -230,6 +230,26 @@ list is also in the second list.
(procedure-keywords (lambda (#:tag t #:mode [m #f]) t)) (procedure-keywords (lambda (#:tag t #:mode [m #f]) t))
]} ]}
@defproc[(procedure-result-arity [proc procedure?]) (or/c #f procedure-arity?)]{
Returns the arity of the result of the procedure @racket[proc] or
@racket[#f] if the number of results are not known, perhaps due to shortcomings
in the implementation of @racket[procedure-result-arity] or
because @racket[proc]'s behavior is not sufficiently simple.
@mz-examples[(procedure-result-arity car)
(procedure-result-arity values)
(procedure-result-arity
(λ (x)
(apply
values
(let loop ()
(cond
[(zero? (random 10)) '()]
[else (cons 1 (loop))])))))]
@history[#:added "6.4.0.3"]
}
@defproc[(make-keyword-procedure @defproc[(make-keyword-procedure
[proc (((listof keyword?) list?) () #:rest list? . ->* . any)] [proc (((listof keyword?) list?) () #:rest list? . ->* . any)]
[plain-proc procedure? (lambda args (apply proc null null args))]) [plain-proc procedure? (lambda args (apply proc null null args))])

87
pkgs/racket-doc/scribblings/reference/unsafe.scrbl
View File

@ -434,4 +434,91 @@ fixnum).}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section{Unsafe Impersonators and Chaperones}
@defproc[(unsafe-impersonate-procedure [proc procedure?]
[replacement-proc procedure?]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? impersonator?)]{
Like @racket[impersonate-procedure], except it assumes that @racket[replacement-proc]
is already properly wrapping @racket[proc] and so when the procedure that
@racket[unsafe-impersonate-procedure] produces is invoked, the
@racket[replacement-proc] is invoked directly, ignoring @racket[proc].
In addition, it does not specially handle @racket[impersonator-prop:application-mark],
instead just treating it as an ordinary property if it is supplied as one of the
@racket[prop] arguments.
This procedure is unsafe only in how it assumes @racket[replacement-proc] is
a proper wrapper for @racket[proc]. It otherwise does all of the checking
that @racket[impersonate-procedure] does.
As an example, this function:
@racketblock[(λ (f)
(unsafe-impersonate-procedure
f
(λ (x)
(if (number? x)
(error 'no-numbers!)
(f x)))))]
is equivalent to this one:
@racketblock[(λ (f)
(impersonate-procedure
f
(λ (x)
(if (number? x)
(error 'no-numbers!)
x))))]
(except that some error messages start with @litchar{unsafe-impersonate-procedure}
instead of @litchar{impersonate-procedure}).
Similarly the two procedures @racket[_wrap-f1] and
@racket[_wrap-f2] are almost equivalent; they differ only
in the error message produced when their arguments are
functions that return multiple values (and that they update
different global variables). The version using @racket[unsafe-impersonate-procedure]
will signal an error in the @racket[let] expression about multiple
value return, whereas the one using @racket[impersonate-procedure] signals
an error from @racket[impersonate-procedure] about multiple value return.
@racketblock[(define log1-args '())
(define log1-results '())
(define wrap-f1
(λ (f)
(impersonate-procedure
f
(λ (arg)
(set! log1-args (cons arg log1-args))
(values (λ (res)
(set! log1-results (cons res log1-results))
res)
arg)))))
(define log2-args '())
(define log2-results '())
(define wrap-f2
(λ (f)
(unsafe-impersonate-procedure
f
(λ (arg)
(set! log2-args (cons arg log2-args))
(let ([res (f arg)])
(set! log2-results (cons res log2-results))
res)))))]
@history[#:added "6.4.0.4"]
}
@defproc[(unsafe-chaperone-procedure [proc procedure?]
[wrapper-proc procedure?]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? chaperone?)]{
Like @racket[unsafe-impersonate-procedure], but creates a @tech{chaperone}.
@history[#:added "6.4.0.4"]
}
@; ------------------------------------------------------------------------
@include-section["unsafe-undefined.scrbl"] @include-section["unsafe-undefined.scrbl"]

112
pkgs/racket-test-core/tests/racket/chaperone.rktl
View File

@ -3,6 +3,10 @@
(load-relative "loadtest.rktl") (load-relative "loadtest.rktl")
(Section 'chaperones) (Section 'chaperones)
(require (only-in racket/unsafe/ops
unsafe-impersonate-procedure
unsafe-chaperone-procedure))
;; ---------------------------------------- ;; ----------------------------------------
(define (chaperone-of?/impersonator a b) (define (chaperone-of?/impersonator a b)
@ -2310,6 +2314,80 @@
;; ---------------------------------------- ;; ----------------------------------------
(let ()
(define (f x) (+ x 1))
(define f2 (unsafe-chaperone-procedure f f))
(test 2 f2 1)
(test #t chaperone-of? f2 f)
(test #f chaperone-of? f f2)
(define f3 (unsafe-chaperone-procedure f sub1))
(define f3i (unsafe-impersonate-procedure f sub1))
(test 0 f3 1)
(test 0 f3i 1)
(test #t chaperone-of? f3 f)
(test #f chaperone-of? f3i f)
(test #f chaperone-of? f3 f2)
(test #f chaperone-of? f2 f3)
(test #f chaperone-of?
(unsafe-chaperone-procedure f f)
(unsafe-chaperone-procedure f f))
(define-values (prop:p prop:p? prop:get-p)
(make-impersonator-property 'p))
(test #t prop:p? (unsafe-chaperone-procedure f f prop:p 5))
(test 5 prop:get-p (unsafe-chaperone-procedure f f prop:p 5))
(define f4 (unsafe-chaperone-procedure f (case-lambda
[(x) (f x)]
[(x y) (f x)])))
(test 2 f4 1)
(test 1
procedure-arity
(unsafe-chaperone-procedure (λ (x) (+ x 1))
(case-lambda
[(x) (+ x 1)]
[(x y) (+ x y)])))
(define f5 (unsafe-chaperone-procedure f (λ (x #:y [y 1]) (f x))))
(test 2 f5 1)
(err/rt-test (unsafe-chaperone-procedure
(λ (#:x x) x)
(λ (#:y y) y))
exn:fail?)
(let ()
(define (f-marks)
(continuation-mark-set->list
(current-continuation-marks)
'mark-key))
(define f-marks-chap
(unsafe-chaperone-procedure
f-marks
f-marks
impersonator-prop:application-mark
(cons 'x 123)))
;; test that impersonator-prop:application-mark
;; is ignored (as the docs say it is).
(test '() f-marks-chap))
(let ()
(struct s (f) #:property prop:procedure 0)
(test #t s? (unsafe-chaperone-procedure (s add1) (λ (x) x)))))
;; Check name in arity error message:
(let ()
(define (pf x) x)
(define cf (unsafe-chaperone-procedure pf (lambda (x) x)))
(err/rt-test (cf) (λ (x) (regexp-match #rx"^pf:" (exn-message x)))))
;; ----------------------------------------
(let () (let ()
(struct s ([a #:mutable])) (struct s ([a #:mutable]))
(err/rt-test (impersonate-struct 5 set-s-a! (lambda (a b) b))) (err/rt-test (impersonate-struct 5 set-s-a! (lambda (a b) b)))
@ -2331,4 +2409,38 @@
;; ---------------------------------------- ;; ----------------------------------------
(let ()
(define-values (->-c has-->c? get-->-c)
(make-impersonator-property '->-c))
(define-values (->-w has-->w? get-->-w)
(make-impersonator-property '->-w))
(define-values (prop:x x? x-ref)
(make-impersonator-property 'x))
(define (wrap-again function)
(chaperone-procedure*
function
#f
->-w void
->-c void))
(define (do-wrap f)
(chaperone-procedure* f
(λ (chap arg)
(test #t has-->w? chap)
(test #t has-->c? chap)
arg
(values (lambda (result) result) arg))))
(define wrapped-f (wrap-again (do-wrap (lambda (x) (+ x 1)))))
(define wrapped2-f (wrap-again (chaperone-procedure (do-wrap (lambda (x) (+ x 1))) #f prop:x 'x)))
(define (test-wrapped x) (x 19))
(set! test-wrapped test-wrapped)
(test-wrapped wrapped-f)
(test-wrapped wrapped2-f))
;; ----------------------------------------
(report-errs) (report-errs)

16
pkgs/racket-test-core/tests/racket/for.rktl
View File

@ -436,10 +436,18 @@
(err/rt-test (for*/fold () ([x '(1 2)]) x) exn:fail:contract:arity?) (err/rt-test (for*/fold () ([x '(1 2)]) x) exn:fail:contract:arity?)
;; for/fold result-arity checking: ;; for/fold result-arity checking:
(err/rt-test (begin (for/fold () ([i (in-range 10)]) 1) 1) #rx".*expected number of values not received.*") (err/rt-test (begin (for/fold () ([i (in-range 10)]) 1) 1)
(err/rt-test (begin (for/fold () () 1) 1) #rx".*expected number of values not received.*") exn:fail:contract:arity?
(err/rt-test (begin (for/fold ([x 1]) () (values 1 2)) 1) #rx".*expected number of values not received.*") #rx".*expected number of values not received.*")
(err/rt-test (begin (for/fold ([x 1] [y 2]) ([i (in-range 10)]) 1) 1) #rx".*expected number of values not received.*") (err/rt-test (begin (for/fold () () 1) 1)
exn:fail:contract:arity?
#rx".*expected number of values not received.*")
(err/rt-test (begin (for/fold ([x 1]) () (values 1 2)) 1)
exn:fail:contract:arity?
#rx".*expected number of values not received.*")
(err/rt-test (begin (for/fold ([x 1] [y 2]) ([i (in-range 10)]) 1) 1)
exn:fail:contract:arity?
#rx".*expected number of values not received.*")
(test 1 'one (begin (for/fold () () (values)) 1)) (test 1 'one (begin (for/fold () () (values)) 1))
;; for/fold syntax checking ;; for/fold syntax checking

43
pkgs/racket-test-core/tests/racket/function.rktl
View File

@ -106,6 +106,49 @@
(arity-test compose1 0 -1) (arity-test compose1 0 -1)
(arity-test compose 0 -1)) (arity-test compose 0 -1))
;; ---------- procedure-result-arity ----------
(test 1 procedure-result-arity car)
(test 1 procedure-result-arity list)
(test (arity-at-least 0) procedure-result-arity values)
(test (arity-at-least 0) procedure-result-arity call/cc)
(let ()
(struct s (x))
(test 1 procedure-result-arity s-x)
(test 1 procedure-result-arity s?)
(test 1 procedure-result-arity s))
(test 1 procedure-result-arity (λ (x) 0))
(test 1 procedure-result-arity (let ([f 1]) (λ (x) (+ f x))))
(test #f procedure-result-arity
(λ ()
(if (= 0 (random 1))
1
(values 1 2))))
(err/rt-test (procedure-result-arity 1) exn:fail?)
(test 1 procedure-result-arity (chaperone-procedure car values))
(test 1 procedure-result-arity (impersonate-procedure car (λ (x) 1)))
(test #f procedure-result-arity (λ (x) (values x x)))
(test 1 procedure-result-arity (parameterize ([eval-jit-enabled #f])
(eval '(λ (x) x))))
(test 1 procedure-result-arity (parameterize ([eval-jit-enabled #f])
(eval '(case-lambda
[(x) x]
[(x y) x]
[(a b c d e f) a]
[(a b . whatever) a]))))
(test #f procedure-result-arity (parameterize ([eval-jit-enabled #f])
(eval '(case-lambda
[(x) x]
[(x y) (values x y)]
[(a b c d e f) (values 1 2 3 4 5 6 7 8)]
[(a b . whatever) a]))))
;; hopefully this test will start failing at
;; some point and return 1 instead of #f
(let ()
(struct s (f) #:property prop:procedure 0)
(test #f procedure-result-arity (s car)))
;; ---------- identity ---------- ;; ---------- identity ----------
(let () (let ()
(test 'foo identity 'foo) (test 'foo identity 'foo)

9
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -5111,6 +5111,15 @@
(set! f f) (set! f f)
(test 12 ((f 10) 1))) (test 12 ((f 10) 1)))
(let ()
(define (f)
(procedure-specialize
(lambda ()
#'x)))
(set! f f)
(test #t syntax? ((f)))
(test 'x syntax-e ((f))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

8
pkgs/racket-test-core/tests/racket/testing.rktl
View File

@ -216,6 +216,14 @@ transcript.
[(_ e exn?) [(_ e exn?)
(syntax (syntax
(thunk-error-test (err:mz:lambda () e) (quote-syntax e) exn?))] (thunk-error-test (err:mz:lambda () e) (quote-syntax e) exn?))]
[(_ e exn? msg-rx)
(regexp? (syntax-e #'msg-rx))
#'(thunk-error-test
(err:mz:lambda () e)
(quote-syntax e)
(lambda (exn)
(and (exn? exn)
(regexp-match? msg-rx (exn-message exn)))))]
[(_ e) [(_ e)
(syntax (syntax
(err/rt-test e exn:application:type?))]))) (err/rt-test e exn:application:type?))])))

17
pkgs/racket-test/tests/match/examples.rkt
View File

@ -810,4 +810,21 @@
[_ 'no]) [_ 'no])
'yes)) 'yes))
(test-case "match-expander rename transformer"
(define-match-expander foo
(lambda (stx) (syntax-case stx () [(_ a) #'a]))
(make-rename-transformer #'values))
(check-equal? (foo 2) 2))
(test-case "match-expander rename transformer set!"
(define x 1)
(define-match-expander foo
(lambda (stx) (syntax-case stx () [(_ a) #'a]))
(make-rename-transformer #'x))
(set! foo 2)
(check-equal? x 2))
)) ))

18
pkgs/racket-test/tests/racket/contract/arrow.rkt
View File

@ -488,4 +488,22 @@
'((contract (dynamic->* #:range-contracts #f) (λ () 1) 'pos 'neg)) '((contract (dynamic->* #:range-contracts #f) (λ () 1) 'pos 'neg))
1) 1)
(test/spec-passed
'dynamic->*9
'(begin
((contract (dynamic->* #:range-contracts (list (or/c 1 2) (or/c 3 4)))
(λ () (values 1 3))
'pos
'neg))
(void)))
(test/pos-blame
'dynamic->*10
'(begin
((contract (dynamic->* #:range-contracts (list (or/c 1 2) (or/c 3 4)))
(λ () (values #f #f))
'pos
'neg))
(void)))
) )

475
pkgs/racket-test/tests/racket/contract/prof.rkt
View File

@ -43,35 +43,35 @@
(contract-eval '(require 'prof-fun)) (contract-eval '(require 'prof-fun))
(test/spec-passed (test/spec-passed
'provide/contract1 'contract-marks1
'((contract (-> neg-blame? any/c) (λ (x) x) 'pos 'neg) 1)) '((contract (-> neg-blame? any/c) (λ (x) x) 'pos 'neg) 1))
(test/spec-passed (test/spec-passed
'provide/contract2 'contract-marks2
'((contract (-> any/c pos-blame?) (λ (x) x) 'pos 'neg) 1)) '((contract (-> any/c pos-blame?) (λ (x) x) 'pos 'neg) 1))
(test/spec-passed (test/spec-passed
'provide/contract3 'contract-marks3
'(contract (vector/c pos-blame?) (vector 1) 'pos 'neg)) '(contract (vector/c pos-blame?) (vector 1) 'pos 'neg))
(test/spec-passed (test/spec-passed
'provide/contract4 'contract-marks4
'((contract (parameter/c pos-blame?) (make-parameter #f) 'pos 'neg))) '((contract (parameter/c pos-blame?) (make-parameter #f) 'pos 'neg)))
(test/spec-passed (test/spec-passed
'provide/contract5 'contract-marks5
'(contract (unconstrained-domain-> pos-blame?) (λ () 1) 'pos 'neg)) '(contract (unconstrained-domain-> pos-blame?) (λ () 1) 'pos 'neg))
(test/spec-passed (test/spec-passed
'provide/contract6 'contract-marks6
'(contract (->* () #:pre neg-blame? any) (λ () 1) 'pos 'neg)) '(contract (->* () #:pre neg-blame? any) (λ () 1) 'pos 'neg))
(test/spec-passed (test/spec-passed
'provide/contract7 'contract-marks7
'(contract (->* () any/c #:post pos-blame?) (λ () 1) 'pos 'neg)) '(contract (->* () any/c #:post pos-blame?) (λ () 1) 'pos 'neg))
(test/spec-passed/result (test/spec-passed/result
'provide/contract8 'contract-marks8
'(let () '(let ()
(eval '(module prof1 racket/base (eval '(module prof1 racket/base
(require racket/contract 'prof-fun) (require racket/contract 'prof-fun)
@ -85,7 +85,7 @@
11) 11)
(test/spec-passed/result (test/spec-passed/result
'provide/contract9 'contract-marks9
'(let () '(let ()
(eval '(module prof2 racket/base (eval '(module prof2 racket/base
(require racket/contract 'prof-fun) (require racket/contract 'prof-fun)
@ -98,7 +98,7 @@
11) 11)
(test/spec-passed/result (test/spec-passed/result
'provide/contract10 'contract-marks10
'(let () '(let ()
(eval '(module prof3 racket/base (eval '(module prof3 racket/base
(require racket/contract 'prof-fun) (require racket/contract 'prof-fun)
@ -111,21 +111,21 @@
11) 11)
(test/spec-passed (test/spec-passed
'provide/contract11 'contract-marks11
'(let () '(let ()
(struct posn (x y)) (struct posn (x y))
((contract (-> (struct/dc posn [x neg-blame?]) any/c) (λ (x) x) 'pos 'neg) ((contract (-> (struct/dc posn [x neg-blame?]) any/c) (λ (x) x) 'pos 'neg)
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract12 'contract-marks12
'(let () '(let ()
(struct posn (x y)) (struct posn (x y))
((contract (-> any/c (struct/dc posn [x pos-blame?])) (λ (x) x) 'pos 'neg) ((contract (-> any/c (struct/dc posn [x pos-blame?])) (λ (x) x) 'pos 'neg)
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract13 'contract-marks13
'(let () '(let ()
(struct posn (x y)) (struct posn (x y))
((contract (-> any/c (struct/dc posn [x pos-blame?] #:inv (x) pos-blame?)) ((contract (-> any/c (struct/dc posn [x pos-blame?] #:inv (x) pos-blame?))
@ -133,7 +133,7 @@
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract14 'contract-marks14
'(let () '(let ()
(struct posn (x y) #:mutable) (struct posn (x y) #:mutable)
((contract (-> any/c (struct/dc posn [x pos-blame?])) ((contract (-> any/c (struct/dc posn [x pos-blame?]))
@ -141,7 +141,7 @@
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract15 'contract-marks15
'(let () '(let ()
(struct posn (x y)) (struct posn (x y))
((contract (-> any/c (struct/dc posn [x #:lazy pos-blame?])) ((contract (-> any/c (struct/dc posn [x #:lazy pos-blame?]))
@ -149,7 +149,7 @@
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract16 'contract-marks16
'(let () '(let ()
(struct posn (x y)) (struct posn (x y))
((contract (-> any/c (struct/dc posn ((contract (-> any/c (struct/dc posn
@ -159,7 +159,7 @@
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract17 'contract-marks17
'(let () '(let ()
(struct posn (x y)) (struct posn (x y))
((contract (-> any/c (struct/dc posn ((contract (-> any/c (struct/dc posn
@ -169,7 +169,7 @@
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract18 'contract-marks18
'(let () '(let ()
(struct posn (x y) #:mutable) (struct posn (x y) #:mutable)
((contract (-> any/c (struct/dc posn ((contract (-> any/c (struct/dc posn
@ -179,7 +179,7 @@
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract19 'contract-marks19
'(let () '(let ()
(struct posn (x y)) (struct posn (x y))
((contract (-> any/c (struct/dc posn ((contract (-> any/c (struct/dc posn
@ -189,7 +189,7 @@
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract20 'contract-marks20
'(let () '(let ()
(struct posn (x y) #:mutable) (struct posn (x y) #:mutable)
((contract (-> any/c (struct/dc posn ((contract (-> any/c (struct/dc posn
@ -199,15 +199,444 @@
(posn 1 2)))) (posn 1 2))))
(test/spec-passed (test/spec-passed
'provide/contract21 'contract-marks21
'(let () '(let ()
((contract (case-> (-> any/c any/c pos-blame?)) ((contract (case-> (-> any/c any/c pos-blame?))
(λ (x y) x) 'pos 'neg) (λ (x y) x) 'pos 'neg)
1 2))) 1 2)))
(test/spec-passed (test/spec-passed
'provide/contract22 'contract-marks22
'(let () '(let ()
((contract (case-> (-> neg-blame? any/c)) ((contract (case-> (-> neg-blame? any/c))
(λ (x) x) 'pos 'neg) (λ (x) x) 'pos 'neg)
1)))) 1)))
(test/spec-passed
'contract-marks23
'(unbox (contract (box/c neg-blame?) (box 1) 'pos 'neg)))
(test/spec-passed
'contract-marks24
'(set-box! (contract (box/c neg-blame?) (box 1) 'pos 'neg) 2))
;; do we catch flat contracts applies with `contract-out`?
(test/spec-passed/result
'contract-marks25
'(let ()
(eval '(module prof25 racket/base
(require racket/contract 'prof-fun)
(define x 3)
(define a-contract (λ _ (named-blame? 'prof25)))
(provide
(contract-out
[x a-contract]))))
(eval '(require 'prof25))
(eval 'x))
3)
(test/spec-passed/result
'contract-marks26
'(let ()
(eval '(define/contract x (λ _ (named-blame? 'top-level)) 3))
(eval 'x))
3)
(test/spec-passed/result
'contract-marks27
'(with-contract test27 #:result (λ _ (named-blame? '(region test27))) 3)
3)
(test/spec-passed/result
'contract-marks28
'(let ()
(eval '(define-struct/contract foo ([bar (λ _ (named-blame? 'top-level))])))
(eval '(foo-bar (foo 3))))
3)
(test/spec-passed/result
'contract-marks29
'(let ()
(eval '(define f (invariant-assertion (-> (λ _ (named-blame? 'top-level))
(λ _ (named-blame? 'top-level)))
(λ (x) 3))))
(eval '(f 2)))
3)
(test/spec-passed/result
'contract-marks30
'(let ()
(eval '(module test30 racket/base
(require racket/contract/base 'prof-fun)
(define (f x) 3)
(define-module-boundary-contract g f (-> (λ _ (named-blame? 'top-level))
(λ _ (named-blame? 'top-level))))
(provide g)))
(eval '(require 'test30))
(eval '(f 2)))
3)
(test/spec-passed/result
'contract-marks31
'((hash-ref (contract (hash/c (-> neg-blame? pos-blame?)
(-> neg-blame? pos-blame?))
(hash values values)
'pos 'neg)
values)
3)
3)
(test/spec-passed/result
'contract-marks32
'(car (contract (listof pos-blame?) (list 3) 'pos 'neg))
3)
(test/spec-passed/result
'contract-marks33
'((car (contract (listof (-> neg-blame? pos-blame?)) (list (lambda (x) 3)) 'pos 'neg)) 2)
3)
(test/spec-passed/result
'contract-marks34
'(begin
(require racket/promise)
(force (contract (promise/c pos-blame?) (delay 3) 'pos 'neg)))
3)
(test/spec-passed/result
'contract-marks35
'(let ()
(define/contract tag
(prompt-tag/c (-> (λ _ (named-blame? 'top-level))
(λ _ (named-blame? 'top-level))))
(make-continuation-prompt-tag))
(call-with-continuation-prompt
(lambda ()
(number->string
(call-with-composable-continuation
(lambda (k)
(abort-current-continuation tag k)))))
tag
(lambda (k) 3)))
3)
(test/spec-passed/result
'contract-marks36
'(let ()
(define/contract mark-key
(continuation-mark-key/c (-> (λ _ (named-blame? 'top-level))
(λ _ (named-blame? 'top-level))))
(make-continuation-mark-key))
(with-continuation-mark
mark-key
(lambda (s) (append s '(truffle fudge ganache)))
(let ([mark-value (continuation-mark-set-first
(current-continuation-marks) mark-key)])
(mark-value '(chocolate-bar)))))
'(chocolate-bar truffle fudge ganache))
(test/spec-passed
'contract-marks37
'(let ()
(define/contract my-evt
(evt/c (λ _ (named-blame? 'top-level)))
always-evt)
(sync my-evt)))
(test/spec-passed
'contract-marks38
'(let ()
(define/contract chan
(channel/c (λ _ (named-blame? 'top-level)))
(make-channel))
(thread (λ () (channel-get chan)))
(channel-put chan 'not-a-string)))
(test/spec-passed
'contract-marks39
'(let ()
(eval '(require racket/class))
(eval '((contract (->m neg-blame? any/c) (λ (_ x) x) 'pos 'neg) 'a 1))))
(test/spec-passed
'contract-marks40
'(let ()
(define o
(contract
(object-contract (field x pos-blame?) (f (->m neg-blame?)))
(new (class object% (init-field x) (define/public (f) x) (super-new)) [x 3])
'pos 'neg))
(get-field x o)
(set-field! x o 2)
(send o f)))
(test/spec-passed
'contract-marks41
'(contract (vectorof pos-blame? #:flat? #t) #(1 2 3) 'pos 'neg))
(test/spec-passed
'contract-marks42
'((vector-ref (contract (vectorof (-> pos-blame? neg-blame?)) (vector values)
'pos 'neg)
0)
1))
(test/spec-passed
'contract-marks43
'(contract (vector/c pos-blame? #:flat? #t) #(1) 'pos 'neg))
(test/spec-passed
'contract-marks42
'((vector-ref (contract (vector/c (-> pos-blame? neg-blame?)) (vector values)
'pos 'neg)
0)
1))
(test/spec-passed
'contract-marks43
'((contract (parametric->/c (X) (-> pos-blame? X neg-blame?))
(lambda (x y) x)
'pos 'neg)
1 2))
(test/spec-passed
'contract-marks44
'(let ()
(struct s ([x #:mutable]))
(define s* (contract (struct/dc s [x pos-blame?] #:inv (x) pos-blame?) (s 3) 'pos 'neg))
(set-s-x! s* 3)
(s-x s*)))
(test/spec-passed
'contract-marks45
'(let ()
(eval '(module propmod racket/base
(require racket/contract 'prof-fun)
(define-values (prop prop? prop-ref)
(make-struct-type-property 'prop))
(define (app-prop x v)
(((prop-ref x) x) v))
(provide/contract
[prop (struct-type-property/c
(-> (lambda _ (named-blame? 'propmod))
(-> (lambda _ (named-blame? 'propmod))
(lambda _ (named-blame? 'propmod)))))])
(provide prop-ref app-prop)))
(eval '(require 'propmod))
(eval '(struct s (f) #:property prop (lambda (s) (s-f s))))
(eval '(define s1 (s even?)))
(eval '(app-prop s1 5))))
(test/spec-passed
'contract-marks46
'((contract (->i ([x () pos-blame?] [y (x) pos-blame?])
#:rest [z (x y) pos-blame?]
#:pre (x y z) pos-blame?
[res (x y z) neg-blame?]
#:post (res x y z) neg-blame?)
(lambda (x y . z) 3)
'pos 'neg)
1 2 3))
(test/spec-passed
'contract-marks47
'((contract (->i ([x () pos-blame?] [y (x) pos-blame?])
([w (x y) pos-blame?])
#:rest [z (x y) pos-blame?]
#:pre (x y z) pos-blame?
[res (x y z) neg-blame?]
#:post (res x y z) neg-blame?)
(lambda (x y [w 3] . z) 3)
'pos 'neg)
1 2 3 4))
(test/spec-passed
'contract-marks48
'((contract (->i ([x () pos-blame?] [y (x) pos-blame?])
[res (x y) neg-blame?])
(lambda (x y) 3)
'pos 'neg)
1 2))
(test/spec-passed
'contract-marks49
'((contract (->i ([x () pos-blame?])
[res (x) neg-blame?])
(lambda (x) 3)
'pos 'neg)
1))
(test/spec-passed
'contract-marks50
'((contract (opt/c (-> neg-blame? any/c)) (λ (x) x) 'pos 'neg) 1))
(test/spec-passed
'contract-marks51
'((contract (opt/c (-> any/c pos-blame?)) (λ (x) x) 'pos 'neg) 1))
(test/spec-passed
'contract-marks52
'((contract (->d ([x pos-blame?] [y pos-blame?])
#:rest z pos-blame?
#:pre pos-blame?
[res neg-blame?]
#:post neg-blame?)
(lambda (x y . z) 3)
'pos 'neg)
1 2 3))
(test/spec-passed
'contract-marks53
'((contract (->d ([x pos-blame?] [y pos-blame?])
([w pos-blame?])
#:rest z pos-blame?
#:pre pos-blame?
[res neg-blame?]
#:post neg-blame?)
(lambda (x y [w 3] . z) 3)
'pos 'neg)
1 2 3 4))
(test/spec-passed
'contract-marks54
'((contract (->d ([x pos-blame?] [y pos-blame?])
[res neg-blame?])
(lambda (x y) 3)
'pos 'neg)
1 2))
(test/spec-passed
'contract-marks55
'((contract (->d ([x pos-blame?])
[res neg-blame?])
(lambda (x) 3)
'pos 'neg)
1))
(test/spec-passed
'contract-marks56
'(let ()
(eval '(require racket/async-channel))
(eval '(define c (contract (async-channel/c pos-blame?) (make-async-channel) 'pos 'neg)))
(eval '(async-channel-put c 3))
(eval '(async-channel-get c))))
(test/spec-passed
'contract-marks57
'(let ()
(eval '(require racket/generic))
(eval '(define-generics fooable (foo fooable)))
(eval '(struct s () #:methods gen:fooable [(define (foo x) x)]))
(eval '(foo (contract (generic-instance/c gen:fooable [foo (-> pos-blame? neg-blame?)])
(s) 'pos 'neg)))))
(test/spec-passed
'contract-marks58
'(let ()
(eval '(require racket/set))
(eval '(define s (contract (set/c pos-blame?) (set 1 2 3) 'pos 'neg)))
(eval '(set-add s 3))
(eval '(set-member? s 3))))
(test/spec-passed
'contract-marks59
'(let ()
(eval '(require racket/set))
(eval '(define s (contract (set/c pos-blame? #:lazy? #t #:kind 'mutable)
(mutable-set 1 2 3) 'pos 'neg)))
(eval '(set-add! s 3))
(eval '(set-member? s 3))))
(test/spec-passed
'contract-marks60
'(let ()
(eval '(require racket/set))
(eval '(define s (contract (set/c pos-blame? #:kind 'dont-care)
(list 1 2 3) 'pos 'neg)))
(eval '(set-add s 3))
(eval '(set-member? s 3))))
(test/spec-passed
'contract-marks61
'(let ()
(eval '(require racket/stream))
(eval '(stream-first (contract (stream/c pos-blame?) (in-range 3) 'pos 'neg)))))
(test/spec-passed/result
'contract-marks62
'(let ()
(define marked? #f) ; check that we measure the cost of contract-stronger?
(define (make/c) ; the two have to not be eq?, otherwise contract-stronger? is not called
(make-contract #:late-neg-projection
(lambda (b)
(lambda (val neg-party)
(pos-blame? 'dummy)))
#:stronger
(lambda (c1 c2)
(when (pos-blame? 'dummy)
(set! marked? #t)
#t))))
((contract (-> pos-blame? (make/c))
(contract (-> pos-blame? (make/c)) values 'pos 'neg)
'pos 'neg)
3)
marked?)
#t)
(test/spec-passed
'contract-marks63
'(let ()
(eval '(require racket/sequence))
(eval '(sequence->list (contract (sequence/c pos-blame?) (in-range 3) 'pos 'neg)))))
(test/spec-passed
'contract-marks64
'(let ()
(eval '(require racket/sequence racket/dict))
(eval '(sequence-ref (contract (sequence/c pos-blame? pos-blame?)
(in-dict '((1 . 2) (3 . 4))) 'pos 'neg)
0))))
(test/spec-passed
'contract-marks65
'(let ()
(eval '(require syntax/id-table))
(eval '(define t (contract (free-id-table/c pos-blame? neg-blame?)
(make-free-id-table)
'pos 'neg)))
(eval '(free-id-table-set! t #'a 3))
(eval '(free-id-table-ref t #'a))))
(test/spec-passed
'contract-marks66
'(let ()
(eval '(require syntax/id-table))
(eval '(define t (contract (free-id-table/c pos-blame? neg-blame?)
(make-immutable-free-id-table)
'pos 'neg)))
(eval '(free-id-table-ref (free-id-table-set t #'a 3) #'a))))
;; check that there's no mark when running the body of a contracted function
;; (i.e., user code)
(test/spec-passed/result
'contract-marks67
'(let ()
(eval '(module m racket/base
(require racket/contract/base
(only-in racket/contract/private/guts
contract-continuation-mark-key))
(provide
(contract-out
[f (-> integer? void?)]))
(define (f x)
(define m
(continuation-mark-set->list
(current-continuation-marks)
contract-continuation-mark-key))
(unless (null? m)
(error 'ack "~s" m)))))
(eval '(require 'm))
(eval '(let ([f f]) (f 1))))
(void))
)

11
pkgs/racket-test/tests/racket/contract/tail.rkt
View File

@ -22,6 +22,17 @@
(f 3)) (f 3))
(c))) (c)))
(ctest/rewrite 1
tail-arrow.2
(let ([c (counter)])
(letrec ([f
(contract (-> any/c c)
(λ ([x #f]) (if (zero? x) x (f (- x 1))))
'pos
'neg)])
(f 3))
(c)))
(ctest/rewrite 1 (ctest/rewrite 1
tail-unconstrained-domain-arrow tail-unconstrained-domain-arrow
(let ([c (counter)]) (let ([c (counter)])

5
racket/collects/racket/HISTORY.txt
View File

@ -1,3 +1,8 @@
Version 6.4, January 2016
Changes noted in the documentation, including support for
incremental garbage collection
Performance improvements and bug repairs
Version 6.3, October 2015 Version 6.3, October 2015
Bug repairs and other changes noted in the documentation, Bug repairs and other changes noted in the documentation,
including substantial changes to the macro expander including substantial changes to the macro expander

11
racket/collects/racket/async-channel.rkt
View File

@ -215,10 +215,17 @@
(define pos-elem-proj (lnp blame)) (define pos-elem-proj (lnp blame))
(define neg-elem-proj (lnp (blame-swap blame))) (define neg-elem-proj (lnp (blame-swap blame)))
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(check-async-channel/c ctc val blame neg-party) (check-async-channel/c ctc val blame neg-party)
(impersonate/chaperone-async-channel val (impersonate/chaperone-async-channel val
(λ (v) (pos-elem-proj v neg-party)) (λ (v)
(λ (v) (neg-elem-proj v neg-party)) (with-contract-continuation-mark
blame+neg-party
(pos-elem-proj v neg-party)))
(λ (v)
(with-contract-continuation-mark
blame+neg-party
(neg-elem-proj v neg-party)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)))) impersonator-prop:blame blame))))

9
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -811,7 +811,7 @@ evaluted left-to-right.)
#`(case-lambda #`(case-lambda
[#,(vector->list wrapper-ress) [#,(vector->list wrapper-ress)
(with-contract-continuation-mark (with-contract-continuation-mark
blame blame+neg-party
#,(add-wrapper-let #,(add-wrapper-let
(add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress (add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress
#`(values #,@(vector->list wrapper-ress))) #`(values #,@(vector->list wrapper-ress)))
@ -906,6 +906,7 @@ evaluted left-to-right.)
(with-syntax ([arg-checker (or (syntax-local-infer-name stx) 'arg-checker)]) (with-syntax ([arg-checker (or (syntax-local-infer-name stx) 'arg-checker)])
#`(λ #,wrapper-proc-arglist #`(λ #,wrapper-proc-arglist
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(c-or-i-procedure (c-or-i-procedure
val val
@ -915,10 +916,12 @@ evaluted left-to-right.)
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-args . args) (λ (kwds kwd-args . args)
(with-contract-continuation-mark (with-contract-continuation-mark
blame (keyword-apply arg-checker kwds kwd-args args))) blame+neg-party
(keyword-apply arg-checker kwds kwd-args args)))
(λ args (λ args
(with-contract-continuation-mark (with-contract-continuation-mark
blame (apply arg-checker args))))) blame+neg-party
(apply arg-checker args)))))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)))))) impersonator-prop:blame blame))))))

155
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -8,7 +8,10 @@
"misc.rkt" "misc.rkt"
"prop.rkt" "prop.rkt"
"guts.rkt" "guts.rkt"
(prefix-in arrow: "arrow.rkt")) (prefix-in arrow: "arrow.rkt")
(only-in racket/unsafe/ops
unsafe-chaperone-procedure
unsafe-impersonate-procedure))
(provide (for-syntax build-chaperone-constructor/real) (provide (for-syntax build-chaperone-constructor/real)
procedure-arity-exactly/no-kwds procedure-arity-exactly/no-kwds
@ -154,17 +157,11 @@
[(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))] [(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))]
[(rng-late-neg-projs ...) (if rngs rngs '())] [(rng-late-neg-projs ...) (if rngs rngs '())]
[(rng-x ...) (if rngs (generate-temporaries rngs) '())]) [(rng-x ...) (if rngs (generate-temporaries rngs) '())])
(with-syntax ([(rng-checker-name ...)
(if rngs (define rng-checker
(list (gen-id 'rng-checker)) (and rngs
null)] (with-syntax ([rng-len (length rngs)]
[(rng-checker ...) [rng-results #'(values (rng-late-neg-projs rng-x neg-party) ...)])
(if rngs
(list
(with-syntax ([rng-len (length rngs)])
(with-syntax ([rng-results
#'(values (rng-late-neg-projs rng-x neg-party)
...)])
#'(case-lambda #'(case-lambda
[(rng-x ...) [(rng-x ...)
(with-contract-continuation-mark (with-contract-continuation-mark
@ -175,15 +172,27 @@
[args [args
(arrow:bad-number-of-results blame val rng-len args (arrow:bad-number-of-results blame val rng-len args
#:missing-party neg-party)])))) #:missing-party neg-party)]))))
null)]) (define (wrap-call-with-values-and-range-checking stx assume-result-values?)
(if rngs
(if assume-result-values?
#`(let-values ([(rng-x ...) #,stx])
(with-contract-continuation-mark
(cons blame neg-party)
(let ()
post ...
(values (rng-late-neg-projs rng-x neg-party) ...))))
#`(call-with-values
(λ () #,stx)
#,rng-checker))
stx))
(let* ([min-method-arity (length doms)] (let* ([min-method-arity (length doms)]
[max-method-arity (+ min-method-arity (length opt-doms))] [max-method-arity (+ min-method-arity (length opt-doms))]
[min-arity (+ (length this-args) min-method-arity)] [min-arity (+ (length this-args) min-method-arity)]
[max-arity (+ min-arity (length opt-doms))] [max-arity (+ min-arity (length opt-doms))]
[req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)] [req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)]
[opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)] [opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
[need-apply-values? (or dom-rest (not (null? opt-doms)))] [need-apply? (or dom-rest (not (null? opt-doms)))])
[no-rng-checking? (not rngs)])
(with-syntax ([(dom-projd-args ...) #'((dom-ctc dom-x neg-party) ...)] (with-syntax ([(dom-projd-args ...) #'((dom-ctc dom-x neg-party) ...)]
[basic-params [basic-params
(cond (cond
@ -227,6 +236,7 @@
(for/fold ([s #'null]) (for/fold ([s #'null])
([tx (in-list (map cdr put-in-reverse))]) ([tx (in-list (map cdr put-in-reverse))])
(tx s)))]) (tx s)))])
(with-syntax ([kwd-lam-params (with-syntax ([kwd-lam-params
(if dom-rest (if dom-rest
#'(this-param ... #'(this-param ...
@ -239,7 +249,7 @@
kwd-param ...))] kwd-param ...))]
[basic-return [basic-return
(let ([inner-stx-gen (let ([inner-stx-gen
(if need-apply-values? (if need-apply?
(λ (s) #`(apply values #,@s (λ (s) #`(apply values #,@s
this-param ... this-param ...
dom-projd-args ... dom-projd-args ...
@ -248,16 +258,56 @@
#,@s #,@s
this-param ... this-param ...
dom-projd-args ...)))]) dom-projd-args ...)))])
(if no-rng-checking? (if rngs
(inner-stx-gen #'())
(arrow:check-tail-contract rng-ctcs (arrow:check-tail-contract rng-ctcs
blame-party-info blame-party-info
neg-party neg-party
#'(rng-checker-name ...) (list rng-checker)
inner-stx-gen)))] inner-stx-gen
#'(cons blame neg-party))
(inner-stx-gen #'())))]
[(basic-unsafe-return basic-unsafe-return/result-values-assumed)
(let ()
(define (inner-stx-gen stuff assume-result-values?)
(define arg-checking-expressions
(if need-apply?
#'(this-param ... dom-projd-args ... opt+rest-uses)
#'(this-param ... dom-projd-args ...)))
(define the-call/no-tail-mark
(with-syntax ([(tmps ...) (generate-temporaries
arg-checking-expressions)])
#`(let-values ([(tmps ...)
(with-contract-continuation-mark
(cons blame neg-party)
(values #,@arg-checking-expressions))])
#,(if need-apply?
#`(apply val tmps ...)
#`(val tmps ...)))))
(define the-call
#`(with-continuation-mark arrow:tail-contract-key
(list* neg-party blame-party-info #,rng-ctcs)
#,the-call/no-tail-mark))
(cond
[(null? (syntax-e stuff)) ;; surely there must a better way
the-call/no-tail-mark]
[else
(wrap-call-with-values-and-range-checking
the-call
assume-result-values?)]))
(define (mk-return assume-result-values?)
(if rngs
(arrow:check-tail-contract
rng-ctcs
blame-party-info
neg-party
#'not-a-null
(λ (x) (inner-stx-gen x assume-result-values?))
#'(cons blame neg-party))
(inner-stx-gen #'() assume-result-values?)))
(list (mk-return #f) (mk-return #t)))]
[kwd-return [kwd-return
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply-values? (if need-apply?
(λ (s k) #`(apply values (λ (s k) #`(apply values
#,@s #,@k #,@s #,@k
this-param ... this-param ...
@ -275,15 +325,15 @@
(λ (s) (λ (s)
(inner-stx-gen s #'(kwd-results))))]) (inner-stx-gen s #'(kwd-results))))])
#`(let ([kwd-results kwd-stx]) #`(let ([kwd-results kwd-stx])
#,(if no-rng-checking? #,(if rngs
(outer-stx-gen #'())
(arrow:check-tail-contract rng-ctcs (arrow:check-tail-contract rng-ctcs
blame-party-info blame-party-info
neg-party neg-party
#'(rng-checker-name ...) (list rng-checker)
outer-stx-gen))))]) outer-stx-gen
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] #'(cons blame neg-party))
[basic-lambda #'(λ basic-params (outer-stx-gen #'()))))])
;; Arrow contract domain checking is instrumented ;; Arrow contract domain checking is instrumented
;; both here, and in `arity-checking-wrapper'. ;; both here, and in `arity-checking-wrapper'.
;; We need to instrument here, because sometimes ;; We need to instrument here, because sometimes
@ -293,65 +343,69 @@
;; Overhead of double-wrapping has not been ;; Overhead of double-wrapping has not been
;; noticeable in my measurements so far. ;; noticeable in my measurements so far.
;; - stamourv ;; - stamourv
(with-syntax ([basic-lambda #'(λ basic-params
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(let () (let ()
pre ... basic-return)))] pre ... basic-return)))]
[basic-unsafe-lambda
#'(λ basic-params
(let ()
pre ... basic-unsafe-return))]
[basic-unsafe-lambda/result-values-assumed
#'(λ basic-params
(let ()
pre ... basic-unsafe-return/result-values-assumed))]
[kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params [kwd-lambda #`(λ kwd-lam-params
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(let () (let ()
pre ... kwd-return)))]) pre ... kwd-return)))])
(with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])
(cond (cond
[(and (null? req-keywords) (null? opt-keywords)) [(and (null? req-keywords) (null? opt-keywords))
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(arrow:arity-checking-wrapper val
(let ([basic-lambda-name basic-lambda])
(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
basic-lambda-name basic-lambda
basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed
#,(and rngs (length rngs))
void void
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-kwd ...))))] '(opt-kwd ...))]
[(pair? req-keywords) [(pair? req-keywords)
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(arrow:arity-checking-wrapper val
(let ([kwd-lambda-name kwd-lambda])
(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
void void #t #f #f
kwd-lambda-name kwd-lambda
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-kwd ...))))] '(opt-kwd ...))]
[else [else
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(arrow:arity-checking-wrapper val
(let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda])
(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
basic-lambda-name basic-lambda #t #f #f
kwd-lambda-name kwd-lambda
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-kwd ...))))]))))))))))) '(opt-kwd ...))])))))))))
(define (maybe-cons-kwd c x r neg-party) (define (maybe-cons-kwd c x r neg-party)
(if (eq? arrow:unspecified-dom x) (if (eq? arrow:unspecified-dom x)
r r
(cons (c x neg-party) r))) (cons (c x neg-party) r)))
(define (->-proj chaperone-or-impersonate-procedure ctc (define (->-proj chaperone? ctc
;; fields of the 'ctc' struct ;; fields of the 'ctc' struct
min-arity doms kwd-infos rest pre? rngs post? min-arity doms kwd-infos rest pre? rngs post?
plus-one-arity-function chaperone-constructor plus-one-arity-function chaperone-constructor
@ -414,10 +468,15 @@
(if partial-rest (list partial-rest) '()))) (if partial-rest (list partial-rest) '())))
(define blame-party-info (arrow:get-blame-party-info orig-blame)) (define blame-party-info (arrow:get-blame-party-info orig-blame))
(define (successfully-got-the-right-kind-of-function val neg-party) (define (successfully-got-the-right-kind-of-function val neg-party)
(define chap/imp-func (apply chaperone-constructor (define-values (chap/imp-func use-unsafe-chaperone-procedure?)
(apply chaperone-constructor
orig-blame val orig-blame val
neg-party blame-party-info neg-party blame-party-info
rngs the-args)) rngs the-args))
(define chaperone-or-impersonate-procedure
(if use-unsafe-chaperone-procedure?
(if chaperone? unsafe-chaperone-procedure unsafe-impersonate-procedure)
(if chaperone? chaperone-procedure impersonate-procedure)))
(cond (cond
[chap/imp-func [chap/imp-func
(if (or post? (not rngs)) (if (or post? (not rngs))

35
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -962,11 +962,12 @@
(cons result-checker args-dealt-with) (cons result-checker args-dealt-with)
args-dealt-with))))) args-dealt-with)))))
(arrow:arity-checking-wrapper f blame neg-party (values (arrow:arity-checking-wrapper f blame neg-party
interposition-proc interposition-proc interposition-proc #f interposition-proc #f #f
min-arity max-arity min-arity max-arity
min-arity max-arity min-arity max-arity
mandatory-keywords optional-keywords)))) mandatory-keywords optional-keywords)
#f))))
(build--> 'dynamic->* (build--> 'dynamic->*
mandatory-domain-contracts optional-domain-contracts mandatory-domain-contracts optional-domain-contracts
@ -1159,11 +1160,13 @@
(arrow:keywords-match man-kwds opt-kwds x) (arrow:keywords-match man-kwds opt-kwds x)
#t)) #t))
(define (make-property build-X-property chaperone-or-impersonate-procedure) (define (make-property chaperone?)
(define build-X-property
(if chaperone? build-chaperone-contract-property build-contract-property))
(define val-first-proj (define val-first-proj
(λ (->stct) (λ (->stct)
(maybe-warn-about-val-first ->stct) (maybe-warn-about-val-first ->stct)
(->-proj chaperone-or-impersonate-procedure ->stct (->-proj chaperone? ->stct
(base->-min-arity ->stct) (base->-min-arity ->stct)
(base->-doms ->stct) (base->-doms ->stct)
(base->-kwd-infos ->stct) (base->-kwd-infos ->stct)
@ -1176,7 +1179,7 @@
#f))) #f)))
(define late-neg-proj (define late-neg-proj
(λ (->stct) (λ (->stct)
(->-proj chaperone-or-impersonate-procedure ->stct (->-proj chaperone? ->stct
(base->-min-arity ->stct) (base->-min-arity ->stct)
(base->-doms ->stct) (base->-doms ->stct)
(base->-kwd-infos ->stct) (base->-kwd-infos ->stct)
@ -1227,19 +1230,13 @@
(not (base->-post? that)))) (not (base->-post? that))))
(define-struct (-> base->) () (define-struct (-> base->) ()
#:property #:property prop:chaperone-contract (make-property #t))
prop:chaperone-contract
(make-property build-chaperone-contract-property chaperone-procedure))
(define-struct (predicate/c base->) () (define-struct (predicate/c base->) ()
#:property #:property prop:chaperone-contract (make-property #t))
prop:chaperone-contract
(make-property build-chaperone-contract-property chaperone-procedure))
(define-struct (impersonator-> base->) () (define-struct (impersonator-> base->) ()
#:property #:property prop:contract (make-property #f))
prop:contract
(make-property build-contract-property impersonate-procedure))
(define ->void-contract (define ->void-contract
(let-syntax ([get-chaperone-constructor (let-syntax ([get-chaperone-constructor
@ -1303,7 +1300,7 @@
'(expected: "a procedure that accepts 1 non-keyword argument" '(expected: "a procedure that accepts 1 non-keyword argument"
given: "~e") given: "~e")
f)) f))
(cond (values (cond
[(and (struct-predicate-procedure? f) [(and (struct-predicate-procedure? f)
(not (impersonator? f))) (not (impersonator? f)))
#f] #f]
@ -1319,9 +1316,11 @@
(unless (null? kwds) (unless (null? kwds)
(arrow:raise-no-keywords-arg blame #:missing-party neg-party f kwds)) (arrow:raise-no-keywords-arg blame #:missing-party neg-party f kwds))
(unless (= 1 (length other)) (unless (= 1 (length other))
(arrow:raise-wrong-number-of-args-error #:missing-party neg-party (arrow:raise-wrong-number-of-args-error
#:missing-party neg-party
blame f (length other) 1 1 1)) blame f (length other) 1 1 1))
(values (rng-checker f blame neg-party) (car other))))])))) (values (rng-checker f blame neg-party) (car other))))])
#f))))
(define -predicate/c (mk-any/c->boolean-contract predicate/c)) (define -predicate/c (mk-any/c->boolean-contract predicate/c))
(define any/c->boolean-contract (mk-any/c->boolean-contract make-->)) (define any/c->boolean-contract (mk-any/c->boolean-contract make-->))

65
racket/collects/racket/contract/private/arrow.rkt
View File

@ -52,7 +52,7 @@
(define tail-contract-key (gensym 'tail-contract-key)) (define tail-contract-key (gensym 'tail-contract-key))
(define-for-syntax (check-tail-contract rng-ctcs blame-party-info neg-party rng-checkers call-gen) (define-for-syntax (check-tail-contract rng-ctcs blame-party-info neg-party rng-checkers call-gen blame+neg-party)
(unless (identifier? rng-ctcs) (unless (identifier? rng-ctcs)
(raise-argument-error 'check-tail-contract (raise-argument-error 'check-tail-contract
"identifier?" "identifier?"
@ -61,7 +61,7 @@
#`(call-with-immediate-continuation-mark #`(call-with-immediate-continuation-mark
tail-contract-key tail-contract-key
(λ (m) (λ (m)
(if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party) (if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party #,blame+neg-party)
#,(call-gen #'()) #,(call-gen #'())
#,(call-gen rng-checkers))))) #,(call-gen rng-checkers)))))
@ -69,7 +69,10 @@
;; rng-ctc : (or/c #f (listof ctc)) ;; rng-ctc : (or/c #f (listof ctc))
;; blame-party-info : (list/c pos-party boolean?[blame-swapped?]) ;; blame-party-info : (list/c pos-party boolean?[blame-swapped?])
;; neg-party : neg-party ;; neg-party : neg-party
(define (tail-marks-match? m rng-ctcs blame-party-info neg-party) ;; blame+neg-party : (cons/c blame? neg-party)
(define (tail-marks-match? m rng-ctcs blame-party-info neg-party blame+neg-party)
(with-contract-continuation-mark
blame+neg-party
(and m (and m
rng-ctcs rng-ctcs
(eq? (car m) neg-party) (eq? (car m) neg-party)
@ -87,7 +90,7 @@
(cond (cond
[(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] [(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
[(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] [(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
[else #f])])))) [else #f])])))))
;; used as part of the information in the continuation mark ;; used as part of the information in the continuation mark
;; that records what is to be checked for a pending contract ;; that records what is to be checked for a pending contract
@ -115,27 +118,30 @@
(λ (val neg-party) (λ (val neg-party)
(check-is-a-procedure orig-blame neg-party val) (check-is-a-procedure orig-blame neg-party val)
(define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...)) (define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...))
(define blame+neg-party (cons orig-blame neg-party))
(wrapper (wrapper
val val
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-vals . args) (λ (kwds kwd-vals . args)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons orig-blame neg-party) blame+neg-party
#,(check-tail-contract #,(check-tail-contract
#'rngs-list #'rngs-list
#'blame-party-info #'blame-party-info
#'neg-party #'neg-party
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args))))) (λ (s) #`(apply values #,@s kwd-vals args))
#'blame+neg-party)))
(λ args (λ args
(with-contract-continuation-mark (with-contract-continuation-mark
(cons orig-blame neg-party) blame+neg-party
#,(check-tail-contract #,(check-tail-contract
#'rngs-list #'rngs-list
#'blame-party-info #'blame-party-info
#'neg-party #'neg-party
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s args)))))) (λ (s) #`(apply values #,@s args))
#'blame+neg-party))))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:application-mark impersonator-prop:application-mark
(cons tail-contract-key (list neg-party blame-party-info rngs-x ...)))))))) (cons tail-contract-key (list neg-party blame-party-info rngs-x ...))))))))
@ -346,7 +352,8 @@
blame-party-info blame-party-info
#'neg-party #'neg-party
#'(rng-checker-name ...) #'(rng-checker-name ...)
inner-stx-gen)))] inner-stx-gen
#'(cons blame neg-party))))]
[kwd-return [kwd-return
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply-values? (if need-apply-values?
@ -370,7 +377,8 @@
blame-party-info blame-party-info
#'neg-party #'neg-party
#'(rng-checker-name ...) #'(rng-checker-name ...)
outer-stx-gen))))]) outer-stx-gen
#'(cons blame neg-party)))))])
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
[basic-lambda #'(λ basic-params [basic-lambda #'(λ basic-params
;; Arrow contract domain checking is instrumented ;; Arrow contract domain checking is instrumented
@ -398,7 +406,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda]) (let ([basic-lambda-name basic-lambda])
(arity-checking-wrapper val blame neg-party (arity-checking-wrapper val blame neg-party
basic-lambda-name basic-lambda-name #f #f #f
void void
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -410,7 +418,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda]) (let ([kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party (arity-checking-wrapper val blame neg-party
void void #f #f #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -423,7 +431,7 @@
(let ([basic-lambda-name basic-lambda] (let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda]) [kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party (arity-checking-wrapper val blame neg-party
basic-lambda-name basic-lambda-name #f #f #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -433,15 +441,34 @@
'(opt-kwd ...))))]))))))))))) '(opt-kwd ...))))])))))))))))
;; should we pass both the basic-lambda and the kwd-lambda? ;; should we pass both the basic-lambda and the kwd-lambda?
(define (arity-checking-wrapper val blame neg-party basic-lambda kwd-lambda ;; if basic-unsafe-lambda is #f, returns only the one value,
;; namely the chaperone wrapper. Otherwise, returns two values,
;; a procedure and a boolean indicating it the procedure is the
;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might
;; also be #t, but that happens only when we know that basic-lambda
;; can't be chosen (because there are keywords involved)
(define (arity-checking-wrapper val blame neg-party basic-lambda
basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed contract-result-val-count
kwd-lambda
min-method-arity max-method-arity min-arity max-arity min-method-arity max-method-arity min-arity max-arity
req-kwd opt-kwd) req-kwd opt-kwd)
;; should not build this unless we are in the 'else' case (and maybe not at all) ;; should not build this unless we are in the 'else' case (and maybe not at all)
(cond (cond
[(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd) [(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
(if (and (null? req-kwd) (null? opt-kwd)) (if (and (null? req-kwd) (null? opt-kwd))
basic-lambda (cond
kwd-lambda)] [(and basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed
(equal? contract-result-val-count
(procedure-result-arity val)))
(values basic-unsafe-lambda/result-values-assumed #t)]
[basic-unsafe-lambda
(values basic-unsafe-lambda #t)]
[else basic-lambda])
(if basic-unsafe-lambda
(values kwd-lambda #f)
kwd-lambda))]
[else [else
(define-values (vr va) (procedure-keywords val)) (define-values (vr va) (procedure-keywords val))
(define all-kwds (append req-kwd opt-kwd)) (define all-kwds (append req-kwd opt-kwd))
@ -493,9 +520,13 @@
(raise-blame-error (blame-swap blame) #:missing-party neg-party val (raise-blame-error (blame-swap blame) #:missing-party neg-party val
"expected required keyword ~a" "expected required keyword ~a"
(car req-kwd))))) (car req-kwd)))))
(define proc
(if (or (not va) (pair? vr) (pair? va)) (if (or (not va) (pair? vr) (pair? va))
(make-keyword-procedure kwd-checker basic-checker-name) (make-keyword-procedure kwd-checker basic-checker-name)
basic-checker-name)])) basic-checker-name))
(if basic-unsafe-lambda
(values proc #f)
proc)]))
(define (raise-wrong-number-of-args-error (define (raise-wrong-number-of-args-error
blame #:missing-party [missing-party #f] val blame #:missing-party [missing-party #f] val

8
racket/collects/racket/contract/private/base.rkt
View File

@ -74,8 +74,12 @@
(if clnp #f neg) (if clnp #f neg)
#t)) #t))
(cond (cond
[clnp ((clnp blame) v neg)] [clnp (with-contract-continuation-mark
[else (((contract-projection c) blame) v)]))) (cons blame neg)
((clnp blame) v neg))]
[else (with-contract-continuation-mark
blame
(((contract-projection c) blame) v))])))
(define-syntax (invariant-assertion stx) (define-syntax (invariant-assertion stx)
(syntax-case stx () (syntax-case stx ()

11
racket/collects/racket/contract/private/box.rkt
View File

@ -141,6 +141,7 @@
(define pos-elem-r-proj (r-vfp box-blame)) (define pos-elem-r-proj (r-vfp box-blame))
(define neg-elem-w-proj (w-vfp (blame-swap box-blame))) (define neg-elem-w-proj (w-vfp (blame-swap box-blame)))
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(cond (cond
[(check-box/c-np ctc val blame) [(check-box/c-np ctc val blame)
=> =>
@ -150,8 +151,14 @@
(box-immutable (pos-elem-r-proj (unbox val) neg-party)) (box-immutable (pos-elem-r-proj (unbox val) neg-party))
(chaperone/impersonate-box (chaperone/impersonate-box
val val
(λ (b v) (pos-elem-r-proj v neg-party)) (λ (b v)
(λ (b v) (neg-elem-w-proj v neg-party)) (with-contract-continuation-mark
blame+neg-party
(pos-elem-r-proj v neg-party)))
(λ (b v)
(with-contract-continuation-mark
blame+neg-party
(neg-elem-w-proj v neg-party)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party)))]))))) impersonator-prop:blame (blame-add-missing-party blame neg-party)))])))))

6
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -91,12 +91,14 @@
(λ (rng-checks) (λ (rng-checks)
#`(apply values #,@rng-checks this-parameter ... #`(apply values #,@rng-checks this-parameter ...
(dom-proj-x dom-formals neg-party) ... (dom-proj-x dom-formals neg-party) ...
(rst-proj-x rst-formal neg-party)))) (rst-proj-x rst-formal neg-party)))
#'(cons blame neg-party))
(check-tail-contract (check-tail-contract
#'rng-ctcs-x blame-party-info neg-party rng-checkers #'rng-ctcs-x blame-party-info neg-party rng-checkers
(λ (rng-checks) (λ (rng-checks)
#`(values/drop #,@rng-checks this-parameter ... #`(values/drop #,@rng-checks this-parameter ...
(dom-proj-x dom-formals neg-party) ...)))))] (dom-proj-x dom-formals neg-party) ...))
#'(cons blame neg-party))))]
[rst-ctc-expr [rst-ctc-expr
#`(apply values this-parameter ... #`(apply values this-parameter ...
(dom-proj-x dom-formals neg-party) ... (dom-proj-x dom-formals neg-party) ...

19
racket/collects/racket/contract/private/guts.rkt
View File

@ -772,11 +772,24 @@
(define contract-continuation-mark-key (define contract-continuation-mark-key
(make-continuation-mark-key 'contract)) (make-continuation-mark-key 'contract))
(define-syntax-rule (with-contract-continuation-mark payload code) ;; Instrumentation strategy:
;; - add instrumentation at entry points to the contract system:
;; - `contract` (`apply-contract`, really)
;; - `contract-out` (`do-partial-app`, really)
;; - all others go through one of the above
;; that instrumentation picks up "top-level" flat contracts (i.e., not part of
;; some higher-order contract) and the "eager" parts of higher-order contracts
;; - add instrumentation inside chaperones/impersonators created by projections
;; that instrumentation picks up the deferred work of higher-order contracts
;; - add instrumentation to `plus-one-arity-functions`
;; those perform checking, but don't rely on chaperones
;; they exist for -> and ->*, and are partially implemented for ->i
;; TODO once they're fully implemented for ->i, will need to instrument them
(define-syntax-rule (with-contract-continuation-mark payload code ...)
(begin (begin
;; ;; When debugging a missing blame party error, turn this on, then run ;; ;; When debugging a missing blame party error, turn this on, then run
;; ;; the contract test suite. It should find the problematic combinator. ;; ;; the contract test suite. It should find the problematic combinator.
;; (unless (or (pair? payload) (not (blame-missing-party? payload))) ;; (unless (or (pair? payload) (not (blame-missing-party? payload)))
;; (error "internal error: missing blame party" payload)) ;; (error "internal error: missing blame party" payload))
(with-continuation-mark contract-continuation-mark-key payload code))) (with-continuation-mark contract-continuation-mark-key payload
(let () code ...))))

27
racket/collects/racket/contract/private/hash.rkt
View File

@ -234,6 +234,7 @@
(define (handle-the-hash val neg-party (define (handle-the-hash val neg-party
pos-dom-proj neg-dom-proj mk-pos-rng-proj mk-neg-rng-proj pos-dom-proj neg-dom-proj mk-pos-rng-proj mk-neg-rng-proj
chaperone-or-impersonate-hash ctc blame) chaperone-or-impersonate-hash ctc blame)
(define blame+neg-party (cons blame neg-party))
(if (immutable? val) (if (immutable? val)
(for/fold ([h val]) ([(k v) (in-hash val)]) (for/fold ([h val]) ([(k v) (in-hash val)])
(hash-set h (hash-set h
@ -242,16 +243,26 @@
(chaperone-or-impersonate-hash (chaperone-or-impersonate-hash
val val
(λ (h k) (λ (h k)
(values (neg-dom-proj k neg-party) (values (with-contract-continuation-mark
(λ (h k v) blame+neg-party
((mk-pos-rng-proj k) v neg-party))))
(λ (h k v)
(values (neg-dom-proj k neg-party)
((mk-neg-rng-proj k) v neg-party)))
(λ (h k)
(neg-dom-proj k neg-party)) (neg-dom-proj k neg-party))
(λ (h k v)
(with-contract-continuation-mark
blame+neg-party
((mk-pos-rng-proj k) v neg-party)))))
(λ (h k v)
(with-contract-continuation-mark
blame+neg-party
(values (neg-dom-proj k neg-party)
((mk-neg-rng-proj k) v neg-party))))
(λ (h k) (λ (h k)
(pos-dom-proj k neg-party)) (with-contract-continuation-mark
blame+neg-party
(neg-dom-proj k neg-party)))
(λ (h k)
(with-contract-continuation-mark
blame+neg-party
(pos-dom-proj k neg-party)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame))) impersonator-prop:blame blame)))

46
racket/collects/racket/contract/private/misc.rkt
View File

@ -1283,7 +1283,10 @@
(c/i-procedure (c/i-procedure
proc proc
(λ (promise) (λ (promise)
(values (λ (val) (p-app val neg-party)) promise))))) (values (λ (val) (with-contract-continuation-mark
(cons blame neg-party)
(p-app val neg-party)))
promise)))))
(raise-blame-error (raise-blame-error
blame #:missing-party neg-party blame #:missing-party neg-party
val val
@ -1520,11 +1523,14 @@
(define cc-neg-projs (for/list ([proj (in-list call/cc-projs)]) (proj swapped))) (define cc-neg-projs (for/list ([proj (in-list call/cc-projs)]) (proj swapped)))
(define cc-pos-projs (for/list ([proj (in-list call/cc-projs)]) (proj blame))) (define cc-pos-projs (for/list ([proj (in-list call/cc-projs)]) (proj blame)))
(define (make-proj projs neg-party) (define (make-proj projs neg-party)
(define blame+neg-party (cons blame neg-party))
(λ vs (λ vs
(with-contract-continuation-mark
blame+neg-party
(apply values (apply values
(for/list ([proj (in-list projs)] (for/list ([proj (in-list projs)]
[v (in-list vs)]) [v (in-list vs)])
(proj v neg-party))))) (proj v neg-party))))))
(λ (val neg-party) (λ (val neg-party)
;; now do the actual wrapping ;; now do the actual wrapping
(cond (cond
@ -1604,11 +1610,16 @@
(define proj1 (ho-proj blame)) (define proj1 (ho-proj blame))
(define proj2 (ho-proj (blame-swap blame))) (define proj2 (ho-proj (blame-swap blame)))
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(cond (cond
[(continuation-mark-key? val) [(continuation-mark-key? val)
(proxy val (proxy val
(λ (v) (proj1 v neg-party)) (λ (v) (with-contract-continuation-mark
(λ (v) (proj2 v neg-party)) blame+neg-party
(proj1 v neg-party)))
(λ (v) (with-contract-continuation-mark
blame+neg-party
(proj2 v neg-party)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)] impersonator-prop:blame blame)]
[else [else
@ -1665,7 +1676,9 @@
(define ctcs (chaperone-evt/c-ctcs evt-ctc)) (define ctcs (chaperone-evt/c-ctcs evt-ctc))
(define projs (map contract-projection ctcs)) (define projs (map contract-projection ctcs))
(λ (blame) (λ (blame)
(define ((checker val) . args) (define ((checker val blame+neg-party) . args)
(with-contract-continuation-mark
blame+neg-party
(define expected-num (length ctcs)) (define expected-num (length ctcs))
(unless (= (length args) expected-num) (unless (= (length args) expected-num)
(raise-blame-error (raise-blame-error
@ -1677,9 +1690,9 @@
(apply (apply
values values
(for/list ([proj projs] [val args]) (for/list ([proj projs] [val args])
((proj blame) val)))) ((proj blame) val)))))
(define (generator evt) (define ((generator blame+neg-party) evt)
(values evt (checker evt))) (values evt (checker evt blame+neg-party)))
(λ (val neg-party) (λ (val neg-party)
(unless (contract-first-order-passes? evt-ctc val) (unless (contract-first-order-passes? evt-ctc val)
(raise-blame-error (raise-blame-error
@ -1687,7 +1700,7 @@
'(expected: "~s" given: "~e") '(expected: "~s" given: "~e")
(contract-name evt-ctc) (contract-name evt-ctc)
val)) val))
(chaperone-evt val generator)))) (chaperone-evt val (generator (cons blame neg-party))))))
;; evt/c-first-order : Contract -> Any -> Boolean ;; evt/c-first-order : Contract -> Any -> Boolean
;; First order check for evt/c ;; First order check for evt/c
@ -1733,8 +1746,19 @@
(λ (blame) (λ (blame)
(define pos-proj (ho-proj blame)) (define pos-proj (ho-proj blame))
(define neg-proj (ho-proj (blame-swap blame))) (define neg-proj (ho-proj (blame-swap blame)))
(define (proj1 neg-party) (λ (ch) (values ch (λ (v) (pos-proj v neg-party))))) (define (proj1 neg-party)
(define (proj2 neg-party) (λ (ch v) (neg-proj v neg-party))) (define blame+neg-party (cons blame neg-party))
(λ (ch)
(values ch (λ (v)
(with-contract-continuation-mark
blame+neg-party
(pos-proj v neg-party))))))
(define (proj2 neg-party)
(define blame+neg-party (cons blame neg-party))
(λ (ch v)
(with-contract-continuation-mark
blame+neg-party
(neg-proj v neg-party))))
(λ (val neg-party) (λ (val neg-party)
(cond (cond
[(channel? val) [(channel? val)

4
racket/collects/racket/contract/private/parametric.rkt
View File

@ -61,6 +61,8 @@
(define barrier/c (polymorphic-contract-barrier c)) (define barrier/c (polymorphic-contract-barrier c))
(define vars (polymorphic-contract-vars c)) (define vars (polymorphic-contract-vars c))
(define (wrap p neg-party) (define (wrap p neg-party)
(with-contract-continuation-mark
(cons blame neg-party)
;; values in polymorphic types come in from negative position, ;; values in polymorphic types come in from negative position,
;; relative to the poly/c contract ;; relative to the poly/c contract
(define instances (define instances
@ -68,7 +70,7 @@
(barrier/c negative? var))) (barrier/c negative? var)))
(define protector (define protector
(apply (polymorphic-contract-body c) instances)) (apply (polymorphic-contract-body c) instances))
(((get/build-late-neg-projection protector) blame) p neg-party)) (((get/build-late-neg-projection protector) blame) p neg-party)))
(lambda (p neg-party) (lambda (p neg-party)
(unless (procedure? p) (unless (procedure? p)

35
racket/collects/racket/contract/private/provide.rkt
View File

@ -152,14 +152,16 @@
;; expressions: ;; expressions:
(quasisyntax/loc stx (#%expression #,stx))))))) (quasisyntax/loc stx (#%expression #,stx)))))))
(struct provide/contract-transformer provide/contract-info (saved-id-table partially-applied-id) (struct provide/contract-transformer provide/contract-info (saved-id-table partially-applied-id blame)
#:property #:property
prop:set!-transformer prop:set!-transformer
(λ (self stx) (λ (self stx)
(let ([partially-applied-id (provide/contract-transformer-partially-applied-id self)] (let ([partially-applied-id (provide/contract-transformer-partially-applied-id self)]
[saved-id-table (provide/contract-transformer-saved-id-table self)] [saved-id-table (provide/contract-transformer-saved-id-table self)]
[rename-id (provide/contract-info-rename-id self)]) [rename-id (provide/contract-info-rename-id self)]
(with-syntax ([partially-applied-id partially-applied-id]) [blame (provide/contract-transformer-blame self)])
(with-syntax ([partially-applied-id partially-applied-id]
[blame blame])
(if (eq? 'expression (syntax-local-context)) (if (eq? 'expression (syntax-local-context))
;; In an expression context: ;; In an expression context:
(let* ([key (syntax-local-lift-context)] (let* ([key (syntax-local-lift-context)]
@ -171,7 +173,9 @@
(syntax-local-introduce (syntax-local-introduce
(syntax-local-lift-expression (syntax-local-lift-expression
(add-lifted-property (add-lifted-property
#'(partially-applied-id (quote-module-name)))))))]) #'(with-contract-continuation-mark
(cons blame 'no-negative-party)
(partially-applied-id (quote-module-name))))))))])
(when key (hash-set! saved-id-table key lifted-ctcd-val)) (when key (hash-set! saved-id-table key lifted-ctcd-val))
(define (adjust-location new-stx) (define (adjust-location new-stx)
(datum->syntax new-stx (syntax-e new-stx) stx new-stx)) (datum->syntax new-stx (syntax-e new-stx) stx new-stx))
@ -195,13 +199,14 @@
;; expressions: ;; expressions:
(quasisyntax/loc stx (#%expression #,stx))))))) (quasisyntax/loc stx (#%expression #,stx)))))))
(define (make-provide/contract-transformer rename-id cid id eid pos [pid #f]) (define (make-provide/contract-transformer rename-id cid id eid pos [pid #f] [blame #f])
(if pid (if pid
(provide/contract-transformer rename-id cid id (make-hasheq) pid) (provide/contract-transformer rename-id cid id (make-hasheq) pid blame)
(begin (begin
;; TODO: this needs to change! ;; TODO: this needs to change!
;; syntax/parse uses this ;; syntax/parse uses this
;; this will just drop contracts for now. ;; this will just drop contracts for now.
;; VS: is this still the case? this function is not exported anymore
(λ (stx) (λ (stx)
(syntax-case stx () (syntax-case stx ()
[(_ args ...) [(_ args ...)
@ -286,12 +291,12 @@
[(->i . _) (values #t (->i-valid-app-shapes ctrct))] [(->i . _) (values #t (->i-valid-app-shapes ctrct))]
[_ (values #f #f)])) [_ (values #f #f)]))
(with-syntax ([id id] (with-syntax ([id id]
[(partially-applied-id extra-neg-party-argument-fn contract-id) [(partially-applied-id extra-neg-party-argument-fn contract-id blame-id)
(generate-temporaries (list 'idX 'idY 'idZ))] (generate-temporaries (list 'idX 'idY 'idZ 'idB))]
[ctrct ctrct]) [ctrct ctrct])
(syntax-local-lift-module-end-declaration (syntax-local-lift-module-end-declaration
#`(begin #`(begin
(define partially-applied-id (define-values (partially-applied-id blame-id)
(do-partial-app contract-id (do-partial-app contract-id
id id
'#,name-for-blame '#,name-for-blame
@ -322,7 +327,8 @@
(quote-syntax #,id-rename) (quote-syntax #,id-rename)
(quote-syntax contract-id) (quote-syntax id) (quote-syntax contract-id) (quote-syntax id)
#f #f #f #f
(quote-syntax partially-applied-id))))))) (quote-syntax partially-applied-id)
(quote-syntax blame-id)))))))
(define-syntax (define-module-boundary-contract stx) (define-syntax (define-module-boundary-contract stx)
(cond (cond
@ -375,7 +381,7 @@
'define-module-boundary-contract 'define-module-boundary-contract
pos-blame-party-expr))])])) pos-blame-party-expr))])]))
;; ... -> (or/c #f (-> blame val)) ;; ... -> (values (or/c #f (-> neg-party val)) blame)
(define (do-partial-app ctc val name pos-module-source source) (define (do-partial-app ctc val name pos-module-source source)
(define p (parameterize ([warn-about-val-first? #f]) (define p (parameterize ([warn-about-val-first? #f])
;; when we're building the val-first projection ;; when we're building the val-first projection
@ -388,14 +394,19 @@
(λ () (contract-name ctc)) (λ () (contract-name ctc))
pos-module-source pos-module-source
#f #t)) #f #t))
(with-contract-continuation-mark
(cons blme 'no-negative-party) ; we don't know the negative party yet
;; computing neg-accepter may involve some front-loaded checking. instrument
(define neg-accepter ((p blme) val)) (define neg-accepter ((p blme) val))
;; check as much as we can while knowing only the
;; contracted value (e.g., function arity)
;; we don't have the negative blame here, but we ;; we don't have the negative blame here, but we
;; expect only positive failures from this; do the ;; expect only positive failures from this; do the
;; check and then toss the results. ;; check and then toss the results.
(neg-accepter 'incomplete-blame-from-provide.rkt) (neg-accepter 'incomplete-blame-from-provide.rkt)
neg-accepter) (values neg-accepter blme)))
(define-for-syntax (true-provide/contract provide-stx just-check-errors? who) (define-for-syntax (true-provide/contract provide-stx just-check-errors? who)
(syntax-case provide-stx () (syntax-case provide-stx ()

33
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -330,6 +330,7 @@
(define mut-indy-proj (car mut-indy-projs)) (define mut-indy-proj (car mut-indy-projs))
(define sel (and (subcontract? subcontract) (subcontract-ref subcontract))) (define sel (and (subcontract? subcontract) (subcontract-ref subcontract)))
(define blame (car blames)) (define blame (car blames))
(define blame+neg-party (cons blame neg-party))
(define mut-blame (car mut-blames)) (define mut-blame (car mut-blames))
(define indy-blame (car indy-blames)) (define indy-blame (car indy-blames))
(define mut-indy-blame (car mut-indy-blames)) (define mut-indy-blame (car mut-indy-blames))
@ -344,7 +345,7 @@
(cond (cond
[(invariant? subcontract) [(invariant? subcontract)
(unless (with-contract-continuation-mark (unless (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(apply (invariant-dep-proc subcontract) dep-args)) (apply (invariant-dep-proc subcontract) dep-args))
(raise-invariant-blame-failure blame neg-party v (raise-invariant-blame-failure blame neg-party v
(reverse dep-args) (reverse dep-args)
@ -352,7 +353,7 @@
(values chaperone-args impersonate-args)] (values chaperone-args impersonate-args)]
[(immutable? subcontract) [(immutable? subcontract)
(define (chk fld v) (with-contract-continuation-mark (define (chk fld v) (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(proj v neg-party))) (proj v neg-party)))
(chk #f (sel v)) ;; check the field contract immediately (chk #f (sel v)) ;; check the field contract immediately
(values (if (flat-contract? (indep-ctc subcontract)) (values (if (flat-contract? (indep-ctc subcontract))
@ -363,7 +364,7 @@
(values (list* sel (values (list* sel
(cache-λ (fld v) (cache-λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(proj v neg-party))) (proj v neg-party)))
chaperone-args) chaperone-args)
impersonate-args)] impersonate-args)]
@ -373,23 +374,23 @@
(list* sel (list* sel
(λ (fld v) (λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(proj v neg-party))) (proj v neg-party)))
(mutable-set subcontract) (mutable-set subcontract)
(λ (fld v) (λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(mut-proj v neg-party))) (mut-proj v neg-party)))
impersonate-args)) impersonate-args))
(values (list* sel (values (list* sel
(λ (fld v) (λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(proj v neg-party))) (proj v neg-party)))
(mutable-set subcontract) (mutable-set subcontract)
(λ (fld v) (λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(mut-proj v neg-party))) (mut-proj v neg-party)))
chaperone-args) chaperone-args)
impersonate-args))] impersonate-args))]
@ -398,7 +399,7 @@
(cond (cond
[(dep-immutable? subcontract) [(dep-immutable? subcontract)
(define (chk fld v) (with-contract-continuation-mark (define (chk fld v) (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(proj v neg-party))) (proj v neg-party)))
(chk #f (sel v)) ;; check the field contract immediately (chk #f (sel v)) ;; check the field contract immediately
(values (if (flat-contract? dep-ctc) (values (if (flat-contract? dep-ctc)
@ -409,7 +410,7 @@
(values (list* sel (values (list* sel
(cache-λ (fld v) (cache-λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(proj v neg-party))) (proj v neg-party)))
chaperone-args) chaperone-args)
impersonate-args)] impersonate-args)]
@ -419,12 +420,12 @@
(values (list* sel (values (list* sel
(λ (fld v) (λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(proj v neg-party))) (proj v neg-party)))
(dep-mutable-set subcontract) (dep-mutable-set subcontract)
(λ (fld v) (λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(mut-proj v neg-party))) (mut-proj v neg-party)))
chaperone-args) chaperone-args)
impersonate-args) impersonate-args)
@ -432,12 +433,12 @@
(list* sel (list* sel
(λ (fld v) (λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(proj v neg-party))) (proj v neg-party)))
(dep-mutable-set subcontract) (dep-mutable-set subcontract)
(λ (fld v) (λ (fld v)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(mut-proj v neg-party))) (mut-proj v neg-party)))
impersonate-args)))] impersonate-args)))]
[(dep-on-state-immutable? subcontract) [(dep-on-state-immutable? subcontract)
@ -445,7 +446,7 @@
(values (list* sel (values (list* sel
(λ (strct val) (λ (strct val)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(build-dep-on-state-proj (build-dep-on-state-proj
(base-struct/dc-subcontracts ctc) subcontract strct (base-struct/dc-subcontracts ctc) subcontract strct
orig-indy-projs orig-indy-blames blame neg-party val))) orig-indy-projs orig-indy-blames blame neg-party val)))
@ -455,13 +456,13 @@
(proj (sel v) neg-party) (proj (sel v) neg-party)
(define (get-chap-proc strct val) (define (get-chap-proc strct val)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct
orig-indy-projs orig-indy-blames blame neg-party orig-indy-projs orig-indy-blames blame neg-party
val))) val)))
(define (set-chap-proc strct val) (define (set-chap-proc strct val)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(build-dep-on-state-proj (build-dep-on-state-proj
(base-struct/dc-subcontracts ctc) subcontract strct (base-struct/dc-subcontracts ctc) subcontract strct
orig-mut-indy-projs orig-mut-indy-blames mut-blame neg-party val))) orig-mut-indy-projs orig-mut-indy-blames mut-blame neg-party val)))

5
racket/collects/racket/contract/private/struct-prop.rkt
View File

@ -16,11 +16,14 @@
(raise-blame-error input-blame x #:neg-party (raise-blame-error input-blame x #:neg-party
'(expected "struct-type-property" given: "~e") '(expected "struct-type-property" given: "~e")
x)) x))
(define blame+neg-party (cons blame neg-party))
(define-values (nprop _pred _acc) (define-values (nprop _pred _acc)
(make-struct-type-property (make-struct-type-property
(wrap-name x) (wrap-name x)
(lambda (val _info) (lambda (val _info)
(late-neg-proj val neg-party)) (with-contract-continuation-mark
blame+neg-party
(late-neg-proj val neg-party)))
(list (cons x values)))) (list (cons x values))))
nprop))) nprop)))

5
racket/collects/racket/contract/private/vector.rkt
View File

@ -365,14 +365,11 @@
(for/list ([c (in-list (base-vector/c-elems ctc))]) (for/list ([c (in-list (base-vector/c-elems ctc))])
((get/build-late-neg-projection c) blame+ctxt))) ((get/build-late-neg-projection c) blame+ctxt)))
(λ (val neg-party) (λ (val neg-party)
(with-contract-continuation-mark
(cons blame neg-party)
(begin
(check-vector/c ctc val blame neg-party) (check-vector/c ctc val blame neg-party)
(for ([e (in-vector val)] (for ([e (in-vector val)]
[p (in-list val+np-acceptors)]) [p (in-list val+np-acceptors)])
(p e neg-party)) (p e neg-party))
val))))))) val)))))
(define (vector/c-ho-late-neg-projection vector-wrapper) (define (vector/c-ho-late-neg-projection vector-wrapper)
(λ (ctc) (λ (ctc)

23
racket/collects/racket/match/match-expander.rkt
View File

@ -11,12 +11,29 @@
#:property prop:set!-transformer #:property prop:set!-transformer
(λ (me stx) (λ (me stx)
(define xf (match-expander-macro-xform me)) (define xf (match-expander-macro-xform me))
(if (set!-transformer? xf) (define proc
((set!-transformer-procedure xf) stx) (cond [(rename-transformer? xf)
(lambda (x)
(define target (rename-transformer-target xf))
(syntax-case stx (set!)
[(set! id args ...)
#`(set! #,target args ...)]
[(id args ...)
(datum->syntax stx
`(,target ,@(syntax->list #'(args ...)))
stx stx)]
[_ (rename-transformer-target xf)]))]
[(set!-transformer? xf) (set!-transformer-procedure xf)]
[(procedure? xf)
(lambda (stx)
(syntax-case stx (set!) (syntax-case stx (set!)
[(set! . _) [(set! . _)
(raise-syntax-error #f "cannot mutate syntax identifier" stx)] (raise-syntax-error #f "cannot mutate syntax identifier" stx)]
[_ (xf stx)]))) [_ (xf stx)]))]
[else (raise-syntax-error
#f
"not a procedure for match expander transformer" stx)]))
(proc stx))
#:property prop:match-expander (struct-field-index match-xform) #:property prop:match-expander (struct-field-index match-xform)
#:property prop:legacy-match-expander (struct-field-index legacy-xform)) #:property prop:legacy-match-expander (struct-field-index legacy-xform))
(values make-match-expander)))) (values make-match-expander))))

11
racket/collects/racket/private/class-c-old.rkt
View File

@ -1649,6 +1649,15 @@
(define prj (contract-late-neg-projection c)) (define prj (contract-late-neg-projection c))
(define p-pos (prj (blame-add-field-context blame f #:swap? #f))) (define p-pos (prj (blame-add-field-context blame f #:swap? #f)))
(define p-neg (prj (blame-add-field-context blame f #:swap? #t))) (define p-neg (prj (blame-add-field-context blame f #:swap? #t)))
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg neg-party))))) (hash-set! field-ht f (field-info-extend-external fi
(lambda args
(with-contract-continuation-mark
(cons blame neg-party)
(apply p-pos args)))
(lambda args
(with-contract-continuation-mark
(cons blame neg-party)
(apply p-neg args)))
neg-party)))))
(copy-seals cls c))) (copy-seals cls c)))

116
racket/collects/racket/private/for.rkt
View File

@ -48,10 +48,10 @@
(rename *in-port in-port) (rename *in-port in-port)
(rename *in-lines in-lines) (rename *in-lines in-lines)
(rename *in-bytes-lines in-bytes-lines) (rename *in-bytes-lines in-bytes-lines)
in-hash (rename *in-hash in-hash)
in-hash-keys (rename *in-hash-keys in-hash-keys)
in-hash-values (rename *in-hash-values in-hash-values)
in-hash-pairs (rename *in-hash-pairs in-hash-pairs)
in-directory in-directory
in-sequences in-sequences
@ -664,12 +664,93 @@
(values (hash-iterate-key ht pos) (values (hash-iterate-key ht pos)
(hash-iterate-value ht pos))))) (hash-iterate-value ht pos)))))
(define-sequence-syntax *in-hash
(lambda () #'in-hash)
(lambda (stx)
(syntax-case stx ()
[[(k v) (_ ht-expr)]
(for-clause-syntax-protect
#'[(k v)
(:do-in
;;outer bindings
([(ht) ht-expr])
;; outer check
(unless (hash? ht) (in-hash ht))
;; loop bindings
([i (hash-iterate-first ht)])
;; pos check
i
;; inner bindings
([(k v) (values (hash-iterate-key ht i)
(hash-iterate-value ht i))])
;; pre guard
#t
;; post guard
#t
;; loop args
((hash-iterate-next ht i)))])]
[_ #f])))
(define (in-hash-keys ht) (define (in-hash-keys ht)
(unless (hash? ht) (raise-argument-error 'in-hash-keys "hash?" ht)) (unless (hash? ht) (raise-argument-error 'in-hash-keys "hash?" ht))
(make-do-sequence (lambda () (:hash-gen ht hash-iterate-key)))) (make-do-sequence (lambda () (:hash-gen ht hash-iterate-key))))
(define-sequence-syntax *in-hash-keys
(lambda () #'in-hash-keys)
(lambda (stx)
(syntax-case stx ()
[[(id) (_ ht-expr)]
(for-clause-syntax-protect
#'[(id)
(:do-in
;;outer bindings
([(ht) ht-expr])
;; outer check
(unless (hash? ht) (in-hash-keys ht))
;; loop bindings
([i (hash-iterate-first ht)])
;; pos check
i
;; inner bindings
([(id) (hash-iterate-key ht i)])
;; pre guard
#t
;; post guard
#t
;; loop args
((hash-iterate-next ht i)))])]
[_ #f])))
(define (in-hash-values ht) (define (in-hash-values ht)
(unless (hash? ht) (raise-argument-error 'in-hash-values "hash?" ht)) (unless (hash? ht) (raise-argument-error 'in-hash-values "hash?" ht))
(make-do-sequence (lambda () (:hash-gen ht hash-iterate-value)))) (make-do-sequence (lambda () (:hash-gen ht hash-iterate-value))))
(define-sequence-syntax *in-hash-values
(lambda () #'in-hash-values)
(lambda (stx)
(syntax-case stx ()
[[(id) (_ ht-expr)]
(for-clause-syntax-protect
#'[(id)
(:do-in
;;outer bindings
([(ht) ht-expr])
;; outer check
(unless (hash? ht) (in-hash-values ht))
;; loop bindings
([i (hash-iterate-first ht)])
;; pos check
i
;; inner bindings
([(id) (hash-iterate-value ht i)])
;; pre guard
#t
;; post guard
#t
;; loop args
((hash-iterate-next ht i)))])]
[_ #f])))
(define (in-hash-pairs ht) (define (in-hash-pairs ht)
(unless (hash? ht) (raise-argument-error 'in-hash-values "hash?" ht)) (unless (hash? ht) (raise-argument-error 'in-hash-values "hash?" ht))
(make-do-sequence (lambda () (make-do-sequence (lambda ()
@ -677,6 +758,33 @@
(cons (hash-iterate-key ht pos) (cons (hash-iterate-key ht pos)
(hash-iterate-value ht pos))))))) (hash-iterate-value ht pos)))))))
(define-sequence-syntax *in-hash-pairs
(lambda () #'in-hash-pairs)
(lambda (stx)
(syntax-case stx ()
[[(id) (_ ht-expr)]
(for-clause-syntax-protect
#'[(id)
(:do-in
;;outer bindings
([(ht) ht-expr])
;; outer check
(unless (hash? ht) (in-hash-pairs ht))
;; loop bindings
([i (hash-iterate-first ht)])
;; pos check
i
;; inner bindings
([(id) (cons (hash-iterate-key ht i)
(hash-iterate-value ht i))])
;; pre guard
#t
;; post guard
#t
;; loop args
((hash-iterate-next ht i)))])]
[_ #f])))
(define (:hash-gen ht sel) (define (:hash-gen ht sel)
(values (lambda (pos) (sel ht pos)) (values (lambda (pos) (sel ht pos))
(lambda (pos) (hash-iterate-next ht pos)) (lambda (pos) (hash-iterate-next ht pos))

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

@ -2,7 +2,11 @@
(#%require "define.rkt" (#%require "define.rkt"
"small-scheme.rkt" "small-scheme.rkt"
"more-scheme.rkt" "more-scheme.rkt"
(only '#%unsafe
unsafe-chaperone-procedure
unsafe-impersonate-procedure)
(for-syntax '#%kernel (for-syntax '#%kernel
'#%unsafe
"procedure-alias.rkt" "procedure-alias.rkt"
"stx.rkt" "stx.rkt"
"small-scheme.rkt" "small-scheme.rkt"
@ -26,7 +30,9 @@
new:procedure->method new:procedure->method
new:procedure-rename new:procedure-rename
new:chaperone-procedure new:chaperone-procedure
(protect new:unsafe-chaperone-procedure)
new:impersonate-procedure new:impersonate-procedure
(protect new:unsafe-impersonate-procedure)
new:chaperone-procedure* new:chaperone-procedure*
new:impersonate-procedure* new:impersonate-procedure*
(for-syntax kw-expander? kw-expander-impl kw-expander-proc (for-syntax kw-expander? kw-expander-impl kw-expander-proc
@ -634,7 +640,7 @@
(let ([#,core-id #,impl]) (let ([#,core-id #,impl])
(let ([#,unpack-id #,kwimpl]) (let ([#,unpack-id #,kwimpl])
#,wrap)))))) #,wrap))))))
#`(#%expression #,stx)))]) (quasisyntax/loc stx (#%expression #,stx))))])
(values new-lambda new-lambda))) (values new-lambda new-lambda)))
(define (missing-kw proc . args) (define (missing-kw proc . args)
@ -1529,12 +1535,24 @@
(do-chaperone-procedure #f #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:unsafe-chaperone-procedure
(let ([unsafe-chaperone-procedure
(lambda (proc wrap-proc . props)
(do-unsafe-chaperone-procedure unsafe-chaperone-procedure 'unsafe-chaperone-procedure proc wrap-proc props))])
unsafe-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 #f 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 new:unsafe-impersonate-procedure
(let ([unsafe-impersonate-procedure
(lambda (proc wrap-proc . props)
(do-unsafe-chaperone-procedure unsafe-impersonate-procedure 'unsafe-impersonate-procedure proc wrap-proc props))])
unsafe-impersonate-procedure))
(define new:chaperone-procedure* (define new:chaperone-procedure*
(let ([chaperone-procedure* (let ([chaperone-procedure*
(lambda (proc wrap-proc . props) (lambda (proc wrap-proc . props)
@ -1553,52 +1571,10 @@
(if (or (not (keyword-procedure? n-proc)) (if (or (not (keyword-procedure? n-proc))
(not (procedure? wrap-proc)) (not (procedure? wrap-proc))
;; if any bad prop, let `chaperone-procedure' complain ;; if any bad prop, let `chaperone-procedure' complain
(let loop ([props props]) (bad-props? props))
(cond
[(null? props) #f]
[(impersonator-property? (car props))
(let ([props (cdr props)])
(or (null? props)
(loop (cdr props))))]
[else #t])))
(apply chaperone-procedure proc wrap-proc props) (apply chaperone-procedure proc wrap-proc props)
(let-values ([(a) (procedure-arity proc)] (begin
[(b) (procedure-arity wrap-proc)] (chaperone-arity-match-checking self-arg? name proc wrap-proc props)
[(d) (if self-arg? 1 0)]
[(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 d))]
[(arity-at-least? a)
(b . >= . (+ (arity-at-least-value a) d))]
[else
(ormap (lambda (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) d))]
[else (ormap (lambda (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-arguments-error
name
"wrapper procedure requires more keywords than original procedure"
"wrapper procedure" wrap-proc
"original procedure" proc))
(unless (or (not b-allow)
(and a-allow
(subset? a-allow b-allow)))
(raise-arguments-error
name
"wrapper procedure does not accept all keywords of original procedure"
"wrapper procedure" wrap-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)])
;; `extra-arg ...` will be `self-proc` if `self-arg?`: ;; `extra-arg ...` will be `self-proc` if `self-arg?`:
@ -1759,6 +1735,68 @@
chap-accessor #f chap-accessor #f
props))))))) props)))))))
(define (do-unsafe-chaperone-procedure unsafe-chaperone-procedure name proc wrap-proc props)
(let ([n-proc (normalize-proc proc)]
[n-wrap-proc (normalize-proc wrap-proc)])
(if (or (not (keyword-procedure? n-proc))
(not (procedure? wrap-proc))
;; if any bad prop, let `unsafe-chaperone-procedure' complain
(bad-props? props))
(apply unsafe-chaperone-procedure proc wrap-proc props)
(begin
(chaperone-arity-match-checking #f name proc wrap-proc props)
(apply unsafe-chaperone-procedure proc wrap-proc props)))))
(define (bad-props? props)
(let loop ([props props])
(cond
[(null? props) #f]
[(impersonator-property? (car props))
(let ([props (cdr props)])
(or (null? props)
(loop (cdr props))))]
[else #t])))
(define (chaperone-arity-match-checking self-arg? name proc wrap-proc props)
(let-values ([(a) (procedure-arity proc)]
[(b) (procedure-arity wrap-proc)]
[(d) (if self-arg? 1 0)]
[(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 d))]
[(arity-at-least? a)
(b . >= . (+ (arity-at-least-value a) d))]
[else
(ormap (lambda (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) d))]
[else (ormap (lambda (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-arguments-error
name
"wrapper procedure requires more keywords than original procedure"
"wrapper procedure" wrap-proc
"original procedure" proc))
(unless (or (not b-allow)
(and a-allow
(subset? a-allow b-allow)))
(raise-arguments-error
name
"wrapper procedure does not accept all keywords of original procedure"
"wrapper procedure" wrap-proc
"original procedure" proc))
(void)))
(define (normalize-proc proc) (define (normalize-proc proc)
;; If `proc' gets keyword support through `new-prop:procedure', ;; If `proc' gets keyword support through `new-prop:procedure',
;; then wrap it to normalize to to something that matches ;; then wrap it to normalize to to something that matches

10
racket/collects/racket/sequence.rkt
View File

@ -218,6 +218,7 @@
orig-blame #:missing-party neg-party seq orig-blame #:missing-party neg-party seq
'(expected: "a sequence" given: "~e") '(expected: "a sequence" given: "~e")
seq)) seq))
(define blame+neg-party (cons orig-blame neg-party))
(define result-seq (define result-seq
(make-do-sequence (make-do-sequence
(lambda () (lambda ()
@ -228,7 +229,9 @@
next next
(case-lambda (case-lambda
[(elem) [(elem)
(p elem neg-party)] (with-contract-continuation-mark
blame+neg-party
(p elem neg-party))]
[elems [elems
(define n-elems (length elems)) (define n-elems (length elems))
(raise-blame-error (raise-blame-error
@ -251,6 +254,7 @@
orig-blame #:missing-party neg-party seq orig-blame #:missing-party neg-party seq
'(expected: "a sequence" given: "~e") '(expected: "a sequence" given: "~e")
seq)) seq))
(define blame+neg-party (cons orig-blame neg-party))
(define result-seq (define result-seq
(make-do-sequence (make-do-sequence
(lambda () (lambda ()
@ -260,6 +264,8 @@
(call-with-values (call-with-values
next next
(lambda elems (lambda elems
(with-contract-continuation-mark
blame+neg-party
(define n-elems (length elems)) (define n-elems (length elems))
(unless (= n-elems n-cs) (unless (= n-elems n-cs)
(raise-blame-error (raise-blame-error
@ -270,7 +276,7 @@
values values
(for/list ([elem (in-list elems)] (for/list ([elem (in-list elems)]
[p (in-list ps)]) [p (in-list ps)])
(p elem neg-party)))))) (p elem neg-party)))))))
add1 add1
0 0
(lambda (idx) (lambda (idx)

38
racket/collects/racket/set.rkt
View File

@ -198,6 +198,7 @@
(λ (val neg-party) (λ (val neg-party)
(set-contract-check cmp kind blame neg-party val) (set-contract-check cmp kind blame neg-party val)
(define (pos-interpose val ele) (late-neg-pos-proj ele neg-party)) (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
(define blame+neg-party (cons blame neg-party))
(cond (cond
[(set? val) [(set? val)
(chaperone-hash-set (chaperone-hash-set
@ -205,31 +206,44 @@
(λ (val ele) ele) (λ (val ele) ele)
(λ (val ele) ele) (λ (val ele) ele)
(λ (val ele) ele) (λ (val ele) ele)
(λ (val ele) (late-neg-pos-proj ele neg-party)) (λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-pos-proj ele neg-party)))
(λ (val) (void)) (λ (val) (void))
(λ (val ele) (late-neg-equal-key-pos-proj ele neg-party)) (λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-equal-key-pos-proj ele neg-party)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))] impersonator-prop:blame (cons blame neg-party))]
[else [else
(chaperone-hash-set (chaperone-hash-set
val val
(λ (val ele) ele) (λ (val ele) ele)
(λ (val ele) (late-neg-neg-proj ele neg-party)) (λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-neg-proj ele neg-party)))
(λ (val ele) ele) (λ (val ele) ele)
(λ (val ele) (late-neg-pos-proj ele neg-party)) (λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-pos-proj ele neg-party)))
(λ (val) (void)) (λ (val) (void))
(λ (val ele) (late-neg-equal-key-pos-proj ele neg-party)) (λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-equal-key-pos-proj ele neg-party)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]))] impersonator-prop:blame (cons blame neg-party))]))]
[else [else
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(set-contract-check cmp kind blame neg-party val) (set-contract-check cmp kind blame neg-party val)
(cond (cond
[(set? val) [(set? val)
(chaperone-hash-set (chaperone-hash-set
(for/fold ([s (set-clear val)]) (for/fold ([s (set-clear val)])
([e (in-set val)]) ([e (in-set val)])
(set-add s (late-neg-pos-proj e neg-party))) (set-add s (with-contract-continuation-mark
blame+neg-party
(late-neg-pos-proj e neg-party))))
#f #f #f #f #f #f
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))] impersonator-prop:blame (cons blame neg-party))]
@ -240,11 +254,17 @@
(chaperone-hash-set (chaperone-hash-set
val val
(λ (val ele) ele) (λ (val ele) ele)
(λ (val ele) (late-neg-neg-proj ele neg-party)) (λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-neg-proj ele neg-party)))
(λ (val ele) ele) (λ (val ele) ele)
(λ (val ele) (late-neg-pos-proj ele neg-party)) (λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-pos-proj ele neg-party)))
(λ (val) (void)) (λ (val) (void))
(λ (val ele) (late-neg-equal-key-pos-proj ele neg-party)) (λ (val ele) (with-contract-continuation-mark
blame+neg-party
(late-neg-equal-key-pos-proj ele neg-party)))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]))]))) impersonator-prop:blame (cons blame neg-party))]))])))

9
racket/collects/racket/stream.rkt
View File

@ -256,15 +256,20 @@
(unless (stream? val) (unless (stream? val)
(raise-blame-error blame #:missing-party neg-party (raise-blame-error blame #:missing-party neg-party
val '(expected "a stream" given: "~e") val)) val '(expected "a stream" given: "~e") val))
(define blame+neg-party (cons blame neg-party))
(if (list? val) (if (list? val)
(listof-elem-ctc-neg-acceptor val neg-party) (listof-elem-ctc-neg-acceptor val neg-party)
(impersonate/chaperone-stream (impersonate/chaperone-stream
val val
(λ (v) (elem-ctc-late-neg-acceptor v neg-party)) (λ (v) (with-contract-continuation-mark
blame+neg-party
(elem-ctc-late-neg-acceptor v neg-party)))
(λ (v) (λ (v)
(with-contract-continuation-mark
blame+neg-party
(if (list? v) (if (list? v)
(listof-elem-ctc-neg-acceptor v neg-party) (listof-elem-ctc-neg-acceptor v neg-party)
(stream/c-late-neg-proj-val-acceptor v neg-party))) (stream/c-late-neg-proj-val-acceptor v neg-party))))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame stream-blame))) impersonator-prop:blame stream-blame)))
stream/c-late-neg-proj-val-acceptor)) stream/c-late-neg-proj-val-acceptor))

9
racket/collects/racket/unsafe/ops.rkt
View File

@ -1,14 +1,19 @@
#lang racket/base #lang racket/base
(require '#%unsafe (require '#%unsafe
'#%flfxnum '#%flfxnum
'#%extfl) '#%extfl
"../private/kw.rkt")
(provide (except-out (all-from-out '#%unsafe) (provide (except-out (all-from-out '#%unsafe)
unsafe-undefined unsafe-undefined
check-not-unsafe-undefined check-not-unsafe-undefined
check-not-unsafe-undefined/assign check-not-unsafe-undefined/assign
prop:chaperone-unsafe-undefined prop:chaperone-unsafe-undefined
chaperone-struct-unsafe-undefined) chaperone-struct-unsafe-undefined
unsafe-chaperone-procedure
unsafe-impersonate-procedure)
(rename-out [new:unsafe-impersonate-procedure unsafe-impersonate-procedure]
[new:unsafe-chaperone-procedure unsafe-chaperone-procedure])
(prefix-out unsafe- (prefix-out unsafe-
(combine-out flsin flcos fltan (combine-out flsin flcos fltan
flasin flacos flatan flasin flacos flatan

31
racket/collects/syntax/id-table.rkt
View File

@ -130,19 +130,34 @@
(define pos-rng-proj (id-table/c-rng-pos-proj ctc blame)) (define pos-rng-proj (id-table/c-rng-pos-proj ctc blame))
(define neg-rng-proj (id-table/c-rng-neg-proj ctc blame)) (define neg-rng-proj (id-table/c-rng-neg-proj ctc blame))
(lambda (tbl neg-party) (lambda (tbl neg-party)
(define blame+neg-party (cons blame neg-party))
(check-id-table/c ctc tbl blame neg-party) (check-id-table/c ctc tbl blame neg-party)
;;TODO for immutable hash tables optimize this chaperone to a flat ;;TODO for immutable hash tables optimize this chaperone to a flat
;;check if possible ;;check if possible
(if (immutable-idtbl? tbl) (if (immutable-idtbl? tbl)
(chaperone-immutable-id-table tbl (chaperone-immutable-id-table
(λ (val) (pos-dom-proj val neg-party)) tbl
(λ (val) (pos-rng-proj val neg-party)) (λ (val) (with-contract-continuation-mark
blame+neg-party
(pos-dom-proj val neg-party)))
(λ (val) (with-contract-continuation-mark
blame+neg-party
(pos-rng-proj val neg-party)))
impersonator-prop:contracted ctc) impersonator-prop:contracted ctc)
(chaperone-mutable-id-table tbl (chaperone-mutable-id-table
(λ (val) (neg-dom-proj val neg-party)) tbl
(λ (val) (pos-dom-proj val neg-party)) (λ (val) (with-contract-continuation-mark
(λ (val) (neg-rng-proj val neg-party)) blame+neg-party
(λ (val) (pos-rng-proj val neg-party)) (neg-dom-proj val neg-party)))
(λ (val) (with-contract-continuation-mark
blame+neg-party
(pos-dom-proj val neg-party)))
(λ (val) (with-contract-continuation-mark
blame+neg-party
(neg-rng-proj val neg-party)))
(λ (val) (with-contract-continuation-mark
blame+neg-party
(pos-rng-proj val neg-party)))
impersonator-prop:contracted ctc))))) impersonator-prop:contracted ctc)))))
(struct flat-id-table/c base-id-table/c () (struct flat-id-table/c base-id-table/c ()

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

File diff suppressed because it is too large Load Diff

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

@ -182,12 +182,15 @@ 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 *procedure_specialize(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_specialize(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 *unsafe_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 *unsafe_impersonate_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure_star(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 *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[]);
static Scheme_Object *procedure_result_arity (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[]); static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_values(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_values(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_print(int argc, Scheme_Object **argv); static Scheme_Object *current_print(int argc, Scheme_Object **argv);
@ -641,6 +644,12 @@ scheme_init_fun (Scheme_Env *env)
1, 1, 1), 1, 1, 1),
env); env);
scheme_add_global_constant("procedure-result-arity",
scheme_make_folding_prim(procedure_result_arity,
"procedure-result-arity",
1, 1, 1),
env);
scheme_add_global_constant("current-print", scheme_add_global_constant("current-print",
scheme_register_parameter(current_print, scheme_register_parameter(current_print,
"current-print", "current-print",
@ -744,6 +753,17 @@ scheme_init_unsafe_fun (Scheme_Env *env)
o = scheme_make_prim_w_arity(chaperone_unsafe_undefined, "chaperone-struct-unsafe-undefined", 1, 1); o = scheme_make_prim_w_arity(chaperone_unsafe_undefined, "chaperone-struct-unsafe-undefined", 1, 1);
scheme_add_global_constant("chaperone-struct-unsafe-undefined", o, env); scheme_add_global_constant("chaperone-struct-unsafe-undefined", o, env);
scheme_add_global_constant("unsafe-chaperone-procedure",
scheme_make_prim_w_arity(unsafe_chaperone_procedure,
"unsafe-chaperone-procedure",
2, -1),
env);
scheme_add_global_constant("unsafe-impersonate-procedure",
scheme_make_prim_w_arity(unsafe_impersonate_procedure,
"unsafe-impersonate-procedure",
2, -1),
env);
} }
void void
@ -2873,13 +2893,61 @@ static Scheme_Object *primitive_result_arity(int argc, Scheme_Object *argv[])
return scheme_make_arity(p->minr, p->maxr); return scheme_make_arity(p->minr, p->maxr);
} }
} else { } else {
scheme_wrong_contract("primitive-result_arity", "primitive?", 0, argc, argv); scheme_wrong_contract("primitive-result-arity", "primitive?", 0, argc, argv);
return NULL; return NULL;
} }
return scheme_make_integer(1); return scheme_make_integer(1);
} }
static Scheme_Object *procedure_result_arity(int argc, Scheme_Object *argv[])
{
Scheme_Object *o, *orig_o;
orig_o = argv[0];
o = orig_o;
if (SCHEME_CHAPERONEP(o))
o = SCHEME_CHAPERONE_VAL(o);
/* Struct procedures could be keyword-accepting and that
requires additional complication; defer for now */
if (SAME_TYPE(SCHEME_TYPE(o), scheme_proc_struct_type)) {
return scheme_false;
}
if (SAME_TYPE(SCHEME_TYPE(o), scheme_closure_type)) {
if ((SCHEME_CLOSURE_DATA_FLAGS(SCHEME_COMPILED_CLOS_CODE(o)) & CLOS_SINGLE_RESULT)) {
return scheme_make_integer(1);
}
#ifdef MZ_USE_JIT
} else if (SAME_TYPE(SCHEME_TYPE(o), scheme_native_closure_type)) {
if (scheme_native_closure_is_single_result(o))
return scheme_make_integer(1);
#endif
} else if (SAME_TYPE(SCHEME_TYPE(o), scheme_case_closure_type)) {
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)o;
int i;
for (i = cl->count; i--; ) {
if (!(SCHEME_CLOSURE_DATA_FLAGS(SCHEME_COMPILED_CLOS_CODE(cl->array[i])) & CLOS_SINGLE_RESULT))
break;
}
if (i < 0)
return scheme_make_integer(1);
} else if (SCHEME_PRIMP(o)) {
if (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
Scheme_Prim_W_Result_Arity *p = (Scheme_Prim_W_Result_Arity *)o;
return scheme_make_arity(p->minr, p->maxr);
}
return scheme_make_integer(1);
} else if (!SCHEME_PROCP(o)) {
scheme_wrong_contract("procedure-result-arity", "procedure?", 0, argc, argv);
return NULL;
}
return scheme_false;
}
Scheme_Object *scheme_object_name(Scheme_Object *a) Scheme_Object *scheme_object_name(Scheme_Object *a)
{ {
Scheme_Object *v; Scheme_Object *v;
@ -3465,9 +3533,9 @@ static Scheme_Object *procedure_specialize(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 pass_self, int is_impersonator, int pass_self,
int argc, Scheme_Object *argv[]) int argc, Scheme_Object *argv[], int is_unsafe)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px, *px2;
Scheme_Object *val = argv[0], *orig, *naya, *r, *app_mark; Scheme_Object *val = argv[0], *orig, *naya, *r, *app_mark;
Scheme_Hash_Tree *props; Scheme_Hash_Tree *props;
@ -3476,8 +3544,13 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
if (!SCHEME_PROCP(val)) if (!SCHEME_PROCP(val))
scheme_wrong_contract(name, "procedure?", 0, argc, argv); scheme_wrong_contract(name, "procedure?", 0, argc, argv);
if (is_unsafe) {
if (!SCHEME_PROCP(argv[1]))
scheme_wrong_contract(name, "procedure?", 1, argc, argv);
} else {
if (!SCHEME_FALSEP(argv[1]) && !SCHEME_PROCP(argv[1])) if (!SCHEME_FALSEP(argv[1]) && !SCHEME_PROCP(argv[1]))
scheme_wrong_contract(name, "(or/c procedure? #f)", 1, argc, argv); scheme_wrong_contract(name, "(or/c procedure? #f)", 1, argc, argv);
}
orig = get_or_check_arity(val, -1, NULL, 1); orig = get_or_check_arity(val, -1, NULL, 1);
if (SCHEME_FALSEP(argv[1])) if (SCHEME_FALSEP(argv[1]))
@ -3524,42 +3597,79 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
px->props = props; px->props = props;
/* Put the procedure along with known-good arity (to speed checking; /* Put the procedure along with known-good arity (to speed checking;
initialized to -1) in a vector. An odd-sized vector makes the initialized to -1) in a vector.
chaperone recognized as a procedure chaperone, and a size of 5
(instead of 3) indicates that the wrapper procedure accepts a Vector of odd size for redirects means a procedure chaperone,
"self" argument: */ vector with even slots means a structure chaperone.
A size of 5 (instead of 3) indicates that the wrapper
procedure accepts a "self" argument. An immutable vector
means that it wraps a chaperone that wants the "self"
argument.
If the known-good arity is #f, this means the chaperone
wrapper defers directly to SCHEME_VEC_ELES(r)[0] and no
arity check is needed.
*/
r = scheme_make_vector((pass_self ? 5 : 3), scheme_make_integer(-1)); r = scheme_make_vector((pass_self ? 5 : 3), scheme_make_integer(-1));
if (SCHEME_FALSEP(argv[1]))
SCHEME_VEC_ELS(r)[0] = argv[0];
else
SCHEME_VEC_ELS(r)[0] = argv[1]; SCHEME_VEC_ELS(r)[0] = argv[1];
if (SCHEME_FALSEP(argv[1]))
SCHEME_VEC_ELS(r)[1] = scheme_false;
SCHEME_VEC_ELS(r)[2] = app_mark; SCHEME_VEC_ELS(r)[2] = app_mark;
/* Vector of odd size for redirects means a procedure chaperone,
vector with even slots means a structure chaperone. */
px->redirects = r; px->redirects = r;
if (is_impersonator) if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR; SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
if (is_unsafe || SCHEME_FALSEP(argv[1]))
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_PROC_CHAPERONE_CALL_DIRECT;
/* If there's a `pass_self` chaperone in px->prev, then we'll need
to pass the self proc along. */
for (val = px->prev; SCHEME_P_CHAPERONEP(val); val = ((Scheme_Chaperone *)val)->prev) {
px2 = (Scheme_Chaperone *)val;
if (SCHEME_VECTORP(px2->redirects) && (SCHEME_VEC_SIZE(px2->redirects) & 0x1)) {
if ((SCHEME_VEC_SIZE(px2->redirects) > 3)
|| SCHEME_IMMUTABLEP(px2->redirects))
SCHEME_SET_IMMUTABLE(px->redirects);
break;
}
}
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
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, 0, argc, argv); return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, 0, argc, argv, 0);
}
static Scheme_Object *unsafe_chaperone_procedure(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("unsafe-chaperone-procedure", "chaperoning", 0, 0, argc, argv, 1);
} }
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, 0, argc, argv); return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, 0, argc, argv, 0);
}
static Scheme_Object *unsafe_impersonate_procedure(int argc, Scheme_Object *argv[])
{
return do_chaperone_procedure("unsafe-impersonate-procedure", "impersonating", 1, 0, argc, argv, 1);
} }
static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[]) static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[])
{ {
return do_chaperone_procedure("chaperone-procedure*", "chaperoning", 0, 1, argc, argv); return do_chaperone_procedure("chaperone-procedure*", "chaperoning", 0, 1, argc, argv, 0);
} }
static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[]) static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[])
{ {
return do_chaperone_procedure("impersonate-procedure*", "impersonating", 1, 1, argc, argv); return do_chaperone_procedure("impersonate-procedure*", "impersonating", 1, 1, argc, argv, 0);
} }
static Scheme_Object *apply_chaperone_k(void) static Scheme_Object *apply_chaperone_k(void)
@ -3741,7 +3851,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
checks & 0x2 => no tail; checks == 0x3 => no tail or multiple */ checks & 0x2 => no tail; checks == 0x3 => no tail or multiple */
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark, *self_proc; Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark, *self_proc, *simple_call;
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;
@ -3767,9 +3877,28 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
self_proc = o; self_proc = o;
} }
if (SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[0])) { /* Ensure that the original procedure accepts `argc' arguments: */
if (!SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[1]) /* check not needed for props-only mode */
&& (argc != SCHEME_INT_VAL(SCHEME_VEC_ELS(px->redirects)[1]))) {
a[0] = px->prev;
if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) {
/* Apply the original procedure, in case the chaperone would accept
`argc' arguments (in addition to the original procedure's arity)
in case the methodness of the original procedure is different
from the chaperone, or in case the procedures have different names. */
(void)_scheme_apply_multi(px->prev, argc, argv);
scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure");
return NULL;
}
/* record that argc is ok, on the grounds that the function is likely
to be applied to argc arguments again */
SCHEME_VEC_ELS(px->redirects)[1] = scheme_make_integer(argc);
}
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_PROC_CHAPERONE_CALL_DIRECT) {
simple_call = SCHEME_VEC_ELS(px->redirects)[0];
/* no redirection procedure */ /* no redirection procedure */
if (SCHEME_CHAPERONEP(px->prev)) { if (SCHEME_IMMUTABLEP(px->redirects)) {
/* communicate `self_proc` to the next layer: */ /* communicate `self_proc` to the next layer: */
scheme_current_thread->self_for_proc_chaperone = self_proc; scheme_current_thread->self_for_proc_chaperone = self_proc;
} }
@ -3777,16 +3906,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
/* cannot return a tail call */ /* cannot return a tail call */
MZ_CONT_MARK_POS -= 2; MZ_CONT_MARK_POS -= 2;
if (checks & 0x1) { if (checks & 0x1) {
v = _scheme_apply(px->prev, argc, argv); v = _scheme_apply(simple_call, argc, argv);
} else if (SAME_TYPE(SCHEME_TYPE(px->prev), scheme_native_closure_type)) { } else if (SAME_TYPE(SCHEME_TYPE(simple_call), scheme_native_closure_type)) {
v = _apply_native(px->prev, argc, argv); v = _apply_native(simple_call, argc, argv);
} else { } else {
v = _scheme_apply_multi(px->prev, argc, argv); v = _scheme_apply_multi(simple_call, argc, argv);
} }
MZ_CONT_MARK_POS += 2; MZ_CONT_MARK_POS += 2;
return v; return v;
} else } else
return _scheme_tail_apply(px->prev, argc, argv); return _scheme_tail_apply(simple_call, argc, argv);
} }
if (argv == MZ_RUNSTACK) { if (argv == MZ_RUNSTACK) {
@ -3804,23 +3933,6 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} }
} }
/* Ensure that the original procedure accepts `argc' arguments: */
if (argc != SCHEME_INT_VAL(SCHEME_VEC_ELS(px->redirects)[1])) {
a[0] = px->prev;
if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) {
/* Apply the original procedure, in case the chaperone would accept
`argc' arguments (in addition to the original procedure's arity)
in case the methodness of the original procedure is different
from the chaperone, or in case the procedures have different names. */
(void)_scheme_apply_multi(px->prev, argc, argv);
scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure");
return NULL;
}
/* record that argc is ok, on the grounds that the function is likely
to be applied to argc arguments again */
SCHEME_VEC_ELS(px->redirects)[1] = scheme_make_integer(argc);
}
app_mark = SCHEME_VEC_ELS(px->redirects)[2]; app_mark = SCHEME_VEC_ELS(px->redirects)[2];
if (SCHEME_FALSEP(app_mark)) if (SCHEME_FALSEP(app_mark))
app_mark = NULL; app_mark = NULL;
@ -3940,7 +4052,7 @@ 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)) { if (SCHEME_IMMUTABLEP(px->redirects)) {
/* commuincate `self_proc` to the next layer: */ /* commuincate `self_proc` to the next layer: */
scheme_current_thread->self_for_proc_chaperone = self_proc; scheme_current_thread->self_for_proc_chaperone = self_proc;
} }
@ -3982,7 +4094,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
if (need_pop_mark) if (need_pop_mark)
MZ_CONT_MARK_POS -= 2; MZ_CONT_MARK_POS -= 2;
if (SCHEME_CHAPERONEP(px->prev)) { if (SCHEME_IMMUTABLEP(px->redirects)) {
/* commuincate `self_proc` to the next layer: */ /* commuincate `self_proc` to the next layer: */
scheme_current_thread->self_for_proc_chaperone = self_proc; scheme_current_thread->self_for_proc_chaperone = self_proc;
} }

55
racket/src/racket/src/jit.c
View File

@ -453,8 +453,33 @@ Scheme_Object *scheme_extract_global(Scheme_Object *o, Scheme_Native_Closure *nc
return globs->a[pos]; return globs->a[pos];
} }
static Scheme_Object *extract_syntax(Scheme_Quote_Syntax *qs, Scheme_Native_Closure *nc)
{
/* GLOBAL ASSUMPTION: we assume that globals are the last thing
in the closure; grep for "GLOBAL ASSUMPTION" in fun.c. */
Scheme_Prefix *globs;
int i, pos;
Scheme_Object *v;
globs = (Scheme_Prefix *)nc->vals[nc->code->u2.orig_code->closure_size - 1];
i = qs->position;
pos = qs->midpoint;
v = globs->a[i+pos+1];
if (!v) {
v = globs->a[pos];
v = scheme_delayed_shift((Scheme_Object **)v, i);
globs->a[i+pos+1] = v;
}
return v;
}
static Scheme_Object *extract_closure_local(int pos, mz_jit_state *jitter, int get_constant) static Scheme_Object *extract_closure_local(int pos, mz_jit_state *jitter, int get_constant)
{ {
if (PAST_LIMIT()) return NULL;
if (pos >= jitter->self_pos - jitter->self_to_closure_delta) { if (pos >= jitter->self_pos - jitter->self_to_closure_delta) {
pos -= (jitter->self_pos - jitter->self_to_closure_delta); pos -= (jitter->self_pos - jitter->self_to_closure_delta);
if (pos < jitter->nc->code->u2.orig_code->closure_size) { if (pos < jitter->nc->code->u2.orig_code->closure_size) {
@ -490,6 +515,8 @@ Scheme_Object *scheme_specialize_to_constant(Scheme_Object *obj, mz_jit_state *j
{ {
Scheme_Object *c; Scheme_Object *c;
if (PAST_LIMIT()) return obj;
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) { if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) {
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)) { if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)) {
c = scheme_extract_closure_local(obj, jitter, extra_push, 1); c = scheme_extract_closure_local(obj, jitter, extra_push, 1);
@ -928,11 +955,8 @@ int scheme_needs_only_target_register(Scheme_Object *obj, int and_can_reorder)
return (t >= _scheme_compiled_values_types_); return (t >= _scheme_compiled_values_types_);
} }
static int produces_single_value(Scheme_Object *rator, int num_args, mz_jit_state *jitter) int scheme_native_closure_is_single_result(Scheme_Object *rator)
{ {
rator = scheme_specialize_to_constant(rator, jitter, num_args);
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_native_closure_type)) {
Scheme_Native_Closure *nc = (Scheme_Native_Closure *)rator; Scheme_Native_Closure *nc = (Scheme_Native_Closure *)rator;
if (nc->code->start_code == scheme_on_demand_jit_code) if (nc->code->start_code == scheme_on_demand_jit_code)
return (SCHEME_CLOSURE_DATA_FLAGS(nc->code->u2.orig_code) & CLOS_SINGLE_RESULT); return (SCHEME_CLOSURE_DATA_FLAGS(nc->code->u2.orig_code) & CLOS_SINGLE_RESULT);
@ -940,6 +964,13 @@ static int produces_single_value(Scheme_Object *rator, int num_args, mz_jit_stat
return (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(nc->code) & NATIVE_IS_SINGLE_RESULT); return (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(nc->code) & NATIVE_IS_SINGLE_RESULT);
} }
static int produces_single_value(Scheme_Object *rator, int num_args, mz_jit_state *jitter)
{
rator = scheme_specialize_to_constant(rator, jitter, num_args);
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_native_closure_type))
return scheme_native_closure_is_single_result(rator);
if (SCHEME_PRIMP(rator)) { if (SCHEME_PRIMP(rator)) {
int opt; int opt;
opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
@ -3273,15 +3304,22 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
mz_rs_sync(); mz_rs_sync();
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) {
Scheme_Object *stx;
stx = extract_syntax(qs, jitter->nc);
scheme_mz_load_retained(jitter, target, stx);
CHECK_LIMIT();
} else {
jit_movi_i(JIT_R0, WORDS_TO_BYTES(c)); jit_movi_i(JIT_R0, WORDS_TO_BYTES(c));
jit_movi_i(JIT_R1, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[i + p + 1])); jit_movi_i(JIT_R1, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[i + p + 1]));
jit_movi_i(JIT_R2, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[p])); jit_movi_i(JIT_R2, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[p]));
(void)jit_calli(sjc.quote_syntax_code); (void)jit_calli(sjc.quote_syntax_code);
CHECK_LIMIT(); CHECK_LIMIT();
if (target != JIT_R0) if (target != JIT_R0)
jit_movr_p(target, JIT_R0); jit_movr_p(target, JIT_R0);
} }
}
END_JIT_DATA(10); END_JIT_DATA(10);
@ -4278,7 +4316,7 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da
Generate_Case_Dispatch_Data gdata; Generate_Case_Dispatch_Data gdata;
Scheme_Closure_Data *data; Scheme_Closure_Data *data;
Scheme_Object *o; Scheme_Object *o;
int i, cnt, num_params, has_rest; int i, cnt, num_params, has_rest, single_result = 1;
mzshort *arities; mzshort *arities;
gdata.c = c; gdata.c = c;
@ -4302,6 +4340,8 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da
has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0); has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0);
if (has_rest && num_params) if (has_rest && num_params)
--num_params; --num_params;
if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT))
single_result = 0;
if (!has_rest) if (!has_rest)
arities[i] = num_params; arities[i] = num_params;
@ -4309,6 +4349,9 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da
arities[i] = -(num_params+1); arities[i] = -(num_params+1);
} }
ndata->u.arities = arities; ndata->u.arities = arities;
if (single_result)
SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) |= NATIVE_IS_SINGLE_RESULT;
} }
/*========================================================================*/ /*========================================================================*/

55
racket/src/racket/src/jitcall.c
View File

@ -65,13 +65,24 @@ static Scheme_Object *clear_runstack(Scheme_Object **rs, intptr_t amt, Scheme_Ob
static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, GC_CAN_IGNORE jit_insn *refagain) static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, GC_CAN_IGNORE jit_insn *refagain)
{ {
GC_CAN_IGNORE jit_insn *ref2, *refz1, *refz2, *refz3, *refz4, *refz5; GC_CAN_IGNORE jit_insn *ref2, *ref3, *refz1, *refz2, *refz3, *refz4, *refz5;
GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8; GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8, *refz9, *ref9, *ref10;
ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_struct_type); ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_struct_type);
/* This is an applicable struct. But if it's for reducing arity,
then we can't just apply the struct's procedure. */
jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Structure *)0x0)->stype); jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Structure *)0x0)->stype);
jit_ldi_p(JIT_R2, &scheme_reduced_procedure_struct); jit_ldi_p(JIT_R2, &scheme_reduced_procedure_struct);
refz3 = jit_beqr_p(jit_forward(), JIT_R1, JIT_R2); ref3 = jit_bner_p(jit_forward(), JIT_R1, JIT_R2);
/* Matches reduced arity in a simple way? */
jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Structure *)0x0)->slots[1]);
refz3 = jit_bnei_p(jit_forward(), JIT_R2, scheme_make_integer(num_rands));
mz_patch_branch(ref3);
/* It's an applicable struct that is not an arity reduce or the
arity matches. We can extract the procedure if it's in a field: */
jit_ldxi_p(JIT_R1, JIT_R1, &((Scheme_Struct_Type *)0x0)->proc_attr); jit_ldxi_p(JIT_R1, JIT_R1, &((Scheme_Struct_Type *)0x0)->proc_attr);
refz1 = jit_bmci_i(jit_forward(), JIT_R1, 0x1); refz1 = jit_bmci_i(jit_forward(), JIT_R1, 0x1);
CHECK_LIMIT(); CHECK_LIMIT();
@ -81,6 +92,7 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE); jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE);
jit_addi_p(JIT_R1, JIT_R1, &((Scheme_Structure *)0x0)->slots); jit_addi_p(JIT_R1, JIT_R1, &((Scheme_Structure *)0x0)->slots);
jit_ldxr_p(JIT_R1, JIT_V1, JIT_R1); jit_ldxr_p(JIT_R1, JIT_V1, JIT_R1);
CHECK_LIMIT();
/* JIT_R1 now has the wrapped procedure */ /* JIT_R1 now has the wrapped procedure */
refz4 = jit_bmsi_i(jit_forward(), JIT_R1, 0x1); refz4 = jit_bmsi_i(jit_forward(), JIT_R1, 0x1);
@ -111,17 +123,43 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
CHECK_LIMIT(); CHECK_LIMIT();
mz_patch_branch(ref2); mz_patch_branch(ref2);
/* check for a procedure impersonator that just keeps properties */ /* check for a procedure impersonator that just keeps properties
or is the result of unsafe-{impersonate,chaperone}-procedure */
ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_chaperone_type); ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_chaperone_type);
jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Chaperone *)0x0)->redirects); jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Chaperone *)0x0)->redirects);
refz6 = mz_bnei_t(jit_forward(), JIT_R1, scheme_vector_type, JIT_R2); refz6 = mz_bnei_t(jit_forward(), JIT_R1, scheme_vector_type, JIT_R2);
(void)jit_ldxi_l(JIT_R2, JIT_R1, &SCHEME_VEC_SIZE(0x0)); (void)jit_ldxi_l(JIT_R2, JIT_R1, &SCHEME_VEC_SIZE(0x0));
refz7 = jit_bmci_i(jit_forward(), JIT_R2, 0x1); refz7 = jit_bmci_i(jit_forward(), JIT_R2, 0x1);
(void)jit_ldxi_l(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[0])); /* Flag is set for a property-only or unsafe chaperone: */
refz8 = jit_bnei_p(jit_forward(), JIT_R2, scheme_false); jit_ldxi_s(JIT_R2, JIT_V1, &SCHEME_CHAPERONE_FLAGS(((Scheme_Chaperone *)0x0)));
/* Can extract the impersonated function and use it directly */ refz8 = jit_bmci_ul(jit_forward(), JIT_R2, SCHEME_PROC_CHAPERONE_CALL_DIRECT);
jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Chaperone *)0x0)->prev); /* In the case of an unsafe chaperone, we can only make a direct
call if the arity-check will succeed, otherwise the error message
will use the wrong name. */
jit_ldxi_p(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[1]));
ref9 = jit_beqi_p(jit_forward(), JIT_R2, scheme_false);
refz9 = jit_bnei_p(jit_forward(), JIT_R2, scheme_make_integer(num_rands));
mz_patch_branch(ref9);
CHECK_LIMIT();
/* If the vector is immutable, we need to provide the self proc,
if it's not provided already. The self proc is supplied through
a side channel in the thread record. */
jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(0x0)));
ref9 = jit_bmci_i(jit_forward(), JIT_R2, 0x1);
(void)mz_tl_ldi_p(JIT_R2, tl_scheme_current_thread);
jit_ldxi_l(JIT_R1, JIT_R2, &((Scheme_Thread *)0x0)->self_for_proc_chaperone);
ref10 = jit_bnei_p(jit_forward(), JIT_R1, NULL);
jit_stxi_l(&((Scheme_Thread *)0x0)->self_for_proc_chaperone, JIT_R2, JIT_V1);
mz_patch_branch(ref10);
jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Chaperone *)0x0)->redirects);
mz_patch_branch(ref9);
/* Position [0] in SCHEME_VEC_ELS contains either the
unwrapped function (if chaperone-procedure got #f
for the proc argument) or the unsafe-chaperone
replacement-proc argument; either way, just call it */
jit_ldxi_p(JIT_V1, JIT_R1, &(SCHEME_VEC_ELS(0x0)[0]));
(void)jit_jmpi(refagain); (void)jit_jmpi(refagain);
CHECK_LIMIT();
mz_patch_branch(refz1); mz_patch_branch(refz1);
mz_patch_branch(refz2); mz_patch_branch(refz2);
@ -131,6 +169,7 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
mz_patch_branch(refz6); mz_patch_branch(refz6);
mz_patch_branch(refz7); mz_patch_branch(refz7);
mz_patch_branch(refz8); mz_patch_branch(refz8);
mz_patch_branch(refz9);
return ref2; return ref2;
} }

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

@ -14,8 +14,8 @@
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1141 #define EXPECTED_PRIM_COUNT 1142
#define EXPECTED_UNSAFE_COUNT 106 #define EXPECTED_UNSAFE_COUNT 108
#define EXPECTED_FLFXNUM_COUNT 69 #define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45 #define EXPECTED_EXTFL_COUNT 45
#define EXPECTED_FUTURES_COUNT 15 #define EXPECTED_FUTURES_COUNT 15

15
racket/src/racket/src/schnapp.inc
View File

@ -62,10 +62,17 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
if ((t == scheme_proc_chaperone_type) if ((t == scheme_proc_chaperone_type)
&& SCHEME_VECTORP(((Scheme_Chaperone *)rator)->redirects) && SCHEME_VECTORP(((Scheme_Chaperone *)rator)->redirects)
&& (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1)) { && (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1)
if (SCHEME_FALSEP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0])) { && (SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)rator) == SCHEME_PROC_CHAPERONE_CALL_DIRECT)) {
/* No redirection proc (i.e, chaperone is just for properties) */ if (SCHEME_FALSEP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1])
rator = ((Scheme_Chaperone *)rator)->prev; || SCHEME_INT_VAL(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1]) == argc) {
/* No redirection proc, i.e, chaperone is just for
properties or produced by unsafe-chaperone-procedure result -- and in the
latter case, the arity is right. */
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
if (SCHEME_IMMUTABLEP(((Scheme_Chaperone *)rator)->redirects) && !p->self_for_proc_chaperone)
p->self_for_proc_chaperone = rator;
rator = SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0];
t = _SCHEME_TYPE(rator); t = _SCHEME_TYPE(rator);
} else } else
return scheme_apply_chaperone(rator, argc, argv, NULL, PRIM_CHECK_MULTI | (PRIM_CHECK_VALUE << 1)); return scheme_apply_chaperone(rator, argc, argv, NULL, PRIM_CHECK_MULTI | (PRIM_CHECK_VALUE << 1));

2
racket/src/racket/src/schpriv.h
View File

@ -1063,6 +1063,7 @@ typedef struct Scheme_Chaperone {
#define SCHEME_CHAPERONE_FLAGS(c) MZ_OPT_HASH_KEY(&(c)->iso) #define SCHEME_CHAPERONE_FLAGS(c) MZ_OPT_HASH_KEY(&(c)->iso)
#define SCHEME_CHAPERONE_IS_IMPERSONATOR 0x1 #define SCHEME_CHAPERONE_IS_IMPERSONATOR 0x1
#define SCHEME_PROC_CHAPERONE_CALL_DIRECT 0x2
#define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val) #define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val)
@ -3332,6 +3333,7 @@ int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected);
int scheme_decode_struct_shape(Scheme_Object *shape, intptr_t *_v); int scheme_decode_struct_shape(Scheme_Object *shape, intptr_t *_v);
int scheme_closure_preserves_marks(Scheme_Object *p); int scheme_closure_preserves_marks(Scheme_Object *p);
int scheme_native_closure_preserves_marks(Scheme_Object *p); int scheme_native_closure_preserves_marks(Scheme_Object *p);
int scheme_native_closure_is_single_result(Scheme_Object *rator);
int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which); int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which);

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "6.4.0.1" #define MZSCHEME_VERSION "6.4.0.4"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 4 #define MZSCHEME_VERSION_Y 4
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_W 4
#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)

4
racket/src/racket/src/struct.c
View File

@ -2428,9 +2428,9 @@ int scheme_is_noninterposing_chaperone(Scheme_Object *o)
if (SCHEME_VEC_SIZE(px->redirects) & 1) { if (SCHEME_VEC_SIZE(px->redirects) & 1) {
/* procedure chaperone */ /* procedure chaperone */
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0])) if (SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[1]))
return 0;
return 1; return 1;
return 0;
} }
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0])) if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))