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 version "6.4.0.1")
(define version "6.4.0.4")
(define deps `("racket-lib"
["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 order-n)]
[flags (list mode-symbol ...)]
[category (list category-symbol)
(list category-symbol sort-number)]
[category (list category-string-or-symbol)
(list category-string-or-symbol sort-number)]
[name string
#f]
]
@ -542,7 +542,10 @@ Optional @filepath{info.rkt} fields trigger additional actions by
source file need not be present. Moving documentation into place
may require no movement at all, depending on the way that the
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?)))] ---
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]
argument.}]}
@defproc[(chaperone-vector [vec vector?]
[ref-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))
]}
@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
[proc (((listof keyword?) list?) () #:rest list? . ->* . any)]
[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"]

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

@ -3,6 +3,10 @@
(load-relative "loadtest.rktl")
(Section 'chaperones)
(require (only-in racket/unsafe/ops
unsafe-impersonate-procedure
unsafe-chaperone-procedure))
;; ----------------------------------------
(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 ()
(struct s ([a #:mutable]))
(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)

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?)
;; 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 () () 1) 1) #rx".*expected number of values not received.*")
(err/rt-test (begin (for/fold ([x 1]) () (values 1 2)) 1) #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 () ([i (in-range 10)]) 1) 1)
exn:fail:contract:arity?
#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))
;; 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 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 ----------
(let ()
(test 'foo identity 'foo)

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

@ -5111,6 +5111,15 @@
(set! f f)
(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?)
(syntax
(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)
(syntax
(err/rt-test e exn:application:type?))])))

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

@ -736,12 +736,12 @@
(failure-cont)
0)]
[_ 1]))
(comp 0
(match (cons 1 2)
[(cons a b) #:when (= a b) 1]
[_ 0]))
(comp 1
(match (cons 1 1)
[(cons a b) #:when (= a b) 1]
@ -772,7 +772,7 @@
[`(,(? L4e?) ...) #t]
[(? L3v?) #t]
[_ #f]))
(define (is-biop? sym) (or (is-aop? sym) (is-cmp? sym)))
(define (is-aop? sym) (memq sym '(+ - *)))
(define (is-cmp? sym) (memq sym '(< <= =)))
@ -794,7 +794,7 @@
(apply max (hash-values ht)))))
(check-true (car v))
(check < (cadr v) 50))
(test-case "syntax-local-match-introduce"
(define-match-expander foo
(lambda (stx) (syntax-local-match-introduce #'x)))
@ -809,5 +809,22 @@
[(and x (? (λ _ (set-box! b #f))) (app unbox #f)) 'yes]
[_ 'no])
'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

@ -487,5 +487,23 @@
'dynamic->*8
'((contract (dynamic->* #:range-contracts #f) (λ () 1) 'pos 'neg))
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))
(test/spec-passed
'provide/contract1
'contract-marks1
'((contract (-> neg-blame? any/c) (λ (x) x) 'pos 'neg) 1))
(test/spec-passed
'provide/contract2
'contract-marks2
'((contract (-> any/c pos-blame?) (λ (x) x) 'pos 'neg) 1))
(test/spec-passed
'provide/contract3
'contract-marks3
'(contract (vector/c pos-blame?) (vector 1) 'pos 'neg))
(test/spec-passed
'provide/contract4
'contract-marks4
'((contract (parameter/c pos-blame?) (make-parameter #f) 'pos 'neg)))
(test/spec-passed
'provide/contract5
'contract-marks5
'(contract (unconstrained-domain-> pos-blame?) (λ () 1) 'pos 'neg))
(test/spec-passed
'provide/contract6
'contract-marks6
'(contract (->* () #:pre neg-blame? any) (λ () 1) 'pos 'neg))
(test/spec-passed
'provide/contract7
'contract-marks7
'(contract (->* () any/c #:post pos-blame?) (λ () 1) 'pos 'neg))
(test/spec-passed/result
'provide/contract8
'contract-marks8
'(let ()
(eval '(module prof1 racket/base
(require racket/contract 'prof-fun)
@ -85,7 +85,7 @@
11)
(test/spec-passed/result
'provide/contract9
'contract-marks9
'(let ()
(eval '(module prof2 racket/base
(require racket/contract 'prof-fun)
@ -98,7 +98,7 @@
11)
(test/spec-passed/result
'provide/contract10
'contract-marks10
'(let ()
(eval '(module prof3 racket/base
(require racket/contract 'prof-fun)
@ -111,21 +111,21 @@
11)
(test/spec-passed
'provide/contract11
'contract-marks11
'(let ()
(struct posn (x y))
((contract (-> (struct/dc posn [x neg-blame?]) any/c) (λ (x) x) 'pos 'neg)
(posn 1 2))))
(test/spec-passed
'provide/contract12
'contract-marks12
'(let ()
(struct posn (x y))
((contract (-> any/c (struct/dc posn [x pos-blame?])) (λ (x) x) 'pos 'neg)
(posn 1 2))))
(test/spec-passed
'provide/contract13
'contract-marks13
'(let ()
(struct posn (x y))
((contract (-> any/c (struct/dc posn [x pos-blame?] #:inv (x) pos-blame?))
@ -133,7 +133,7 @@
(posn 1 2))))
(test/spec-passed
'provide/contract14
'contract-marks14
'(let ()
(struct posn (x y) #:mutable)
((contract (-> any/c (struct/dc posn [x pos-blame?]))
@ -141,7 +141,7 @@
(posn 1 2))))
(test/spec-passed
'provide/contract15
'contract-marks15
'(let ()
(struct posn (x y))
((contract (-> any/c (struct/dc posn [x #:lazy pos-blame?]))
@ -149,7 +149,7 @@
(posn 1 2))))
(test/spec-passed
'provide/contract16
'contract-marks16
'(let ()
(struct posn (x y))
((contract (-> any/c (struct/dc posn
@ -159,7 +159,7 @@
(posn 1 2))))
(test/spec-passed
'provide/contract17
'contract-marks17
'(let ()
(struct posn (x y))
((contract (-> any/c (struct/dc posn
@ -169,7 +169,7 @@
(posn 1 2))))
(test/spec-passed
'provide/contract18
'contract-marks18
'(let ()
(struct posn (x y) #:mutable)
((contract (-> any/c (struct/dc posn
@ -179,7 +179,7 @@
(posn 1 2))))
(test/spec-passed
'provide/contract19
'contract-marks19
'(let ()
(struct posn (x y))
((contract (-> any/c (struct/dc posn
@ -189,7 +189,7 @@
(posn 1 2))))
(test/spec-passed
'provide/contract20
'contract-marks20
'(let ()
(struct posn (x y) #:mutable)
((contract (-> any/c (struct/dc posn
@ -199,15 +199,444 @@
(posn 1 2))))
(test/spec-passed
'provide/contract21
'contract-marks21
'(let ()
((contract (case-> (-> any/c any/c pos-blame?))
(λ (x y) x) 'pos 'neg)
1 2)))
(test/spec-passed
'provide/contract22
'contract-marks22
'(let ()
((contract (case-> (-> neg-blame? any/c))
(λ (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

@ -21,6 +21,17 @@
'neg)])
(f 3))
(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
tail-unconstrained-domain-arrow

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
Bug repairs and other changes noted in the documentation,
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 neg-elem-proj (lnp (blame-swap blame)))
(λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(check-async-channel/c ctc val blame neg-party)
(impersonate/chaperone-async-channel val
(λ (v) (pos-elem-proj v neg-party))
(λ (v) (neg-elem-proj v neg-party))
(λ (v)
(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:blame blame))))

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

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

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

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

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

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

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

@ -52,7 +52,7 @@
(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)
(raise-argument-error 'check-tail-contract
"identifier?"
@ -61,7 +61,7 @@
#`(call-with-immediate-continuation-mark
tail-contract-key
(λ (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 rng-checkers)))))
@ -69,25 +69,28 @@
;; rng-ctc : (or/c #f (listof ctc))
;; blame-party-info : (list/c pos-party boolean?[blame-swapped?])
;; neg-party : neg-party
(define (tail-marks-match? m rng-ctcs blame-party-info neg-party)
(and m
rng-ctcs
(eq? (car m) neg-party)
(let ([mark-blame-part-info (cadr m)])
(and (eq? (car mark-blame-part-info) (car blame-party-info))
(eq? (cadr mark-blame-part-info) (cadr blame-party-info))))
(let loop ([m (cddr m)]
[rng-ctcs rng-ctcs])
(cond
[(null? m) (null? rng-ctcs)]
[(null? rng-ctcs) (null? m)]
[else
(define m1 (car m))
(define rng-ctc1 (car rng-ctcs))
(cond
[(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
[(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
[else #f])]))))
;; 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
rng-ctcs
(eq? (car m) neg-party)
(let ([mark-blame-part-info (cadr m)])
(and (eq? (car mark-blame-part-info) (car blame-party-info))
(eq? (cadr mark-blame-part-info) (cadr blame-party-info))))
(let loop ([m (cddr m)]
[rng-ctcs rng-ctcs])
(cond
[(null? m) (null? rng-ctcs)]
[(null? rng-ctcs) (null? m)]
[else
(define m1 (car m))
(define rng-ctc1 (car rng-ctcs))
(cond
[(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
[(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
[else #f])])))))
;; used as part of the information in the continuation mark
;; that records what is to be checked for a pending contract
@ -115,27 +118,30 @@
(λ (val neg-party)
(check-is-a-procedure orig-blame neg-party val)
(define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...))
(define blame+neg-party (cons orig-blame neg-party))
(wrapper
val
(make-keyword-procedure
(λ (kwds kwd-vals . args)
(with-contract-continuation-mark
(cons orig-blame neg-party)
blame+neg-party
#,(check-tail-contract
#'rngs-list
#'blame-party-info
#'neg-party
(list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args)))))
(λ (s) #`(apply values #,@s kwd-vals args))
#'blame+neg-party)))
(λ args
(with-contract-continuation-mark
(cons orig-blame neg-party)
blame+neg-party
#,(check-tail-contract
#'rngs-list
#'blame-party-info
#'neg-party
(list #'res-checker)
(λ (s) #`(apply values #,@s args))))))
(λ (s) #`(apply values #,@s args))
#'blame+neg-party))))
impersonator-prop:contracted ctc
impersonator-prop:application-mark
(cons tail-contract-key (list neg-party blame-party-info rngs-x ...))))))))
@ -346,7 +352,8 @@
blame-party-info
#'neg-party
#'(rng-checker-name ...)
inner-stx-gen)))]
inner-stx-gen
#'(cons blame neg-party))))]
[kwd-return
(let* ([inner-stx-gen
(if need-apply-values?
@ -370,7 +377,8 @@
blame-party-info
#'neg-party
#'(rng-checker-name ...)
outer-stx-gen))))])
outer-stx-gen
#'(cons blame neg-party)))))])
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
[basic-lambda #'(λ basic-params
;; Arrow contract domain checking is instrumented
@ -398,7 +406,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda])
(arity-checking-wrapper val blame neg-party
basic-lambda-name
basic-lambda-name #f #f #f
void
#,min-method-arity
#,max-method-arity
@ -410,7 +418,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party
void
void #f #f #f
kwd-lambda-name
#,min-method-arity
#,max-method-arity
@ -423,7 +431,7 @@
(let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party
basic-lambda-name
basic-lambda-name #f #f #f
kwd-lambda-name
#,min-method-arity
#,max-method-arity
@ -433,15 +441,34 @@
'(opt-kwd ...))))])))))))))))
;; 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
req-kwd opt-kwd)
;; should not build this unless we are in the 'else' case (and maybe not at all)
(cond
[(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
(if (and (null? req-kwd) (null? opt-kwd))
basic-lambda
kwd-lambda)]
(if (and (null? req-kwd) (null? opt-kwd))
(cond
[(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
(define-values (vr va) (procedure-keywords val))
(define all-kwds (append req-kwd opt-kwd))
@ -493,9 +520,13 @@
(raise-blame-error (blame-swap blame) #:missing-party neg-party val
"expected required keyword ~a"
(car req-kwd)))))
(if (or (not va) (pair? vr) (pair? va))
(make-keyword-procedure kwd-checker basic-checker-name)
basic-checker-name)]))
(define proc
(if (or (not va) (pair? vr) (pair? va))
(make-keyword-procedure kwd-checker basic-checker-name)
basic-checker-name))
(if basic-unsafe-lambda
(values proc #f)
proc)]))
(define (raise-wrong-number-of-args-error
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)
#t))
(cond
[clnp ((clnp blame) v neg)]
[else (((contract-projection c) blame) v)])))
[clnp (with-contract-continuation-mark
(cons blame neg)
((clnp blame) v neg))]
[else (with-contract-continuation-mark
blame
(((contract-projection c) blame) v))])))
(define-syntax (invariant-assertion 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 neg-elem-w-proj (w-vfp (blame-swap box-blame)))
(λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(cond
[(check-box/c-np ctc val blame)
=>
@ -150,8 +151,14 @@
(box-immutable (pos-elem-r-proj (unbox val) neg-party))
(chaperone/impersonate-box
val
(λ (b v) (pos-elem-r-proj v neg-party))
(λ (b v) (neg-elem-w-proj v neg-party))
(λ (b v)
(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: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)
#`(apply values #,@rng-checks this-parameter ...
(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
#'rng-ctcs-x blame-party-info neg-party rng-checkers
(λ (rng-checks)
#`(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
#`(apply values this-parameter ...
(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
(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
;; ;; When debugging a missing blame party error, turn this on, then run
;; ;; the contract test suite. It should find the problematic combinator.
;; (unless (or (pair? payload) (not (blame-missing-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 ...))))

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

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

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

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

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

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

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

@ -152,14 +152,16 @@
;; expressions:
(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
prop:set!-transformer
(λ (self stx)
(let ([partially-applied-id (provide/contract-transformer-partially-applied-id self)]
[saved-id-table (provide/contract-transformer-saved-id-table self)]
[rename-id (provide/contract-info-rename-id self)])
(with-syntax ([partially-applied-id partially-applied-id])
[rename-id (provide/contract-info-rename-id self)]
[blame (provide/contract-transformer-blame self)])
(with-syntax ([partially-applied-id partially-applied-id]
[blame blame])
(if (eq? 'expression (syntax-local-context))
;; In an expression context:
(let* ([key (syntax-local-lift-context)]
@ -171,7 +173,9 @@
(syntax-local-introduce
(syntax-local-lift-expression
(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))
(define (adjust-location new-stx)
(datum->syntax new-stx (syntax-e new-stx) stx new-stx))
@ -195,13 +199,14 @@
;; expressions:
(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
(provide/contract-transformer rename-id cid id (make-hasheq) pid)
(provide/contract-transformer rename-id cid id (make-hasheq) pid blame)
(begin
;; TODO: this needs to change!
;; syntax/parse uses this
;; this will just drop contracts for now.
;; VS: is this still the case? this function is not exported anymore
(λ (stx)
(syntax-case stx ()
[(_ args ...)
@ -286,12 +291,12 @@
[(->i . _) (values #t (->i-valid-app-shapes ctrct))]
[_ (values #f #f)]))
(with-syntax ([id id]
[(partially-applied-id extra-neg-party-argument-fn contract-id)
(generate-temporaries (list 'idX 'idY 'idZ))]
[(partially-applied-id extra-neg-party-argument-fn contract-id blame-id)
(generate-temporaries (list 'idX 'idY 'idZ 'idB))]
[ctrct ctrct])
(syntax-local-lift-module-end-declaration
#`(begin
(define partially-applied-id
(define-values (partially-applied-id blame-id)
(do-partial-app contract-id
id
'#,name-for-blame
@ -322,7 +327,8 @@
(quote-syntax #,id-rename)
(quote-syntax contract-id) (quote-syntax id)
#f #f
(quote-syntax partially-applied-id)))))))
(quote-syntax partially-applied-id)
(quote-syntax blame-id)))))))
(define-syntax (define-module-boundary-contract stx)
(cond
@ -375,7 +381,7 @@
'define-module-boundary-contract
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 p (parameterize ([warn-about-val-first? #f])
;; when we're building the val-first projection
@ -388,14 +394,19 @@
(λ () (contract-name ctc))
pos-module-source
#f #t))
(define neg-accepter ((p blme) val))
;; we don't have the negative blame here, but we
;; expect only positive failures from this; do the
;; check and then toss the results.
(neg-accepter 'incomplete-blame-from-provide.rkt)
neg-accepter)
(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))
;; 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
;; expect only positive failures from this; do the
;; check and then toss the results.
(neg-accepter 'incomplete-blame-from-provide.rkt)
(values neg-accepter blme)))
(define-for-syntax (true-provide/contract provide-stx just-check-errors? who)
(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 sel (and (subcontract? subcontract) (subcontract-ref subcontract)))
(define blame (car blames))
(define blame+neg-party (cons blame neg-party))
(define mut-blame (car mut-blames))
(define indy-blame (car indy-blames))
(define mut-indy-blame (car mut-indy-blames))
@ -344,7 +345,7 @@
(cond
[(invariant? subcontract)
(unless (with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(apply (invariant-dep-proc subcontract) dep-args))
(raise-invariant-blame-failure blame neg-party v
(reverse dep-args)
@ -352,7 +353,7 @@
(values chaperone-args impersonate-args)]
[(immutable? subcontract)
(define (chk fld v) (with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(proj v neg-party)))
(chk #f (sel v)) ;; check the field contract immediately
(values (if (flat-contract? (indep-ctc subcontract))
@ -363,7 +364,7 @@
(values (list* sel
(cache-λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(proj v neg-party)))
chaperone-args)
impersonate-args)]
@ -373,23 +374,23 @@
(list* sel
(λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(proj v neg-party)))
(mutable-set subcontract)
(λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(mut-proj v neg-party)))
impersonate-args))
(values (list* sel
(λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(proj v neg-party)))
(mutable-set subcontract)
(λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(mut-proj v neg-party)))
chaperone-args)
impersonate-args))]
@ -398,7 +399,7 @@
(cond
[(dep-immutable? subcontract)
(define (chk fld v) (with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(proj v neg-party)))
(chk #f (sel v)) ;; check the field contract immediately
(values (if (flat-contract? dep-ctc)
@ -409,7 +410,7 @@
(values (list* sel
(cache-λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(proj v neg-party)))
chaperone-args)
impersonate-args)]
@ -419,12 +420,12 @@
(values (list* sel
(λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(proj v neg-party)))
(dep-mutable-set subcontract)
(λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(mut-proj v neg-party)))
chaperone-args)
impersonate-args)
@ -432,12 +433,12 @@
(list* sel
(λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(proj v neg-party)))
(dep-mutable-set subcontract)
(λ (fld v)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(mut-proj v neg-party)))
impersonate-args)))]
[(dep-on-state-immutable? subcontract)
@ -445,7 +446,7 @@
(values (list* sel
(λ (strct val)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(build-dep-on-state-proj
(base-struct/dc-subcontracts ctc) subcontract strct
orig-indy-projs orig-indy-blames blame neg-party val)))
@ -455,13 +456,13 @@
(proj (sel v) neg-party)
(define (get-chap-proc strct val)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct
orig-indy-projs orig-indy-blames blame neg-party
val)))
(define (set-chap-proc strct val)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(build-dep-on-state-proj
(base-struct/dc-subcontracts ctc) subcontract strct
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
'(expected "struct-type-property" given: "~e")
x))
(define blame+neg-party (cons blame neg-party))
(define-values (nprop _pred _acc)
(make-struct-type-property
(wrap-name x)
(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))))
nprop)))

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

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

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

@ -11,13 +11,30 @@
#:property prop:set!-transformer
(λ (me stx)
(define xf (match-expander-macro-xform me))
(if (set!-transformer? xf)
((set!-transformer-procedure xf) stx)
(syntax-case stx (set!)
[(set! . _)
(raise-syntax-error #f "cannot mutate syntax identifier" stx)]
[_ (xf stx)])))
#:property prop:match-expander (struct-field-index match-xform)
(define proc
(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!)
[(set! . _)
(raise-syntax-error #f "cannot mutate syntax identifier" 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:legacy-match-expander (struct-field-index legacy-xform))
(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 p-pos (prj (blame-add-field-context blame f #:swap? #f)))
(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)))

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

@ -48,10 +48,10 @@
(rename *in-port in-port)
(rename *in-lines in-lines)
(rename *in-bytes-lines in-bytes-lines)
in-hash
in-hash-keys
in-hash-values
in-hash-pairs
(rename *in-hash in-hash)
(rename *in-hash-keys in-hash-keys)
(rename *in-hash-values in-hash-values)
(rename *in-hash-pairs in-hash-pairs)
in-directory
in-sequences
@ -664,12 +664,93 @@
(values (hash-iterate-key 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)
(unless (hash? ht) (raise-argument-error 'in-hash-keys "hash?" ht))
(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)
(unless (hash? ht) (raise-argument-error 'in-hash-values "hash?" ht))
(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)
(unless (hash? ht) (raise-argument-error 'in-hash-values "hash?" ht))
(make-do-sequence (lambda ()
@ -677,6 +758,33 @@
(cons (hash-iterate-key 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)
(values (lambda (pos) (sel 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"
"small-scheme.rkt"
"more-scheme.rkt"
(only '#%unsafe
unsafe-chaperone-procedure
unsafe-impersonate-procedure)
(for-syntax '#%kernel
'#%unsafe
"procedure-alias.rkt"
"stx.rkt"
"small-scheme.rkt"
@ -26,7 +30,9 @@
new:procedure->method
new:procedure-rename
new:chaperone-procedure
(protect new:unsafe-chaperone-procedure)
new:impersonate-procedure
(protect new:unsafe-impersonate-procedure)
new:chaperone-procedure*
new:impersonate-procedure*
(for-syntax kw-expander? kw-expander-impl kw-expander-proc
@ -634,7 +640,7 @@
(let ([#,core-id #,impl])
(let ([#,unpack-id #,kwimpl])
#,wrap))))))
#`(#%expression #,stx)))])
(quasisyntax/loc stx (#%expression #,stx))))])
(values new-lambda new-lambda)))
(define (missing-kw proc . args)
@ -1529,12 +1535,24 @@
(do-chaperone-procedure #f #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
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
(let ([impersonate-procedure
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #t #f impersonate-procedure 'impersonate-procedure proc wrap-proc props))])
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*
(let ([chaperone-procedure*
(lambda (proc wrap-proc . props)
@ -1553,52 +1571,10 @@
(if (or (not (keyword-procedure? n-proc))
(not (procedure? wrap-proc))
;; if any bad prop, let `chaperone-procedure' complain
(let loop ([props props])
(cond
[(null? props) #f]
[(impersonator-property? (car props))
(let ([props (cdr props)])
(or (null? props)
(loop (cdr props))))]
[else #t])))
(bad-props? props))
(apply chaperone-procedure 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))
(begin
(chaperone-arity-match-checking self-arg? name proc wrap-proc props)
(let*-values ([(kw-chaperone)
(let ([p (keyword-procedure-proc n-wrap-proc)])
;; `extra-arg ...` will be `self-proc` if `self-arg?`:
@ -1759,6 +1735,68 @@
chap-accessor #f
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)
;; If `proc' gets keyword support through `new-prop:procedure',
;; then wrap it to normalize to to something that matches

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

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

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

@ -198,6 +198,7 @@
(λ (val neg-party)
(set-contract-check cmp kind blame neg-party val)
(define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
(define blame+neg-party (cons blame neg-party))
(cond
[(set? val)
(chaperone-hash-set
@ -205,31 +206,44 @@
(λ (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 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:blame (cons blame neg-party))]
[else
(chaperone-hash-set
val
(λ (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) (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 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:blame (cons blame neg-party))]))]
[else
(λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(set-contract-check cmp kind blame neg-party val)
(cond
[(set? val)
(chaperone-hash-set
(for/fold ([s (set-clear 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
impersonator-prop:contracted ctc
impersonator-prop:blame (cons blame neg-party))]
@ -240,11 +254,17 @@
(chaperone-hash-set
val
(λ (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) (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 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:blame (cons blame neg-party))]))])))

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

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

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

@ -1,14 +1,19 @@
#lang racket/base
(require '#%unsafe
'#%flfxnum
'#%extfl)
'#%extfl
"../private/kw.rkt")
(provide (except-out (all-from-out '#%unsafe)
unsafe-undefined
check-not-unsafe-undefined
check-not-unsafe-undefined/assign
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-
(combine-out flsin flcos fltan
flasin flacos flatan

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

@ -130,20 +130,35 @@
(define pos-rng-proj (id-table/c-rng-pos-proj ctc blame))
(define neg-rng-proj (id-table/c-rng-neg-proj ctc blame))
(lambda (tbl neg-party)
(define blame+neg-party (cons blame neg-party))
(check-id-table/c ctc tbl blame neg-party)
;;TODO for immutable hash tables optimize this chaperone to a flat
;;check if possible
(if (immutable-idtbl? tbl)
(chaperone-immutable-id-table tbl
(λ (val) (pos-dom-proj val neg-party))
(λ (val) (pos-rng-proj val neg-party))
impersonator-prop:contracted ctc)
(chaperone-mutable-id-table tbl
(λ (val) (neg-dom-proj val neg-party))
(λ (val) (pos-dom-proj val neg-party))
(λ (val) (neg-rng-proj val neg-party))
(λ (val) (pos-rng-proj val neg-party))
impersonator-prop:contracted ctc)))))
(chaperone-immutable-id-table
tbl
(λ (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)
(chaperone-mutable-id-table
tbl
(λ (val) (with-contract-continuation-mark
blame+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)))))
(struct flat-id-table/c base-id-table/c ()
#:omit-define-syntaxes

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

File diff suppressed because it is too large Load Diff

200
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_specialize(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 *unsafe_impersonate_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_closure_p(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[]);
Scheme_Object *scheme_values(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),
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_register_parameter(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);
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
@ -2873,13 +2893,61 @@ static Scheme_Object *primitive_result_arity(int argc, Scheme_Object *argv[])
return scheme_make_arity(p->minr, p->maxr);
}
} else {
scheme_wrong_contract("primitive-result_arity", "primitive?", 0, argc, argv);
scheme_wrong_contract("primitive-result-arity", "primitive?", 0, argc, argv);
return NULL;
}
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 *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,
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_Hash_Tree *props;
@ -3476,8 +3544,13 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
if (!SCHEME_PROCP(val))
scheme_wrong_contract(name, "procedure?", 0, argc, argv);
if (!SCHEME_FALSEP(argv[1]) && !SCHEME_PROCP(argv[1]))
scheme_wrong_contract(name, "(or/c procedure? #f)", 1, 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]))
scheme_wrong_contract(name, "(or/c procedure? #f)", 1, argc, argv);
}
orig = get_or_check_arity(val, -1, NULL, 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;
/* Put the procedure along with known-good arity (to speed checking;
initialized to -1) in a vector. An odd-sized vector makes the
chaperone recognized as a procedure chaperone, and a size of 5
(instead of 3) indicates that the wrapper procedure accepts a
"self" argument: */
initialized to -1) in a vector.
Vector of odd size for redirects means a procedure chaperone,
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));
SCHEME_VEC_ELS(r)[0] = argv[1];
if (SCHEME_FALSEP(argv[1]))
SCHEME_VEC_ELS(r)[0] = argv[0];
else
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;
/* Vector of odd size for redirects means a procedure chaperone,
vector with even slots means a structure chaperone. */
px->redirects = r;
if (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;
}
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[])
{
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[])
{
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[])
{
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)
@ -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 */
{
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 need_pop_mark;
Scheme_Cont_Frame_Data cframe;
@ -3767,9 +3877,28 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
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 */
if (SCHEME_CHAPERONEP(px->prev)) {
if (SCHEME_IMMUTABLEP(px->redirects)) {
/* communicate `self_proc` to the next layer: */
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 */
MZ_CONT_MARK_POS -= 2;
if (checks & 0x1) {
v = _scheme_apply(px->prev, argc, argv);
} else if (SAME_TYPE(SCHEME_TYPE(px->prev), scheme_native_closure_type)) {
v = _apply_native(px->prev, argc, argv);
v = _scheme_apply(simple_call, argc, argv);
} else if (SAME_TYPE(SCHEME_TYPE(simple_call), scheme_native_closure_type)) {
v = _apply_native(simple_call, argc, argv);
} else {
v = _scheme_apply_multi(px->prev, argc, argv);
v = _scheme_apply_multi(simple_call, argc, argv);
}
MZ_CONT_MARK_POS += 2;
return v;
} else
return _scheme_tail_apply(px->prev, argc, argv);
return _scheme_tail_apply(simple_call, argc, argv);
}
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];
if (SCHEME_FALSEP(app_mark))
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: */
if (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: */
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)
MZ_CONT_MARK_POS -= 2;
if (SCHEME_CHAPERONEP(px->prev)) {
if (SCHEME_IMMUTABLEP(px->redirects)) {
/* commuincate `self_proc` to the next layer: */
scheme_current_thread->self_for_proc_chaperone = self_proc;
}

73
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];
}
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)
{
if (PAST_LIMIT()) return NULL;
if (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) {
@ -490,6 +515,8 @@ Scheme_Object *scheme_specialize_to_constant(Scheme_Object *obj, mz_jit_state *j
{
Scheme_Object *c;
if (PAST_LIMIT()) return obj;
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) {
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)) {
c = scheme_extract_closure_local(obj, jitter, extra_push, 1);
@ -928,17 +955,21 @@ int scheme_needs_only_target_register(Scheme_Object *obj, int and_can_reorder)
return (t >= _scheme_compiled_values_types_);
}
int scheme_native_closure_is_single_result(Scheme_Object *rator)
{
Scheme_Native_Closure *nc = (Scheme_Native_Closure *)rator;
if (nc->code->start_code == scheme_on_demand_jit_code)
return (SCHEME_CLOSURE_DATA_FLAGS(nc->code->u2.orig_code) & CLOS_SINGLE_RESULT);
else
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)) {
Scheme_Native_Closure *nc = (Scheme_Native_Closure *)rator;
if (nc->code->start_code == scheme_on_demand_jit_code)
return (SCHEME_CLOSURE_DATA_FLAGS(nc->code->u2.orig_code) & CLOS_SINGLE_RESULT);
else
return (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(nc->code) & NATIVE_IS_SINGLE_RESULT);
}
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_native_closure_type))
return scheme_native_closure_is_single_result(rator);
if (SCHEME_PRIMP(rator)) {
int opt;
@ -3273,14 +3304,21 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
mz_rs_sync();
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_R2, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[p]));
(void)jit_calli(sjc.quote_syntax_code);
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_R1, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[i + p + 1]));
jit_movi_i(JIT_R2, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[p]));
(void)jit_calli(sjc.quote_syntax_code);
CHECK_LIMIT();
CHECK_LIMIT();
if (target != JIT_R0)
jit_movr_p(target, JIT_R0);
if (target != JIT_R0)
jit_movr_p(target, JIT_R0);
}
}
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;
Scheme_Closure_Data *data;
Scheme_Object *o;
int i, cnt, num_params, has_rest;
int i, cnt, num_params, has_rest, single_result = 1;
mzshort *arities;
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);
if (has_rest && num_params)
--num_params;
if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT))
single_result = 0;
if (!has_rest)
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);
}
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)
{
GC_CAN_IGNORE jit_insn *ref2, *refz1, *refz2, *refz3, *refz4, *refz5;
GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8;
GC_CAN_IGNORE jit_insn *ref2, *ref3, *refz1, *refz2, *refz3, *refz4, *refz5;
GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8, *refz9, *ref9, *ref10;
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_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);
refz1 = jit_bmci_i(jit_forward(), JIT_R1, 0x1);
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_addi_p(JIT_R1, JIT_R1, &((Scheme_Structure *)0x0)->slots);
jit_ldxr_p(JIT_R1, JIT_V1, JIT_R1);
CHECK_LIMIT();
/* JIT_R1 now has the wrapped procedure */
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();
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);
jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Chaperone *)0x0)->redirects);
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));
refz7 = jit_bmci_i(jit_forward(), JIT_R2, 0x1);
(void)jit_ldxi_l(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[0]));
refz8 = jit_bnei_p(jit_forward(), JIT_R2, scheme_false);
/* Can extract the impersonated function and use it directly */
jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Chaperone *)0x0)->prev);
/* Flag is set for a property-only or unsafe chaperone: */
jit_ldxi_s(JIT_R2, JIT_V1, &SCHEME_CHAPERONE_FLAGS(((Scheme_Chaperone *)0x0)));
refz8 = jit_bmci_ul(jit_forward(), JIT_R2, SCHEME_PROC_CHAPERONE_CALL_DIRECT);
/* 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);
CHECK_LIMIT();
mz_patch_branch(refz1);
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(refz7);
mz_patch_branch(refz8);
mz_patch_branch(refz9);
return ref2;
}

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

@ -14,8 +14,8 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1141
#define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_PRIM_COUNT 1142
#define EXPECTED_UNSAFE_COUNT 108
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45
#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)
&& SCHEME_VECTORP(((Scheme_Chaperone *)rator)->redirects)
&& (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1)) {
if (SCHEME_FALSEP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0])) {
/* No redirection proc (i.e, chaperone is just for properties) */
rator = ((Scheme_Chaperone *)rator)->prev;
&& (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1)
&& (SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)rator) == SCHEME_PROC_CHAPERONE_CALL_DIRECT)) {
if (SCHEME_FALSEP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1])
|| 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);
} else
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_IS_IMPERSONATOR 0x1
#define SCHEME_PROC_CHAPERONE_CALL_DIRECT 0x2
#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_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);

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

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

6
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) {
/* procedure chaperone */
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))
return 0;
return 1;
if (SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[1]))
return 1;
return 0;
}
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))