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

v5.0.99.2: proxy' -> impersonator'

Browse Source
This commit is contained in:
Matthew Flatt 2010-11-08 06:23:16 -07:00
parent 81488335cd
commit 7f67b6569c
33 changed files with 1479 additions and 1476 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mzlib/private/contract-arrow.rkt
View File

@ -50,7 +50,7 @@
(apply values res-checker kwd-vals args)) (apply values res-checker kwd-vals args))
(λ args (λ args
(apply values res-checker args))) (apply values res-checker args)))
proxy-prop:contracted ctc) impersonator-prop:contracted ctc)
(raise-blame-error blame val "expected a procedure")))))) (raise-blame-error blame val "expected a procedure"))))))
(define ctc (define ctc
(if (and (chaperone-contract? rngs-x) ...) (if (and (chaperone-contract? rngs-x) ...)
@ -60,7 +60,7 @@
#:first-order procedure?) #:first-order procedure?)
(make-contract (make-contract
#:name name #:name name
#:projection (proj proxy-procedure) #:projection (proj impersonate-procedure)
#:first-order procedure?))) #:first-order procedure?)))
ctc)))])) ctc)))]))

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

@ -97,8 +97,8 @@ v4 todo:
#'(p-app-x ...) #'(p-app-x ...)
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s args))))) (λ (s) #`(apply values #,@s args)))))
proxy-prop:contracted ctc impersonator-prop:contracted ctc
proxy-prop:application-mark (cons contract-key (list p-app-x ...))))))) impersonator-prop:application-mark (cons contract-key (list p-app-x ...)))))))
(define ctc (define ctc
(if (and (chaperone-contract? rngs-x) ...) (if (and (chaperone-contract? rngs-x) ...)
(make-chaperone-contract (make-chaperone-contract
@ -107,7 +107,7 @@ v4 todo:
#:first-order procedure?) #:first-order procedure?)
(make-contract (make-contract
#:name name #:name name
#:projection (projection proxy-procedure) #:projection (projection impersonate-procedure)
#:first-order procedure?))) #:first-order procedure?)))
ctc)))])) ctc)))]))
@ -440,10 +440,10 @@ v4 todo:
#:first-order ->-first-order #:first-order ->-first-order
#:stronger ->-stronger?)) #:stronger ->-stronger?))
(define-struct (proxy-> base->) () (define-struct (impersonator-> base->) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection (->-proj proxy-procedure) #:projection (->-proj impersonate-procedure)
#:name ->-name #:name ->-name
#:first-order ->-first-order #:first-order ->-first-order
#:stronger ->-stronger?)) #:stronger ->-stronger?))
@ -470,9 +470,9 @@ v4 todo:
(make-chaperone-> pre post doms/c opt-doms/c rest/c (make-chaperone-> pre post doms/c opt-doms/c rest/c
kwds/c mandatory-kwds opt-kwds/c optional-kwds kwds/c mandatory-kwds opt-kwds/c optional-kwds
rngs/c rng-any? func) rngs/c rng-any? func)
(make-proxy-> pre post doms/c opt-doms/c rest/c (make-impersonator-> pre post doms/c opt-doms/c rest/c
kwds/c mandatory-kwds opt-kwds/c optional-kwds kwds/c mandatory-kwds opt-kwds/c optional-kwds
rngs/c rng-any? func))))) rngs/c rng-any? func)))))
(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs pre post) (define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs pre post)
(cond (cond
@ -605,8 +605,8 @@ v4 todo:
(syntax->list #'(kwd-names ...))) (syntax->list #'(kwd-names ...)))
null null
(if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))) (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...))))
proxy-prop:contracted ctc impersonator-prop:contracted ctc
proxy-prop:application-mark (cons contract-key (list rng-names ...)))))]) impersonator-prop:application-mark (cons contract-key (list rng-names ...)))))])
(syntax-property (syntax-property
(syntax (syntax
(build--> '-> (build--> '->
@ -930,8 +930,8 @@ v4 todo:
(map list (syntax->list #'(optional-dom-kwd ...)) (map list (syntax->list #'(optional-dom-kwd ...))
(syntax->list #'(optional-dom-kwd-proj ...))) (syntax->list #'(optional-dom-kwd-proj ...)))
(if rng-ctc (syntax->list #'(rng-proj ...)) #f)) (if rng-ctc (syntax->list #'(rng-proj ...)) #f))
proxy-prop:contracted ctc impersonator-prop:contracted ctc
proxy-prop:application-mark (cons contract-key (list rng-proj ...))))))))))))])) impersonator-prop:application-mark (cons contract-key (list rng-proj ...))))))))))))]))
(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx))) (define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))
@ -1313,7 +1313,7 @@ v4 todo:
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame)) [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame))
(loop (cdr args) (loop (cdr args)
(cdr non-kwd-ctcs)))]))))))) (cdr non-kwd-ctcs)))])))))))
proxy-prop:contracted ->d-stct)))))) impersonator-prop:contracted ->d-stct))))))
(define (build-values-string desc dep-pre-args) (define (build-values-string desc dep-pre-args)
(cond (cond
@ -1377,14 +1377,14 @@ v4 todo:
(append mandatory-kwds optional-kwds) (append mandatory-kwds optional-kwds)
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs)) (append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
(λ (x y) (keyword<? (car x) (car y))))]) (λ (x y) (keyword<? (car x) (car y))))])
(make-proxy-->d mtd? (make-impersonator-->d mtd?
mandatory-dom-ctcs optional-dom-ctcs mandatory-dom-ctcs optional-dom-ctcs
(map cdr kwd/ctc-pairs) (map cdr kwd/ctc-pairs)
rest-ctc pre-cond range post-cond rest-ctc pre-cond range post-cond
(map car kwd/ctc-pairs) (map car kwd/ctc-pairs)
mandatory-kwds mandatory-kwds
optional-kwds optional-kwds
name-wrapper))) name-wrapper)))
(define (->d-name ctc) (define (->d-name ctc)
(let* ([counting-id 'x] (let* ([counting-id 'x]
@ -1471,10 +1471,10 @@ v4 todo:
;; appropriately. b) might be okay, but we should think about ;; appropriately. b) might be okay, but we should think about
;; it first. At the very least, the projection function would ;; it first. At the very least, the projection function would
;; need to add checks in the appropriate places. ;; need to add checks in the appropriate places.
(define-struct (proxy-->d base-->d) () (define-struct (impersonator-->d base-->d) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection (->d-proj proxy-procedure) #:projection (->d-proj impersonate-procedure)
#:name ->d-name #:name ->d-name
#:first-order ->d-first-order #:first-order ->d-first-order
#:stronger ->d-stronger?)) #:stronger ->d-stronger?))

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

@ -81,7 +81,7 @@
(box-wrapper val (box-wrapper val
(λ (b v) (pos-elem-proj v)) (λ (b v) (pos-elem-proj v))
(λ (b v) (neg-elem-proj v)) (λ (b v) (neg-elem-proj v))
proxy-prop:contracted ctc)))))))) impersonator-prop:contracted ctc))))))))
(define-struct (chaperone-box/c base-box/c) () (define-struct (chaperone-box/c base-box/c) ()
#:property prop:chaperone-contract #:property prop:chaperone-contract
@ -90,12 +90,12 @@
#:first-order box/c-first-order #:first-order box/c-first-order
#:projection (ho-projection chaperone-box))) #:projection (ho-projection chaperone-box)))
(define-struct (proxy-box/c base-box/c) () (define-struct (impersonator-box/c base-box/c) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name box/c-name #:name box/c-name
#:first-order box/c-first-order #:first-order box/c-first-order
#:projection (ho-projection proxy-box))) #:projection (ho-projection impersonate-box)))
(define-syntax (wrap-box/c stx) (define-syntax (wrap-box/c stx)
(syntax-case stx () (syntax-case stx ()
@ -144,5 +144,5 @@
[(chaperone-contract? ctc) [(chaperone-contract? ctc)
(make-chaperone-box/c ctc immutable)] (make-chaperone-box/c ctc immutable)]
[else [else
(make-proxy-box/c ctc immutable)]))) (make-impersonator-box/c ctc immutable)])))

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

@ -44,7 +44,7 @@
contract-first-order-passes? contract-first-order-passes?
prop:contracted prop:contracted
proxy-prop:contracted impersonator-prop:contracted
has-contract? has-contract?
value-contract value-contract
@ -59,14 +59,14 @@
(define (has-contract? v) (define (has-contract? v)
(or (has-prop:contracted? v) (or (has-prop:contracted? v)
(has-proxy-prop:contracted? v))) (has-impersonator-prop:contracted? v)))
(define (value-contract v) (define (value-contract v)
(cond (cond
[(has-prop:contracted? v) [(has-prop:contracted? v)
(get-prop:contracted v)] (get-prop:contracted v)]
[(has-proxy-prop:contracted? v) [(has-impersonator-prop:contracted? v)
(get-proxy-prop:contracted v)] (get-impersonator-prop:contracted v)]
[else #f])) [else #f]))
(define-values (prop:contracted has-prop:contracted? get-prop:contracted) (define-values (prop:contracted has-prop:contracted? get-prop:contracted)
@ -80,8 +80,8 @@
(lambda (s) v))))]) (lambda (s) v))))])
(values prop pred (λ (v) ((get v) v))))) (values prop pred (λ (v) ((get v) v)))))
(define-values (proxy-prop:contracted has-proxy-prop:contracted? get-proxy-prop:contracted) (define-values (impersonator-prop:contracted has-impersonator-prop:contracted? get-impersonator-prop:contracted)
(make-proxy-property 'proxy-prop:contracted)) (make-impersonator-property 'impersonator-prop:contracted))
(define-syntax (any stx) (define-syntax (any stx)
(raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx)) (raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx))
@ -339,7 +339,7 @@
#:name and-name #:name and-name
#:first-order and-first-order #:first-order and-first-order
#:stronger and-stronger?)) #:stronger and-stronger?))
(define-struct (proxy-and/c base-and/c) () (define-struct (impersonator-and/c base-and/c) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection and-proj #:projection and-proj
@ -358,7 +358,7 @@
(λ (x) (for/and ([pred (in-list preds)]) (pred x)))))] (λ (x) (for/and ([pred (in-list preds)]) (pred x)))))]
[(andmap chaperone-contract? contracts) [(andmap chaperone-contract? contracts)
(make-chaperone-and/c contracts)] (make-chaperone-and/c contracts)]
[else (make-proxy-and/c contracts)]))) [else (make-impersonator-and/c contracts)])))
(define (get-any-projection c) any-projection) (define (get-any-projection c) any-projection)
(define (any-projection b) any-function) (define (any-projection b) any-function)

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

@ -71,7 +71,7 @@
[(chaperone-contract? rng-ctc) [(chaperone-contract? rng-ctc)
(make-chaperone-hash/c dom-ctc rng-ctc immutable)] (make-chaperone-hash/c dom-ctc rng-ctc immutable)]
[else [else
(make-proxy-hash/c dom-ctc rng-ctc immutable)]))) (make-impersonator-hash/c dom-ctc rng-ctc immutable)])))
(define (check-hash/c ctc) (define (check-hash/c ctc)
(let ([dom-ctc (base-hash/c-dom ctc)] (let ([dom-ctc (base-hash/c-dom ctc)]
@ -180,7 +180,7 @@
(neg-dom-proj k)) (neg-dom-proj k))
(λ (h k) (λ (h k)
(pos-dom-proj k)) (pos-dom-proj k))
proxy-prop:contracted ctc)))))))) impersonator-prop:contracted ctc))))))))
(define-struct (chaperone-hash/c base-hash/c) () (define-struct (chaperone-hash/c base-hash/c) ()
#:omit-define-syntaxes #:omit-define-syntaxes
@ -190,10 +190,10 @@
#:first-order hash/c-first-order #:first-order hash/c-first-order
#:projection (ho-projection chaperone-hash))) #:projection (ho-projection chaperone-hash)))
(define-struct (proxy-hash/c base-hash/c) () (define-struct (impersonator-hash/c base-hash/c) ()
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name hash/c-name #:name hash/c-name
#:first-order hash/c-first-order #:first-order hash/c-first-order
#:projection (ho-projection proxy-hash))) #:projection (ho-projection impersonate-hash)))

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

@ -119,11 +119,11 @@
[(null? (cdr ho-contracts)) [(null? (cdr ho-contracts))
(if (chaperone-contract? (car ho-contracts)) (if (chaperone-contract? (car ho-contracts))
(make-chaperone-single-or/c pred flat-contracts (car ho-contracts)) (make-chaperone-single-or/c pred flat-contracts (car ho-contracts))
(make-proxy-single-or/c pred flat-contracts (car ho-contracts)))] (make-impersonator-single-or/c pred flat-contracts (car ho-contracts)))]
[else [else
(if (andmap chaperone-contract? ho-contracts) (if (andmap chaperone-contract? ho-contracts)
(make-chaperone-multi-or/c flat-contracts ho-contracts) (make-chaperone-multi-or/c flat-contracts ho-contracts)
(make-proxy-multi-or/c flat-contracts ho-contracts))]))))])) (make-impersonator-multi-or/c flat-contracts ho-contracts))]))))]))
(define (single-or/c-projection ctc) (define (single-or/c-projection ctc)
(let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))] (let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
@ -167,7 +167,7 @@
#:first-order single-or/c-first-order #:first-order single-or/c-first-order
#:stronger single-or/c-stronger?)) #:stronger single-or/c-stronger?))
(define-struct (proxy-single-or/c single-or/c) () (define-struct (impersonator-single-or/c single-or/c) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection single-or/c-projection #:projection single-or/c-projection
@ -253,7 +253,7 @@
#:first-order multi-or/c-first-order #:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger?)) #:stronger multi-or/c-stronger?))
(define-struct (proxy-multi-or/c multi-or/c) () (define-struct (impersonator-multi-or/c multi-or/c) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection multi-or/c-proj #:projection multi-or/c-proj

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

@ -85,7 +85,7 @@
(elem-pos-proj val)) (elem-pos-proj val))
(λ (vec i val) (λ (vec i val)
(elem-neg-proj val)) (elem-neg-proj val))
proxy-prop:contracted ctc)))))))) impersonator-prop:contracted ctc))))))))
(define-struct (chaperone-vectorof base-vectorof) () (define-struct (chaperone-vectorof base-vectorof) ()
#:property prop:chaperone-contract #:property prop:chaperone-contract
@ -94,12 +94,12 @@
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:projection (vectorof-ho-projection chaperone-vector))) #:projection (vectorof-ho-projection chaperone-vector)))
(define-struct (proxy-vectorof base-vectorof) () (define-struct (impersonator-vectorof base-vectorof) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name vectorof-name #:name vectorof-name
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:projection (vectorof-ho-projection proxy-vector))) #:projection (vectorof-ho-projection impersonate-vector)))
(define-syntax (wrap-vectorof stx) (define-syntax (wrap-vectorof stx)
(syntax-case stx () (syntax-case stx ()
@ -149,7 +149,7 @@
[(chaperone-contract? ctc) [(chaperone-contract? ctc)
(make-chaperone-vectorof ctc immutable)] (make-chaperone-vectorof ctc immutable)]
[else [else
(make-proxy-vectorof ctc immutable)]))) (make-impersonator-vectorof ctc immutable)])))
(define/subexpression-pos-prop (vector-immutableof c) (define/subexpression-pos-prop (vector-immutableof c)
(vectorof c #:immutable #t)) (vectorof c #:immutable #t))
@ -239,7 +239,7 @@
((vector-ref elem-pos-projs i) val)) ((vector-ref elem-pos-projs i) val))
(λ (vec i val) (λ (vec i val)
((vector-ref elem-neg-projs i) val)) ((vector-ref elem-neg-projs i) val))
proxy-prop:contracted ctc)))))))) impersonator-prop:contracted ctc))))))))
(define-struct (chaperone-vector/c base-vector/c) () (define-struct (chaperone-vector/c base-vector/c) ()
#:property prop:chaperone-contract #:property prop:chaperone-contract
@ -248,12 +248,12 @@
#:first-order vector/c-first-order #:first-order vector/c-first-order
#:projection (vector/c-ho-projection chaperone-vector))) #:projection (vector/c-ho-projection chaperone-vector)))
(define-struct (proxy-vector/c base-vector/c) () (define-struct (impersonator-vector/c base-vector/c) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name vector/c-name #:name vector/c-name
#:first-order vector/c-first-order #:first-order vector/c-first-order
#:projection (vector/c-ho-projection proxy-vector))) #:projection (vector/c-ho-projection impersonate-vector)))
(define-syntax (wrap-vector/c stx) (define-syntax (wrap-vector/c stx)
(syntax-case stx () (syntax-case stx ()
@ -303,7 +303,7 @@
[(andmap chaperone-contract? ctcs) [(andmap chaperone-contract? ctcs)
(make-chaperone-vector/c ctcs immutable)] (make-chaperone-vector/c ctcs immutable)]
[else [else
(make-proxy-vector/c ctcs immutable)]))) (make-impersonator-vector/c ctcs immutable)])))
(define/subexpression-pos-prop (vector-immutable/c . args) (define/subexpression-pos-prop (vector-immutable/c . args)
(apply vector/c args #:immutable #t)) (apply vector/c args #:immutable #t))

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

@ -23,22 +23,22 @@
new:procedure->method new:procedure->method
new:procedure-rename new:procedure-rename
new:chaperone-procedure new:chaperone-procedure
new:proxy-procedure) new:impersonate-procedure)
;; ---------------------------------------- ;; ----------------------------------------
(define-values (prop:keyword-proxy keyword-proxy? keyword-proxy-ref) (define-values (prop:keyword-impersonator keyword-impersonator? keyword-impersonator-ref)
(make-struct-type-property 'keyword-proxy)) (make-struct-type-property 'keyword-impersonator))
(define (keyword-procedure-proxy-of v) (define (keyword-procedure-impersonator-of v)
(cond (cond
[(keyword-proxy? v) ((keyword-proxy-ref v) v)] [(keyword-impersonator? v) ((keyword-impersonator-ref v) v)]
[else #f])) [else #f]))
(define-values (struct:keyword-procedure mk-kw-proc keyword-procedure? (define-values (struct:keyword-procedure mk-kw-proc keyword-procedure?
keyword-procedure-ref keyword-procedure-set!) keyword-procedure-ref keyword-procedure-set!)
(make-struct-type 'keyword-procedure #f 4 0 #f (make-struct-type 'keyword-procedure #f 4 0 #f
(list (cons prop:checked-procedure #t) (list (cons prop:checked-procedure #t)
(cons prop:proxy-of keyword-procedure-proxy-of)) (cons prop:impersonator-of keyword-procedure-impersonator-of))
(current-inspector) (current-inspector)
#f #f
'(0 1 2 3))) '(0 1 2 3)))
@ -131,13 +131,13 @@
;; is used for each evaluation of a keyword lambda.) ;; is used for each evaluation of a keyword lambda.)
;; The `procedure' property is a per-type method that has exactly ;; The `procedure' property is a per-type method that has exactly
;; the right arity, and that sends all arguments to `missing-kw'. ;; the right arity, and that sends all arguments to `missing-kw'.
(define (make-required name fail-proc method? proxy?) (define (make-required name fail-proc method? impersonator?)
(let-values ([(s: mk ? -ref -set!) (let-values ([(s: mk ? -ref -set!)
(make-struct-type (or name 'unknown) (make-struct-type (or name 'unknown)
(if proxy? (if impersonator?
(if method? (if method?
struct:keyword-method-proxy struct:keyword-method-impersonator
struct:keyword-procedure-proxy) struct:keyword-procedure-impersonator)
(if method? (if method?
struct:keyword-method struct:keyword-method
struct:keyword-procedure)) struct:keyword-procedure))
@ -156,26 +156,26 @@
;; Proxies ;; Proxies
(define-values (struct:keyword-procedure-proxy make-kpp keyword-procedure-proxy? kpp-ref kpp-set!) (define-values (struct:keyword-procedure-impersonator make-kpp keyword-procedure-impersonator? kpp-ref kpp-set!)
(make-struct-type 'procedure (make-struct-type 'procedure
struct:keyword-procedure struct:keyword-procedure
1 0 #f 1 0 #f
(list (cons prop:keyword-proxy (lambda (v) (kpp-ref v 0)))))) (list (cons prop:keyword-impersonator (lambda (v) (kpp-ref v 0))))))
(define-values (struct:keyword-method-proxy make-kmp keyword-method-proxy? kmp-ref kmp-set!) (define-values (struct:keyword-method-impersonator make-kmp keyword-method-impersonator? kmp-ref kmp-set!)
(make-struct-type 'procedure (make-struct-type 'procedure
struct:keyword-method struct:keyword-method
1 0 #f 1 0 #f
(list (cons prop:keyword-proxy (lambda (v) (kmp-ref v 0)))))) (list (cons prop:keyword-impersonator (lambda (v) (kmp-ref v 0))))))
(define-values (struct:okpp make-optional-keyword-procedure-proxy okpp? okpp-ref okpp-set!) (define-values (struct:okpp make-optional-keyword-procedure-impersonator okpp? okpp-ref okpp-set!)
(make-struct-type 'procedure (make-struct-type 'procedure
struct:okp struct:okp
1 0 #f 1 0 #f
(list (cons prop:keyword-proxy (lambda (v) (okpp-ref v 0)))))) (list (cons prop:keyword-impersonator (lambda (v) (okpp-ref v 0))))))
(define-values (struct:okmp make-optional-keyword-method-proxy okmp? okmp-ref okmp-set!) (define-values (struct:okmp make-optional-keyword-method-impersonator okmp? okmp-ref okmp-set!)
(make-struct-type 'procedure (make-struct-type 'procedure
struct:okp struct:okp
1 0 #f 1 0 #f
(list (cons prop:keyword-proxy (lambda (v) (okmp-ref v 0)))))) (list (cons prop:keyword-impersonator (lambda (v) (okmp-ref v 0))))))
;; ---------------------------------------- ;; ----------------------------------------
@ -1179,20 +1179,20 @@
(do-chaperone-procedure #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))]) (do-chaperone-procedure #f chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
chaperone-procedure)) chaperone-procedure))
(define new:proxy-procedure (define new:impersonate-procedure
(let ([proxy-procedure (let ([impersonate-procedure
(lambda (proc wrap-proc . props) (lambda (proc wrap-proc . props)
(do-chaperone-procedure #t proxy-procedure 'proxy-procedure proc wrap-proc props))]) (do-chaperone-procedure #t impersonate-procedure 'impersonate-procedure proc wrap-proc props))])
proxy-procedure)) impersonate-procedure))
(define (do-chaperone-procedure is-proxy? chaperone-procedure name proc wrap-proc props) (define (do-chaperone-procedure is-impersonator? chaperone-procedure name proc wrap-proc props)
(if (or (not (keyword-procedure? proc)) (if (or (not (keyword-procedure? proc))
(not (procedure? wrap-proc)) (not (procedure? wrap-proc))
;; if any bad prop, let `chaperone-procedure' complain ;; if any bad prop, let `chaperone-procedure' complain
(let loop ([props props]) (let loop ([props props])
(cond (cond
[(null? props) #f] [(null? props) #f]
[(proxy-property? (car props)) [(impersonator-property? (car props))
(let ([props (cdr props)]) (let ([props (cdr props)])
(or (null? props) (or (null? props)
(loop (cdr props))))] (loop (cdr props))))]
@ -1225,7 +1225,7 @@
name name
(format (format
"~a procedure requires more keywords than original procedure: " "~a procedure requires more keywords than original procedure: "
(if is-proxy? "proxying" "chaperoning")) (if is-impersonator? "impersonating" "chaperoning"))
proc)) proc))
(unless (or (not b-allow) (unless (or (not b-allow)
(and a-allow (and a-allow
@ -1234,7 +1234,7 @@
name name
(format (format
"~a procedure does not accept all keywords of original procedure: " "~a procedure does not accept all keywords of original procedure: "
(if is-proxy? "proxying" "chaperoning")) (if is-impersonator? "impersonating" "chaperoning"))
proc)) proc))
(let* ([kw-chaperone (let* ([kw-chaperone
(let ([p (keyword-procedure-proc wrap-proc)]) (let ([p (keyword-procedure-proc wrap-proc)])
@ -1266,7 +1266,7 @@
wrap-proc)) wrap-proc))
(for-each (for-each
(lambda (kw new-arg arg) (lambda (kw new-arg arg)
(unless is-proxy? (unless is-impersonator?
(unless (chaperone-of? new-arg arg) (unless (chaperone-of? new-arg arg)
(raise-mismatch-error (raise-mismatch-error
'|keyword procedure chaperone| '|keyword procedure chaperone|
@ -1283,10 +1283,10 @@
[new-proc [new-proc
(cond (cond
[(okp? proc) [(okp? proc)
(if is-proxy? (if is-impersonator?
((if (okm? proc) ((if (okm? proc)
make-optional-keyword-method-proxy make-optional-keyword-method-impersonator
make-optional-keyword-procedure-proxy) make-optional-keyword-procedure-impersonator)
(keyword-procedure-checker proc) (keyword-procedure-checker proc)
(chaperone-procedure (keyword-procedure-proc proc) (chaperone-procedure (keyword-procedure-proc proc)
kw-chaperone) kw-chaperone)
@ -1305,7 +1305,7 @@
(chaperone-procedure proc (chaperone-procedure proc
(okp-ref wrap-proc 0)))))] (okp-ref wrap-proc 0)))))]
[else [else
(if is-proxy? (if is-impersonator?
;; Constructor must be from `make-required': ;; Constructor must be from `make-required':
(let* ([name+fail (keyword-procedure-name+fail proc)] (let* ([name+fail (keyword-procedure-name+fail proc)]
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc) #t)]) [mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc) #t)])

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

@ -126,11 +126,11 @@
(rename new:procedure->method procedure->method) (rename new:procedure->method procedure->method)
(rename new:procedure-rename procedure-rename) (rename new:procedure-rename procedure-rename)
(rename new:chaperone-procedure chaperone-procedure) (rename new:chaperone-procedure chaperone-procedure)
(rename new:proxy-procedure proxy-procedure) (rename new:impersonate-procedure impersonate-procedure)
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure (all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure
procedure-arity procedure-reduce-arity raise-arity-error procedure-arity procedure-reduce-arity raise-arity-error
procedure->method procedure-rename procedure->method procedure-rename
chaperone-procedure proxy-procedure) chaperone-procedure impersonate-procedure)
(all-from "reqprov.rkt") (all-from "reqprov.rkt")
(all-from "for.rkt") (all-from "for.rkt")
(all-from "kernstruct.rkt") (all-from "kernstruct.rkt")

6
collects/scribblings/reference/booleans.scrbl
View File

@ -44,7 +44,7 @@ strings, byte strings, numbers, pairs, mutable pairs, vectors, boxes, hash
tables, and inspectable structures. In the last five cases, equality tables, and inspectable structures. In the last five cases, equality
is recursively defined; if both @scheme[v1] and @scheme[v2] contain is recursively defined; if both @scheme[v1] and @scheme[v2] contain
reference cycles, they are equal when the infinite unfoldings of the reference cycles, they are equal when the infinite unfoldings of the
values would be equal. See also @scheme[prop:equal+hash] and @racket[prop:proxy-of]. values would be equal. See also @scheme[prop:equal+hash] and @racket[prop:impersonator-of].
@examples[ @examples[
(equal? 'yes 'yes) (equal? 'yes 'yes)
@ -183,8 +183,8 @@ transparent structures, @scheme[equal-hash-code] and
values. For opaque structure types, @scheme[equal?] is the same as values. For opaque structure types, @scheme[equal?] is the same as
@scheme[eq?], and @scheme[equal-hash-code] and @scheme[eq?], and @scheme[equal-hash-code] and
@scheme[equal-secondary-hash-code] results are based only on @scheme[equal-secondary-hash-code] results are based only on
@scheme[eq-hash-code]. If a structure has a @racket[prop:proxy-of] @scheme[eq-hash-code]. If a structure has a @racket[prop:impersonator-of]
property, then the @racket[prop:proxy-of] property takes precedence over property, then the @racket[prop:impersonator-of] property takes precedence over
@racket[prop:equal+hash] if the property value's procedure returns a @racket[prop:equal+hash] if the property value's procedure returns a
non-@racket[#f] value when applied to the structure. non-@racket[#f] value when applied to the structure.

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

@ -8,16 +8,16 @@
@(define-syntax-rule (operations i ...) @(define-syntax-rule (operations i ...)
(itemlist #:style 'compact @item{@op[i]} ...)) (itemlist #:style 'compact @item{@op[i]} ...))
@title[#:tag "chaperones"]{Proxies and Chaperones} @title[#:tag "chaperones"]{Impersonators and Chaperones}
A @deftech{proxy} is a wrapper for a value where the wrapper An @deftech{impersonator} is a wrapper for a value where the wrapper
redirects certain of the value's operations. Proxies apply only to procedures, redirects certain of the value's operations. Impersonators apply only to procedures,
@tech{structures} for which an accessor or mutator is available, @tech{structures} for which an accessor or mutator is available,
@tech{structure types}, @tech{hash tables}, @tech{vectors}, @tech{structure types}, @tech{hash tables}, @tech{vectors},
and @tech{box}es. A proxied value is @scheme[equal?] to the original and @tech{box}es. An impersonator is @scheme[equal?] to the original
value, but not @scheme[eq?] to the original value. value, but not @scheme[eq?] to the original value.
A @deftech{chaperone} is a kind of proxy whose refinement of a value's A @deftech{chaperone} is a kind of impersonator whose refinement of a value's
operation is restricted to side effects (including, in particular, operation is restricted to side effects (including, in particular,
raising an exception) or chaperoning values supplied to or produced by raising an exception) or chaperoning values supplied to or produced by
the operation. For example, a vector chaperone can redirect the operation. For example, a vector chaperone can redirect
@ -27,16 +27,16 @@ to be a chaperoned variant of the value that is in the accessed vector
slot, but it cannot redirect @scheme[vector-ref] to produce a value slot, but it cannot redirect @scheme[vector-ref] to produce a value
that is arbitrarily different from the value in the vector slot. that is arbitrarily different from the value in the vector slot.
A non-@tech{chaperone} @tech{proxy}, in contrast, can refine an operation to swap one A non-@tech{chaperone} @tech{impersonator}, in contrast, can refine an operation to swap one
value for any another. A proxy cannot be applied to an immutable value value for any another. An impersonator cannot be applied to an immutable value
or refine the access to an immutable field in an instance of a @tech{structure or refine the access to an immutable field in an instance of a @tech{structure
type}, since arbitrary replacement of an operation's value amounts to type}, since arbitrary replacement of an operation's value amounts to
mutation of the proxied value. mutation of the impersonated value.
Beware that each of the following operations can be redirected to Beware that each of the following operations can be redirected to
arbitrary procedure through proxies on the operation's arbitrary procedure through impersonators on the operation's
argument---assuming that the operation is available to the creator of argument---assuming that the operation is available to the creator of
the proxy: the impersonator:
@operations[@t{a structure-field accesor} @operations[@t{a structure-field accesor}
@t{a structure-field mutator} @t{a structure-field mutator}
@ -47,50 +47,50 @@ the proxy:
hash-ref hash-set hash-set! hash-remove hash-remove!] hash-ref hash-set hash-set! hash-remove hash-remove!]
Derived operations, such as printing a value, can be redirected Derived operations, such as printing a value, can be redirected
through proxies due to their use of accessor functions. The through impersonators due to their use of accessor functions. The
@scheme[equal?], @scheme[equal-hash-code], and @scheme[equal?], @scheme[equal-hash-code], and
@scheme[equal-secondary-hash-code] operations, in contrast, may bypass @scheme[equal-secondary-hash-code] operations, in contrast, may bypass
proxies (but they are not obliged to). impersonators (but they are not obliged to).
In addition to redirecting operations that work on a value, a In addition to redirecting operations that work on a value, a
proxy can include @deftech{proxy properties} for a proxied impersonator can include @deftech{impersonator properties} for an impersonated
value. A @tech{proxy property} is similar to a @tech{structure value. An @tech{impersonator property} is similar to a @tech{structure
type property}, but it applies to chaperones instead of structure type property}, but it applies to impersonators instead of structure
types and their instances. types and their instances.
@defproc[(proxy? [v any/c]) boolean?]{ @defproc[(impersonator? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a proxy, @scheme[#f] otherwise. Returns @scheme[#t] if @scheme[v] is an @tech{impersonator}, @scheme[#f] otherwise.
Programs and libraries generally should avoid @scheme[proxy?] and Programs and libraries generally should avoid @scheme[impersonator?] and
treat proxies the same as unproxied values. In rare cases, treat impersonators the same as non-impersonator values. In rare cases,
@scheme[proxy?] may be needed to guard against redirection by a @scheme[impersonator?] may be needed to guard against redirection by an
proxy of an operation to an arbitrary procedure.} impersonator of an operation to an arbitrary procedure.}
@defproc[(chaperone? [v any/c]) boolean?]{ @defproc[(chaperone? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a chaperone, @scheme[#f] otherwise. Returns @scheme[#t] if @scheme[v] is a @tech{chaperone}, @scheme[#f] otherwise.
Programs and libraries generally should avoid @scheme[chaperone?] for Programs and libraries generally should avoid @scheme[chaperone?] for
the same reason that they should avoid @racket[proxy?].} the same reason that they should avoid @racket[impersonator?].}
@defproc[(proxy-of? [v1 any/c] [v2 any/c]) boolean?]{ @defproc[(impersonator-of? [v1 any/c] [v2 any/c]) boolean?]{
Indicates whether @scheme[v1] can be considered equivalent modulo Indicates whether @scheme[v1] can be considered equivalent modulo
proxies to @scheme[v2]. impersonators to @scheme[v2].
For values that include no proxies, @scheme[v1] and @scheme[v2] can For values that include no impersonators, @scheme[v1] and @scheme[v2] can
be considered proxies of each other if they are @scheme[equal?]. be considered impersonators of each other if they are @scheme[equal?].
Otherwise, all proxies of @scheme[v2] must be intact in @scheme[v1], Otherwise, all impersonators of @scheme[v2] must be intact in @scheme[v1],
in the sense that parts of @scheme[v2] must be derived from in the sense that parts of @scheme[v2] must be derived from
@scheme[v1] through one of the proxy constructors (e.g., @scheme[v1] through one of the impersonator constructors (e.g.,
@scheme[proxy-procedure] or @racket[chaperone-procedure]). @scheme[impersonate-procedure] or @racket[chaperone-procedure]).
See also @racket[prop:proxy-of].} See also @racket[prop:impersonator-of].}
@defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{ @defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{
@ -109,16 +109,16 @@ from @scheme[v1] through one of the chaperone constructors (e.g.,
@scheme[chaperone-procedure]).} @scheme[chaperone-procedure]).}
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@section{Proxy Constructors} @section{Impersonator Constructors}
@defproc[(proxy-procedure [proc procedure?] @defproc[(impersonate-procedure [proc procedure?]
[wrapper-proc procedure?] [wrapper-proc procedure?]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c procedure? proxy?)]{ (and/c procedure? impersonator?)]{
Returns a proxied procedure that has the same arity, name, and Returns an impersonator procedure that has the same arity, name, and
other attributes as @scheme[proc]. When the proxied procedure is other attributes as @scheme[proc]. When the impersonator procedure is
applied, the arguments are first passed to @scheme[wrapper-proc], and applied, the arguments are first passed to @scheme[wrapper-proc], and
then the results from @scheme[wrapper-proc] are passed to then the results from @scheme[wrapper-proc] are passed to
@scheme[proc]. The @scheme[wrapper-proc] can also supply a procedure @scheme[proc]. The @scheme[wrapper-proc] can also supply a procedure
@ -137,44 +137,44 @@ before the others. The additional result, if any, must be a procedure
that accepts as many results as produced by @scheme[proc]; it must that accepts as many results as produced by @scheme[proc]; it must
return the same number of results. If @scheme[wrapper-proc] returns return the same number of results. If @scheme[wrapper-proc] returns
the same number of values as it is given (i.e., it does not return a the same number of values as it is given (i.e., it does not return a
procedure to proxy @scheme[proc]'s result), then @scheme[proc] is procedure to impersonator @scheme[proc]'s result), then @scheme[proc] is
called in @tech{tail position} with respect to the call to the proxy. called in @tech{tail position} with respect to the call to the impersonator.
For applications that include keyword arguments, @scheme[wrapper-proc] For applications that include keyword arguments, @scheme[wrapper-proc]
must return an additional value before any other values but after the must return an additional value before any other values but after the
result-proxying procedure (if any). The additional value must be a result-impersonating procedure (if any). The additional value must be a
list of proxys of the keyword arguments that were supplied to the list of replacements for the keyword arguments that were supplied to the
proxied procedure (i.e., not counting optional arguments that were impersonator (i.e., not counting optional arguments that were
not supplied). The arguments must be ordered according to the sorted not supplied). The arguments must be ordered according to the sorted
order of the supplied arguments' keywords. order of the supplied arguments' keywords.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[procedure-proxy] must be even) add proxy properties to @scheme[procedure-impersonator] must be even) add impersonator properties
or override proxy-property values of @scheme[proc]. or override impersonator-property values of @scheme[proc].
If any @scheme[prop] is @racket[proxy-prop:application-mark] and if the If any @scheme[prop] is @racket[impersonator-prop:application-mark] and if the
associated @racket[prop-val] is a pair, then the call to @racket[proc] associated @racket[prop-val] is a pair, then the call to @racket[proc]
is wrapped with @racket[with-continuation-mark] using @racket[(car is wrapped with @racket[with-continuation-mark] using @racket[(car
prop-val)] as the mark key and @racket[(cdr prop-val)] as the mark prop-val)] as the mark key and @racket[(cdr prop-val)] as the mark
value. In addition, if @racket[continuation-mark-set-first] with value. In addition, if @racket[continuation-mark-set-first] with
@racket[(car prop-val)] produces a value for the immediate @racket[(car prop-val)] produces a value for the immediate
continuation frame of the call to the proxied procedure, the value is continuation frame of the call to the impersonated procedure, the value is
also installed as an immediate value for @racket[(car prop-val)] as a also installed as an immediate value for @racket[(car prop-val)] as a
mark during the call to @racket[wrapper-proc] (which allows tail-calls mark during the call to @racket[wrapper-proc] (which allows tail-calls
of proxies with respect to wrapping proxies to be detected within of impersonators with respect to wrapping impersonators to be detected within
@racket[wrapper-proc]).} @racket[wrapper-proc]).}
@defproc[(proxy-struct [v any/c] @defproc[(impersonate-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure? [orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure?)] struct-mutator-procedure?)]
[redirect-proc procedure?] ... ... [redirect-proc procedure?] ... ...
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
any/c]{ any/c]{
Returns a proxied value like @scheme[v], but with certain Returns an impersonator of @scheme[v], with redirect certain
operations on the proxied redirected. The @scheme[orig-proc]s operations on the impersonated value. The @scheme[orig-proc]s
indicate the operations to redirect, and the corresponding indicate the operations to redirect, and the corresponding
@scheme[redirect-proc]s supply the redirections. @scheme[redirect-proc]s supply the redirections.
@ -183,14 +183,14 @@ The protocol for a @scheme[redirect-proc] depends on the corresponding
@itemlist[ @itemlist[
@item{A structure-field: @scheme[redirect-proc] @item{A structure-field accessor: @scheme[redirect-proc]
must accept two arguments, @scheme[v] and the value must accept two arguments, @scheme[v] and the value
@scheme[_field-v] that @scheme[orig-proc] produces for @scheme[_field-v] that @scheme[orig-proc] produces for
@scheme[v]; it must return a replacement for @scheme[v]; it must return a replacement for
@scheme[_field-v]. The corresponding field must not be @scheme[_field-v]. The corresponding field must not be
immutable.} immutable.}
@item{A structure field mutator: @scheme[redirect-proc] must accept @item{A structure-field mutator: @scheme[redirect-proc] must accept
two arguments, @scheme[v] and the value @scheme[_field-v] two arguments, @scheme[v] and the value @scheme[_field-v]
supplied to the mutator; it must return a replacement for supplied to the mutator; it must return a replacement for
@scheme[_field-v] to be propagated to @scheme[orig-proc] and @scheme[_field-v] to be propagated to @scheme[orig-proc] and
@ -199,25 +199,24 @@ The protocol for a @scheme[redirect-proc] depends on the corresponding
] ]
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[proxy-procedure] must be odd) add proxy properties to @scheme[impersonate-struct] must be odd) add impersonator properties
or override proxy-property values of @scheme[v].} or override impersonator-property values of @scheme[v].}
@defproc[(proxy-vector [vec (and/c vector? (not/c immutable?))] @defproc[(impersonate-vector [vec (and/c vector? (not/c immutable?))]
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)] [ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)] [set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c vector? proxy?)]{ (and/c vector? impersonator?)]{
Returns a proxied value like @scheme[vec], but with Returns an impersonator of @scheme[vec], which redirects the
@scheme[vector-ref] and @scheme[vector-set!] operations on the @scheme[vector-ref] and @scheme[vector-set!] operations.
proxied vector redirected.
The @scheme[ref-proc] must accept @scheme[vec], an index passed to The @scheme[ref-proc] must accept @scheme[vec], an index passed to
@scheme[vector-ref], and the value that @scheme[vector-ref] on @scheme[vector-ref], and the value that @scheme[vector-ref] on
@scheme[vec] produces for the given index; it must produce a @scheme[vec] produces for the given index; it must produce a
replacement for the value, which is the result of @scheme[vector-ref] replacement for the value, which is the result of @scheme[vector-ref]
on the proxy. on the impersonator.
The @scheme[set-proc] must accept @scheme[vec], an index passed to The @scheme[set-proc] must accept @scheme[vec], an index passed to
@scheme[vector-set!], and the value passed to @scheme[vector-set!]; it @scheme[vector-set!], and the value passed to @scheme[vector-set!]; it
@ -226,24 +225,23 @@ with @scheme[vector-set!] on the original @scheme[vec] to install the
value. value.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[proxy-vector] must be odd) add proxy properties to @scheme[impersonate-vector] must be odd) add impersonator properties
or override proxy-property values of @scheme[vec].} or override impersonator-property values of @scheme[vec].}
@defproc[(proxy-box [box (and/c box? (not/c immutable?))] @defproc[(impersonate-box [box (and/c box? (not/c immutable?))]
[unbox-proc (box? any/c . -> . any/c)] [unbox-proc (box? any/c . -> . any/c)]
[set-proc (box? any/c . -> . any/c)] [set-proc (box? any/c . -> . any/c)]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c box? proxy?)]{ (and/c box? impersonator?)]{
Returns a proxied value like @scheme[bx], but with Returns an impersonator of @scheme[bx], which redirects the
@scheme[unbox] and @scheme[set-box!] operations on the @scheme[unbox] and @scheme[set-box!] operations.
proxied box redirected.
The @scheme[unbox-proc] must accept @scheme[bx] and the value that The @scheme[unbox-proc] must accept @scheme[bx] and the value that
@scheme[unbox] on @scheme[bx] produces index; it must produce a replacement @scheme[unbox] on @scheme[bx] produces index; it must produce a replacement
value, which is the result of value, which is the result of
@scheme[unbox] on the proxy. @scheme[unbox] on the impersonator.
The @scheme[set-proc] must accept @scheme[bx] and the value passed to The @scheme[set-proc] must accept @scheme[bx] and the value passed to
@scheme[set-box!]; it must produce a replacement @scheme[set-box!]; it must produce a replacement
@ -251,28 +249,28 @@ value, which is used with @scheme[set-box!] on the original
@scheme[bx] to install the value. @scheme[bx] to install the value.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[proxy-box] must be odd) add proxy properties to @scheme[impersonate-box] must be odd) add impersonator properties
or override proxy-property values of @scheme[bx].} or override impersonator-property values of @scheme[bx].}
@defproc[(proxy-hash [hash (and/c hash? (not/c immutable?))] @defproc[(impersonate-hash [hash (and/c hash? (not/c immutable?))]
[ref-proc (hash? any/c . -> . (values [ref-proc (hash? any/c . -> . (values
any/c any/c
(hash? any/c any/c . -> . any/c)))] (hash? any/c any/c . -> . any/c)))]
[set-proc (hash? any/c any/c . -> . (values any/c any/c))] [set-proc (hash? any/c any/c . -> . (values any/c any/c))]
[remove-proc (hash? any/c . -> . any/c)] [remove-proc (hash? any/c . -> . any/c)]
[key-proc (hash? any/c . -> . any/c)] [key-proc (hash? any/c . -> . any/c)]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c hash? proxy?)]{ (and/c hash? impersonator?)]{
Returns a proxied value like @scheme[hash], but with Returns an impersonator of @scheme[hash], which redirects the
@scheme[hash-ref], @scheme[hash-set!] or @scheme[hash-set] (as @scheme[hash-ref], @scheme[hash-set!] or @scheme[hash-set] (as
applicable) and @scheme[hash-remove] or @scheme[hash-remove!] (as applicable), and @scheme[hash-remove] or @scheme[hash-remove!] (as
application) operations on the proxied hash table redirected. When application) operations. When
@scheme[hash-set] or @scheme[hash-remove] is used on a proxied hash @scheme[hash-set] or @scheme[hash-remove] is used on an impersonator of a hash
table, the resulting hash table is given all of the proxys of the table, the result is an impersonator with the same redirecting procedures.
given hash table. In addition, operations like In addition, operations like
@scheme[hash-iterate-key] or @scheme[hash-map], which extract @scheme[hash-iterate-key] or @scheme[hash-map], which extract
keys from the table, use @scheme[key-proc] to filter keys extracted keys from the table, use @scheme[key-proc] to filter keys extracted
from the table. Operations like @scheme[hash-iterate-value] or from the table. Operations like @scheme[hash-iterate-value] or
@ -285,7 +283,7 @@ as well as a procedure. The returned procedure is called only if the
returned key is found in @scheme[hash] via @scheme[hash-ref], in which returned key is found in @scheme[hash] via @scheme[hash-ref], in which
case the procedure is called with @scheme[hash], the previously case the procedure is called with @scheme[hash], the previously
returned key, and the found value. The returned procedure must itself returned key, and the found value. The returned procedure must itself
return a replecement for the found value. return a replacement for the found value.
The @scheme[set-proc] must accept @scheme[hash], a key passed to The @scheme[set-proc] must accept @scheme[hash], a key passed to
@scheme[hash-set!] or @scheme[hash-set], and the value passed to @scheme[hash-set!] or @scheme[hash-set], and the value passed to
@ -298,7 +296,7 @@ The @scheme[remove-proc] must accept @scheme[hash] and a key passed to
@scheme[hash-remove!] or @scheme[hash-remove]; it must produce the a @scheme[hash-remove!] or @scheme[hash-remove]; it must produce the a
replacement for the key, which is used with @scheme[hash-remove!] or replacement for the key, which is used with @scheme[hash-remove!] or
@scheme[hash-remove] on the original @scheme[hash] to remove any @scheme[hash-remove] on the original @scheme[hash] to remove any
mapping using the (proxy-replaced) key. mapping using the (impersonator-replaced) key.
The @scheme[key-proc] must accept @scheme[hash] and a key that has The @scheme[key-proc] must accept @scheme[hash] and a key that has
been extracted from @scheme[hash] (by @scheme[hash-iterate-key] or been extracted from @scheme[hash] (by @scheme[hash-iterate-key] or
@ -313,38 +311,38 @@ produced by @scheme[key-proc] does not yield a value through
@racket[hash-ref], then the @exnraise[exn:fail:contract]. @racket[hash-ref], then the @exnraise[exn:fail:contract].
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[proxy-hash] must be odd) add proxy properties to @scheme[impersonate-hash] must be odd) add impersonator properties
or override proxy-property values of @scheme[hash].} or override impersonator-property values of @scheme[hash].}
@defthing[prop:proxy-of struct-type-property?]{ @defthing[prop:impersonator-of struct-type-property?]{
A @tech{structure type property} (see @secref["structprops"]) that A @tech{structure type property} (see @secref["structprops"]) that
supplies a procedure for extracting a proxied value from a structure supplies a procedure for extracting an impersonated value from a structure
that represents a proxy. The property is used for @racket[proxy-of] that represents an impersonator. The property is used for @racket[impersonator-of]
as well as @racket[equal?]. as well as @racket[equal?].
The property value must be a procedure of one argument, which is a The property value must be a procedure of one argument, which is a
structure whose structure type has the property. The result can be structure whose structure type has the property. The result can be
@scheme[#f] to indicate the structure does not represent a proxy, @scheme[#f] to indicate the structure does not represent an impersonator,
otherwise the result is a value for which the original structure is a otherwise the result is a value for which the original structure is an
proxy (so the original structure is a @racket[proxy-of?] and it is impersonator (so the original structure is an @racket[impersonator-of?] and
@racket[equal?] to the result value). The result value must have the @racket[equal?] to the result value). The result value must have the
same @racket[prop:proxy-of] and @racket[prop:equal+hash] property same @racket[prop:impersonator-of] and @racket[prop:equal+hash] property
values as the original structure, and the property values must be values as the original structure, and the property values must be
inherited from the same structure type (which ensures some consistency inherited from the same structure type (which ensures some consistency
between @racket[proxy-of?] and @racket[equal?]).} between @racket[impersonator-of?] and @racket[equal?]).}
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@section{Chaperone Constructors} @section{Chaperone Constructors}
@defproc[(chaperone-procedure [proc procedure?] @defproc[(chaperone-procedure [proc procedure?]
[wrapper-proc procedure?] [wrapper-proc procedure?]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c procedure? chaperone?)]{ (and/c procedure? chaperone?)]{
Like @racket[proxy-procedure], but for each value supplied to Like @racket[impersonate-procedure], but for each value supplied to
@scheme[wrapper-proc], the corresponding result must be the same or a @scheme[wrapper-proc], the corresponding result must be the same or a
chaperone of (in the sense of @scheme[chaperone-of?]) the supplied chaperone of (in the sense of @scheme[chaperone-of?]) the supplied
value. The additional result, if any, that precedes the chaperoned value. The additional result, if any, that precedes the chaperoned
@ -356,7 +354,7 @@ For applications that include keyword arguments, @scheme[wrapper-proc]
must return an additional value before any other values but after the must return an additional value before any other values but after the
result-chaperoning procedure (if any). The additional value must be a result-chaperoning procedure (if any). The additional value must be a
list of chaperones of the keyword arguments that were supplied to the list of chaperones of the keyword arguments that were supplied to the
chaperoned procedure (i.e., not counting optional arguments that were chaperone procedure (i.e., not counting optional arguments that were
not supplied). The arguments must be ordered according to the sorted not supplied). The arguments must be ordered according to the sorted
order of the supplied arguments' keywords.} order of the supplied arguments' keywords.}
@ -366,18 +364,18 @@ order of the supplied arguments' keywords.}
struct-type-property-accessor-procedure? struct-type-property-accessor-procedure?
(one-of/c struct-info))] (one-of/c struct-info))]
[redirect-proc procedure?] ... ... [redirect-proc procedure?] ... ...
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
any/c]{ any/c]{
Like @racket[proxy-struct], but with the following refinements: Like @racket[impersonate-struct], but with the following refinements:
@itemlist[ @itemlist[
@item{With a structure-field accessor as @racket[orig-proc], @item{With a structure-field accessor as @racket[orig-proc],
@scheme[redirect-proc] must accept two arguments, @scheme[v] and @scheme[redirect-proc] must accept two arguments, @scheme[v] and
the value @scheme[_field-v] that @scheme[orig-proc] produces for the value @scheme[_field-v] that @scheme[orig-proc] produces for
@scheme[v]; it must return chaperone of @scheme[_field-v]. The @scheme[v]; it must return a chaperone of @scheme[_field-v]. The
corresponding field may be immutable.} corresponding field may be immutable.}
@item{A property accessor can be supplied as @racket[orig-proc]. The @item{A property accessor can be supplied as @racket[orig-proc]. The
@ -387,7 +385,7 @@ Like @racket[proxy-struct], but with the following refinements:
@item{With structure-field mutator as @racket[orig-proc], @item{With structure-field mutator as @racket[orig-proc],
@scheme[redirect-proc] must accept two arguments, @scheme[v] and @scheme[redirect-proc] must accept two arguments, @scheme[v] and
the value @scheme[_field-v] supplied to the mutator; it must the value @scheme[_field-v] supplied to the mutator; it must
return chaperone of @scheme[_field-v] to be propagated to return a chaperone of @scheme[_field-v] to be propagated to
@scheme[orig-proc] and @scheme[v].} @scheme[orig-proc] and @scheme[v].}
@item{With @scheme[struct-info] as @racket[orig-proc], the @item{With @scheme[struct-info] as @racket[orig-proc], the
@ -408,11 +406,11 @@ unchaperoned.}
@defproc[(chaperone-vector [vec vector?] @defproc[(chaperone-vector [vec vector?]
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)] [ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)] [set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c vector? chaperone?)]{ (and/c vector? chaperone?)]{
Like @racket[proxy-vector], but with support for mutable vectors. The Like @racket[impersonate-vector], but with support for immutable vectors. The
@scheme[ref-proc] procedure must produce the same value or a chaperone @scheme[ref-proc] procedure must produce the same value or a chaperone
of the original value, and @scheme[set-proc] must produce the value of the original value, and @scheme[set-proc] must produce the value
that is given or a chaperone of the value. The @scheme[set-proc] will that is given or a chaperone of the value. The @scheme[set-proc] will
@ -421,7 +419,7 @@ not be used if @scheme[vec] is immutable.}
@defproc[(chaperone-box [bx box?] @defproc[(chaperone-box [bx box?]
[unbox-proc (box? any/c . -> . any/c)] [unbox-proc (box? any/c . -> . any/c)]
[set-proc (box? any/c . -> . any/c)] [set-proc (box? any/c . -> . any/c)]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c box? chaperone?)]{ (and/c box? chaperone?)]{
@ -439,11 +437,11 @@ the same value or a chaperone of the value that it is given. The
[set-proc (hash? any/c any/c . -> . (values any/c any/c))] [set-proc (hash? any/c any/c . -> . (values any/c any/c))]
[remove-proc (hash? any/c . -> . any/c)] [remove-proc (hash? any/c . -> . any/c)]
[key-proc (hash? any/c . -> . any/c)] [key-proc (hash? any/c . -> . any/c)]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c hash? chaperone?)]{ (and/c hash? chaperone?)]{
Like @racket[proxy-hash], but with constraints on the given functions Like @racket[impersonate-hash], but with constraints on the given functions
and support for immutable hashes. The @scheme[ref-proc] procedure must and support for immutable hashes. The @scheme[ref-proc] procedure must
return a found value or a chaperone of the value. The return a found value or a chaperone of the value. The
@scheme[set-proc] procedure must produce two values: the key that it @scheme[set-proc] procedure must produce two values: the key that it
@ -455,7 +453,7 @@ procedures must produce the given key or a chaperone of the key.}
[struct-info-proc procedure?] [struct-info-proc procedure?]
[make-constructor-proc (procedure? . -> . procedure?)] [make-constructor-proc (procedure? . -> . procedure?)]
[guard-proc procedure?] [guard-proc procedure?]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c struct-type? chaperone?)]{ (and/c struct-type? chaperone?)]{
@ -486,12 +484,12 @@ each the same or a chaperone of the corresponding argument. The
created of the chaperoned structure type. created of the chaperoned structure type.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-struct-type] must be even) add proxy properties to @scheme[chaperone-struct-type] must be even) add impersonator properties
or override proxy-property values of @scheme[struct-type].} or override impersonator-property values of @scheme[struct-type].}
@defproc[(chaperone-evt [evt evt?] @defproc[(chaperone-evt [evt evt?]
[proc (evt? . -> . (values evt? (any/c . -> . any/c)))] [proc (evt? . -> . (values evt? (any/c . -> . any/c)))]
[prop proxy-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c evt? chaperone?)]{ (and/c evt? chaperone?)]{
@ -508,52 +506,52 @@ a selection. The latter procedure accepts the result of @racket[evt],
and it must return a chaperone of that value. and it must return a chaperone of that value.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-struct-type] must be even) add proxy properties to @scheme[chaperone-evt] must be even) add impersonator properties
or override proxy-property values of @scheme[evt].} or override impersonator-property values of @scheme[evt].}
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@section{Proxy Properties} @section{Impersonator Properties}
@defproc[(make-proxy-property [name symbol?]) @defproc[(make-impersonator-property [name symbol?])
(values proxy-property? (values impersonator-property?
(-> any/c boolean?) (-> any/c boolean?)
(-> chaperone? any))]{ (-> impersonator? any))]{
Creates a new @tech{proxy property} and returns three values: Creates a new @tech{impersonator property} and returns three values:
@itemize[ @itemize[
@item{a @deftech{proxy property descriptor}, for use with @item{an @deftech{impersonator property descriptor}, for use with
@scheme[chaperone-procedure], @scheme[chaperone-struct], and @scheme[impersonate-procedure], @scheme[chaperone-procedure],
other chaperone constructors;} and other impersonator constructors;}
@item{a @deftech{proxy property predicate} procedure, which takes @item{an @deftech{impersonator property predicate} procedure, which takes
an arbitrary value and returns @scheme[#t] if the value is a an arbitrary value and returns @scheme[#t] if the value is an
chaperone with a value for the property, @scheme[#f] impersonator with a value for the property, @scheme[#f]
otherwise;} otherwise;}
@item{an @deftech{proxy property accessor} procedure, which @item{an @deftech{impersonator property accessor} procedure, which
returns the value associated with a chaperone for the property; returns the value associated with an impersonator for the property;
if a value given to the accessor is not a chaperone or does not if a value given to the accessor is not an impersonator or does not
have a value for the property (ie if the corresponding chaperone have a value for the property (i.e. if the corresponding impersonator
property predicate returns @racket[#f]), the accessor raises property predicate returns @racket[#f]), the accessor raises
@exnraise[exn:fail:contract].} @exnraise[exn:fail:contract].}
]} ]}
@defproc[(proxy-property? [v any/c]) boolean?]{ @defproc[(impersonator-property? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @tech{proxy property Returns @scheme[#t] if @scheme[v] is a @tech{impersonator property
descriptor} value, @scheme[#f] otherwise.} descriptor} value, @scheme[#f] otherwise.}
@defproc[(proxy-property-accessor-procedure? [v any/c]) boolean?]{ @defproc[(impersonator-property-accessor-procedure? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is an accessor procedure produced Returns @scheme[#t] if @scheme[v] is an accessor procedure produced
by @scheme[make-proxy-property], @scheme[#f] otherwise.} by @scheme[make-impersonator-property], @scheme[#f] otherwise.}
@defthing[proxy-prop:application-mark proxy-property?]{ @defthing[impersonator-prop:application-mark impersonator-property?]{
A @tech{proxy property} that is recognized by @racket[proxy-procedure] An @tech{impersonator property} that is recognized by @racket[impersonate-procedure]
and @racket[chaperone-procedure].} and @racket[chaperone-procedure].}

8
collects/scribblings/reference/contracts.scrbl
View File

@ -246,7 +246,7 @@ is a chaperone contract, then the result will be a chaperone contract.
When a higher-order @racket[vectorof] contract is applied to a vector, the result When a higher-order @racket[vectorof] contract is applied to a vector, the result
is not @racket[eq?] to the input. The result will be a copy for immutable vectors is not @racket[eq?] to the input. The result will be a copy for immutable vectors
and a @tech{chaperone} or @tech{proxy} of the input for mutable vectors.} and a @tech{chaperone} or @tech{impersonator} of the input for mutable vectors.}
@defproc[(vector-immutableof [c contract?]) contract?]{ @defproc[(vector-immutableof [c contract?]) contract?]{
@ -272,7 +272,7 @@ are chaperone contracts, then the result will be a chaperone contract.
When a higher-order @racket[vector/c] contract is applied to a vector, the result When a higher-order @racket[vector/c] contract is applied to a vector, the result
is not @racket[eq?] to the input. The result will be a copy for immutable vectors is not @racket[eq?] to the input. The result will be a copy for immutable vectors
and a @tech{chaperone} or @tech{proxy} of the input for mutable vectors.} and a @tech{chaperone} or @tech{impersonator} of the input for mutable vectors.}
@defproc[(vector-immutable/c [c contract?] ...) contract?]{ @defproc[(vector-immutable/c [c contract?] ...) contract?]{
@ -298,7 +298,7 @@ a chaperone contract, then the result will be a chaperone contract.
When a higher-order @racket[box/c] contract is applied to a box, the result When a higher-order @racket[box/c] contract is applied to a box, the result
is not @racket[eq?] to the input. The result will be a copy for immutable boxes is not @racket[eq?] to the input. The result will be a copy for immutable boxes
and either a @tech{chaperone} or @tech{proxy} of the input for mutable boxes.} and either a @tech{chaperone} or @tech{impersonator} of the input for mutable boxes.}
@defproc[(box-immutable/c [c contract?]) contract?]{ @defproc[(box-immutable/c [c contract?]) contract?]{
@ -377,7 +377,7 @@ If the @racket[key] argument is a chaperone contract, then the resulting contrac
can only be applied to @racket[equal?]-based hash tables. When a higher-order can only be applied to @racket[equal?]-based hash tables. When a higher-order
@racket[hash/c] contract is applied to a hash table, the result is not @racket[eq?] @racket[hash/c] contract is applied to a hash table, the result is not @racket[eq?]
to the input. The result will be a copy for immutable hash tables, and either a to the input. The result will be a copy for immutable hash tables, and either a
@tech{chaperone} or @tech{proxy} of the input for mutable hash tables. @tech{chaperone} or @tech{impersonator} of the input for mutable hash tables.
} }

14
collects/scribblings/reference/unsafe.scrbl
View File

@ -194,8 +194,8 @@ Unsafe variants of @scheme[car], @scheme[cdr], @scheme[mcar],
@deftogether[( @deftogether[(
@defproc[(unsafe-unbox [b box?]) fixnum?] @defproc[(unsafe-unbox [b box?]) fixnum?]
@defproc[(unsafe-set-box! [b box?] [k fixnum?]) void?] @defproc[(unsafe-set-box! [b box?] [k fixnum?]) void?]
@defproc[(unsafe-unbox* [v (and/c box? (not/c chaperone?))]) any/c] @defproc[(unsafe-unbox* [v (and/c box? (not/c impersonator?))]) any/c]
@defproc[(unsafe-set-box*! [v (and/c box? (not/c chaperone?))] [val any/c]) void?] @defproc[(unsafe-set-box*! [v (and/c box? (not/c impersonator?))] [val any/c]) void?]
)]{ )]{
Unsafe versions of @scheme[unbox] and @scheme[set-box!].} Unsafe versions of @scheme[unbox] and @scheme[set-box!].}
@ -205,9 +205,9 @@ Unsafe versions of @scheme[unbox] and @scheme[set-box!].}
@defproc[(unsafe-vector-length [v vector?]) fixnum?] @defproc[(unsafe-vector-length [v vector?]) fixnum?]
@defproc[(unsafe-vector-ref [v vector?] [k fixnum?]) any/c] @defproc[(unsafe-vector-ref [v vector?] [k fixnum?]) any/c]
@defproc[(unsafe-vector-set! [v vector?] [k fixnum?] [val any/c]) void?] @defproc[(unsafe-vector-set! [v vector?] [k fixnum?] [val any/c]) void?]
@defproc[(unsafe-vector*-length [v (and/c vector? (not/c chaperone?))]) fixnum?] @defproc[(unsafe-vector*-length [v (and/c vector? (not/c impersonator?))]) fixnum?]
@defproc[(unsafe-vector*-ref [v (and/c vector? (not/c chaperone?))] [k fixnum?]) any/c] @defproc[(unsafe-vector*-ref [v (and/c vector? (not/c impersonator?))] [k fixnum?]) any/c]
@defproc[(unsafe-vector*-set! [v (and/c vector? (not/c chaperone?))] [k fixnum?] [val any/c]) void?] @defproc[(unsafe-vector*-set! [v (and/c vector? (not/c impersonator?))] [k fixnum?] [val any/c]) void?]
)]{ )]{
Unsafe versions of @scheme[vector-length], @scheme[vector-ref], and Unsafe versions of @scheme[vector-length], @scheme[vector-ref], and
@ -284,8 +284,8 @@ Unsafe versions of @scheme[u16vector-ref] and
@deftogether[( @deftogether[(
@defproc[(unsafe-struct-ref [v any/c] [k fixnum?]) any/c] @defproc[(unsafe-struct-ref [v any/c] [k fixnum?]) any/c]
@defproc[(unsafe-struct-set! [v any/c] [k fixnum?] [val any/c]) void?] @defproc[(unsafe-struct-set! [v any/c] [k fixnum?] [val any/c]) void?]
@defproc[(unsafe-struct*-ref [v (not/c chaperone?)] [k fixnum?]) any/c] @defproc[(unsafe-struct*-ref [v (not/c impersonator?)] [k fixnum?]) any/c]
@defproc[(unsafe-struct*-set! [v (not/c chaperone?)] [k fixnum?] [val any/c]) void?] @defproc[(unsafe-struct*-set! [v (not/c impersonator?)] [k fixnum?] [val any/c]) void?]
)]{ )]{
Unsafe field access and update for an instance of a structure Unsafe field access and update for an instance of a structure

364
collects/tests/racket/chaperone.rktl
View File

@ -5,41 +5,41 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (chaperone-of?/proxy a b) (define (chaperone-of?/impersonator a b)
(test #t proxy-of? a b) (test #t impersonator-of? a b)
(chaperone-of? a b)) (chaperone-of? a b))
(define (chaperone?/proxy a) (define (chaperone?/impersonator a)
(test #t proxy? a) (test #t impersonator? a)
(chaperone? a)) (chaperone? a))
(define-syntax-rule (as-chaperone-or-proxy ([orig proxy] ...) body ...) (define-syntax-rule (as-chaperone-or-impersonator ([orig impersonator] ...) body ...)
(for-each (lambda (orig ...) (for-each (lambda (orig ...)
body ...) body ...)
(list orig proxy) ...)) (list orig impersonator) ...))
;; ---------------------------------------- ;; ----------------------------------------
(test #t chaperone-of?/proxy 10 10) (test #t chaperone-of?/impersonator 10 10)
(test #t chaperone-of?/proxy '(10) '(10)) (test #t chaperone-of?/impersonator '(10) '(10))
(test #t chaperone-of?/proxy '#(1 2 3) '#(1 2 3)) (test #t chaperone-of?/impersonator '#(1 2 3) '#(1 2 3))
(test #t chaperone-of?/proxy '#&(1 2 3) '#&(1 2 3)) (test #t chaperone-of?/impersonator '#&(1 2 3) '#&(1 2 3))
(test #f chaperone-of?/proxy (make-string 1 #\x) (make-string 1 #\x)) (test #f chaperone-of?/impersonator (make-string 1 #\x) (make-string 1 #\x))
(test #t chaperone-of?/proxy (test #t chaperone-of?/impersonator
(string->immutable-string (make-string 1 #\x)) (string->immutable-string (make-string 1 #\x))
(string->immutable-string (make-string 1 #\x))) (string->immutable-string (make-string 1 #\x)))
(define (either-chaperone-of?/proxy a b) (define (either-chaperone-of?/impersonator a b)
(or (chaperone-of?/proxy a b) (or (chaperone-of?/impersonator a b)
(chaperone-of?/proxy b a))) (chaperone-of?/impersonator b a)))
(test #f either-chaperone-of?/proxy (test #f either-chaperone-of?/impersonator
(string->immutable-string "x") (string->immutable-string "x")
(make-string 1 #\x)) (make-string 1 #\x))
(test #f either-chaperone-of?/proxy (test #f either-chaperone-of?/impersonator
'#(1 2 3) '#(1 2 3)
(vector 1 2 3)) (vector 1 2 3))
(test #f either-chaperone-of?/proxy (test #f either-chaperone-of?/impersonator
'#&17 '#&17
(box 17)) (box 17))
@ -50,19 +50,19 @@
(define-struct q (u [w #:mutable]) #:transparent) (define-struct q (u [w #:mutable]) #:transparent)
(define-struct (q2 q) (v) #:transparent) (define-struct (q2 q) (v) #:transparent)
(test #f chaperone-of? (make-o 1 2) (make-o 1 2)) (test #f chaperone-of? (make-o 1 2) (make-o 1 2))
(test #f proxy-of? (make-o 1 2) (make-o 1 2)) (test #f impersonator-of? (make-o 1 2) (make-o 1 2))
(test #t chaperone-of?/proxy (make-p 1 2) (make-p 1 2)) (test #t chaperone-of?/impersonator (make-p 1 2) (make-p 1 2))
(test #f chaperone-of?/proxy (make-p 1 (box 2)) (make-p 1 (box 2))) (test #f chaperone-of?/impersonator (make-p 1 (box 2)) (make-p 1 (box 2)))
(test #t chaperone-of?/proxy (make-p2 1 2 3) (make-p2 1 2 3)) (test #t chaperone-of?/impersonator (make-p2 1 2 3) (make-p2 1 2 3))
(test #f chaperone-of?/proxy (make-q 1 2) (make-q 1 2)) (test #f chaperone-of?/impersonator (make-q 1 2) (make-q 1 2))
(test #f chaperone-of?/proxy (make-q2 1 2 3) (make-q2 1 2 3))) (test #f chaperone-of?/impersonator (make-q2 1 2 3) (make-q2 1 2 3)))
(let* ([p (lambda (x) x)] (let* ([p (lambda (x) x)]
[p1 (proxy-procedure p (lambda (y) y))] [p1 (impersonate-procedure p (lambda (y) y))]
[p2 (chaperone-procedure p1 (lambda (y) y))]) [p2 (chaperone-procedure p1 (lambda (y) y))])
(test #t proxy-of? p2 p) (test #t impersonator-of? p2 p)
(test #t proxy-of? p2 p1) (test #t impersonator-of? p2 p1)
(test #t proxy? p1) (test #t impersonator? p1)
(test #f chaperone? p1) (test #f chaperone? p1)
(test #t chaperone? p2) (test #t chaperone? p2)
(test #f chaperone-of? p2 p) (test #f chaperone-of? p2 p)
@ -70,18 +70,18 @@
;; ---------------------------------------- ;; ----------------------------------------
(test #t chaperone?/proxy (chaperone-box (box 10) (lambda (b v) v) (lambda (b v) v))) (test #t chaperone?/impersonator (chaperone-box (box 10) (lambda (b v) v) (lambda (b v) v)))
(test #f chaperone?/proxy (proxy-box (box 10) (lambda (b v) v) (lambda (b v) v))) (test #f chaperone?/impersonator (impersonate-box (box 10) (lambda (b v) v) (lambda (b v) v)))
(test #t box? (chaperone-box (box 10) (lambda (b v) v) (lambda (b v) v))) (test #t box? (chaperone-box (box 10) (lambda (b v) v) (lambda (b v) v)))
(test #t box? (proxy-box (box 10) (lambda (b v) v) (lambda (b v) v))) (test #t box? (impersonate-box (box 10) (lambda (b v) v) (lambda (b v) v)))
(test #t (lambda (x) (box? x)) (chaperone-box (box 10) (lambda (b v) v) (lambda (b v) v))) (test #t (lambda (x) (box? x)) (chaperone-box (box 10) (lambda (b v) v) (lambda (b v) v)))
(test #t (lambda (x) (box? x)) (proxy-box (box 10) (lambda (b v) v) (lambda (b v) v))) (test #t (lambda (x) (box? x)) (impersonate-box (box 10) (lambda (b v) v) (lambda (b v) v)))
(test #t chaperone?/proxy (chaperone-box (box-immutable 10) (lambda (b v) v) (lambda (b v) v))) (test #t chaperone?/impersonator (chaperone-box (box-immutable 10) (lambda (b v) v) (lambda (b v) v)))
(err/rt-test (proxy-box (box-immutable 10) (lambda (b v) v) (lambda (b v) v))) (err/rt-test (impersonate-box (box-immutable 10) (lambda (b v) v) (lambda (b v) v)))
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-box proxy-box] ([chaperone-box impersonate-box]
[chaperone-of? proxy-of?]) [chaperone-of? impersonator-of?])
(let* ([b (box 0)] (let* ([b (box 0)]
[b2 (chaperone-box b [b2 (chaperone-box b
(lambda (b v) (lambda (b v)
@ -114,11 +114,11 @@
(test #f unbox b2) (test #f unbox b2)
(err/rt-test (set-box! b2 0))))) (err/rt-test (set-box! b2 0)))))
;; no proxy-of checks in a proxy: ;; no impersonator-of checks in a impersonator:
(let ([b (box 0)]) (let ([b (box 0)])
(let ([b2 (proxy-box b (let ([b2 (impersonate-box b
(lambda (b v) #f) (lambda (b v) #f)
(lambda (b v) #f))]) (lambda (b v) #f))])
(test #f unbox b2) (test #f unbox b2)
(test (void) set-box! b2 0) (test (void) set-box! b2 0)
(test #f unbox b) (test #f unbox b)
@ -126,19 +126,19 @@
;; ---------------------------------------- ;; ----------------------------------------
(test #t chaperone?/proxy (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v))) (test #t chaperone?/impersonator (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(test #t vector? (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v))) (test #t vector? (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(test #t vector? (proxy-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v))) (test #t vector? (impersonate-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(test #t (lambda (x) (vector? x)) (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v))) (test #t (lambda (x) (vector? x)) (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(test #t (lambda (x) (vector? x)) (proxy-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v))) (test #t (lambda (x) (vector? x)) (impersonate-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(test #t chaperone?/proxy (chaperone-vector (vector-immutable 1 2 3) (lambda (b i v) v) (lambda (b i v) v))) (test #t chaperone?/impersonator (chaperone-vector (vector-immutable 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(err/rt-test (proxy-vector (vector-immutable 1 2 3) (lambda (b i v) v) (lambda (b i v) v))) (err/rt-test (impersonate-vector (vector-immutable 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(test #(1 2 3) make-reader-graph (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v))) (test #(1 2 3) make-reader-graph (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-vector proxy-vector] ([chaperone-vector impersonate-vector]
[chaperone-of? proxy-of?]) [chaperone-of? impersonator-of?])
(let* ([b (vector 1 2 3)] (let* ([b (vector 1 2 3)]
[b2 (chaperone-vector b [b2 (chaperone-vector b
(lambda (b i v) (lambda (b i v)
@ -167,8 +167,8 @@
;; test chaperone-of checks in a chaperone: ;; test chaperone-of checks in a chaperone:
(let ([b (vector 0)]) (let ([b (vector 0)])
(let ([b2 (chaperone-vector b (let ([b2 (chaperone-vector b
(lambda (b i v) #f) (lambda (b i v) #f)
(lambda (b i v) #f))]) (lambda (b i v) #f))])
(test 'ok 'bad-vector-ref (test 'ok 'bad-vector-ref
(with-handlers ([exn:fail:contract? (lambda (exn) 'ok)]) (with-handlers ([exn:fail:contract? (lambda (exn) 'ok)])
(vector-ref b2 0))) (vector-ref b2 0)))
@ -176,11 +176,11 @@
(test #f vector-ref b2 0) (test #f vector-ref b2 0)
(err/rt-test (vector-set! b2 0 0)))) (err/rt-test (vector-set! b2 0 0))))
;; no proxy-of checks in a proxy: ;; no impersonator-of checks in a impersonator:
(let ([b (vector 0)]) (let ([b (vector 0)])
(let ([b2 (proxy-vector b (let ([b2 (impersonate-vector b
(lambda (b i v) #f) (lambda (b i v) #f)
(lambda (b i v) #f))]) (lambda (b i v) #f))])
(test #f vector-ref b2 0) (test #f vector-ref b2 0)
(test (void) vector-set! b2 0 #f) (test (void) vector-set! b2 0 #f)
(test #f vector-ref b 0) (test #f vector-ref b 0)
@ -188,26 +188,26 @@
;; ---------------------------------------- ;; ----------------------------------------
(test #t chaperone?/proxy (chaperone-procedure (lambda (x) x) (lambda (y) y))) (test #t chaperone?/impersonator (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t proxy? (proxy-procedure (lambda (x) x) (lambda (y) y))) (test #t impersonator? (impersonate-procedure (lambda (x) x) (lambda (y) y)))
(test #t procedure? (chaperone-procedure (lambda (x) x) (lambda (y) y))) (test #t procedure? (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t procedure? (proxy-procedure (lambda (x) x) (lambda (y) y))) (test #t procedure? (impersonate-procedure (lambda (x) x) (lambda (y) y)))
(test #t (lambda (x) (procedure? x)) (chaperone-procedure (lambda (x) x) (lambda (y) y))) (test #t (lambda (x) (procedure? x)) (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t (lambda (x) (procedure? x)) (proxy-procedure (lambda (x) x) (lambda (y) y))) (test #t (lambda (x) (procedure? x)) (impersonate-procedure (lambda (x) x) (lambda (y) y)))
(err/rt-test (chaperone-procedure (lambda (x) x) (lambda (y z) y))) (err/rt-test (chaperone-procedure (lambda (x) x) (lambda (y z) y)))
(err/rt-test (proxy-procedure (lambda (x) x) (lambda (y z) y))) (err/rt-test (impersonate-procedure (lambda (x) x) (lambda (y z) y)))
(err/rt-test (chaperone-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y))) (err/rt-test (chaperone-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(err/rt-test (proxy-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y))) (err/rt-test (impersonate-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
(test 88 (proxy-procedure (lambda (x) x) (lambda (y) 88)) 10) (test 88 (impersonate-procedure (lambda (x) x) (lambda (y) 88)) 10)
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) 88)) 10)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) 88)) 10))
(test 89 (proxy-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10) (test 89 (impersonate-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10)
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values (lambda (z) 89) y))) 10))
;; Single argument, no post filter: ;; Single argument, no post filter:
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let* ([f (lambda (x) (list x x))] (let* ([f (lambda (x) (list x x))]
[in #f] [in #f]
[f2 (chaperone-procedure [f2 (chaperone-procedure
@ -221,8 +221,8 @@
(test 111 values in))) (test 111 values in)))
;; Multiple arguments, no post filter: ;; Multiple arguments, no post filter:
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let* ([f (lambda (x y) (list x y))] (let* ([f (lambda (x y) (list x y))]
[in #f] [in #f]
[f2 (chaperone-procedure [f2 (chaperone-procedure
@ -236,8 +236,8 @@
(test (vector 1110 1111) values in))) (test (vector 1110 1111) values in)))
;; Single argument, post filter on single value: ;; Single argument, post filter on single value:
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let* ([f (lambda (x) (list x x))] (let* ([f (lambda (x) (list x x))]
[in #f] [in #f]
[out #f] [out #f]
@ -257,8 +257,8 @@
(test '(11 11) values out))) (test '(11 11) values out)))
;; Multiple arguments, post filter on multiple values: ;; Multiple arguments, post filter on multiple values:
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let* ([f (lambda (x y z) (values y (list x z)))] (let* ([f (lambda (x y z) (values y (list x z)))]
[in #f] [in #f]
[out #f] [out #f]
@ -278,8 +278,8 @@
(test (vector 'b '(a c)) values out))) (test (vector 'b '(a c)) values out)))
;; Optional keyword arguments: ;; Optional keyword arguments:
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))] (let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f] [in #f]
[f2 (chaperone-procedure [f2 (chaperone-procedure
@ -305,8 +305,8 @@
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2))))) (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))))
;; Optional keyword arguments with result chaperone: ;; Optional keyword arguments with result chaperone:
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))] (let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f] [in #f]
[out #f] [out #f]
@ -338,8 +338,8 @@
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2))))) (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))))
;; Required keyword arguments: ;; Required keyword arguments:
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))] (let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f] [in #f]
[f2 (chaperone-procedure [f2 (chaperone-procedure
@ -365,8 +365,8 @@
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))))) (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))))
;; Required keyword arguments: ;; Required keyword arguments:
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))] (let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f] [in #f]
[out #f] [out #f]
@ -396,36 +396,36 @@
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))))) (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))))
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
(err/rt-test ((proxy-procedure (lambda (x) x) (lambda (y) (values y y))) 1)) (err/rt-test ((impersonate-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y y))) 1)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y y))) 1))
(err/rt-test ((proxy-procedure (lambda (x) x) (lambda (y) (values y y y))) 1)) (err/rt-test ((impersonate-procedure (lambda (x) x) (lambda (y) (values y y y))) 1))
;; ---------------------------------------- ;; ----------------------------------------
(define is-chaperone #t) (define is-chaperone #t)
(define is-not-chaperone #f) (define is-not-chaperone #f)
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-struct proxy-struct] ([chaperone-struct impersonate-struct]
[is-chaperone is-not-chaperone] [is-chaperone is-not-chaperone]
[chaperone?/proxy proxy?]) [chaperone?/impersonator impersonator?])
(let () (let ()
(define-values (prop:blue blue? blue-ref) (make-proxy-property 'blue)) (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue))
(define-values (prop:green green? green-ref) (make-struct-type-property 'green)) (define-values (prop:green green? green-ref) (make-struct-type-property 'green))
(define-struct a ([x #:mutable] y)) (define-struct a ([x #:mutable] y))
(define-struct (b a) ([z #:mutable])) (define-struct (b a) ([z #:mutable]))
(define-struct p (u) #:property prop:green 'green) (define-struct p (u) #:property prop:green 'green)
(define-struct (q p) (v w)) (define-struct (q p) (v w))
(test #t chaperone?/proxy (chaperone-struct (make-a 1 2) a-x (lambda (a v) v))) (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v)))
(test #t chaperone?/proxy (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v))) (test #t chaperone?/impersonator (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v)))
(when is-chaperone (when is-chaperone
(test #t chaperone?/proxy (chaperone-struct (make-p 1) green-ref (lambda (a v) v)))) (test #t chaperone?/impersonator (chaperone-struct (make-p 1) green-ref (lambda (a v) v))))
(test #t chaperone?/proxy (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue)) (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue))
(when is-chaperone (when is-chaperone
(test #t chaperone?/proxy (chaperone-struct (test #t chaperone?/impersonator (chaperone-struct
(chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue) (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue)
a-x (lambda (a v) v) a-x (lambda (a v) v)
prop:blue 'blue))) prop:blue 'blue)))
(err/rt-test (chaperone-struct (make-a 1 2) b-z (lambda (a v) v))) (err/rt-test (chaperone-struct (make-a 1 2) b-z (lambda (a v) v)))
(err/rt-test (chaperone-struct (make-p 1) a-x (lambda (a v) v))) (err/rt-test (chaperone-struct (make-p 1) a-x (lambda (a v) v)))
(err/rt-test (chaperone-struct (make-q 1 2 3) a-x (lambda (a v) v))) (err/rt-test (chaperone-struct (make-q 1 2 3) a-x (lambda (a v) v)))
@ -438,43 +438,43 @@
(chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue) (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue)
blue-ref (lambda (a v) v))) blue-ref (lambda (a v) v)))
(when is-chaperone (when is-chaperone
(let* ([a1 (make-a 1 2)] (let* ([a1 (make-a 1 2)]
[get #f] [get #f]
[set #f] [set #f]
[a2 (chaperone-struct a1 a-y (lambda (an-a v) (set! get v) v) [a2 (chaperone-struct a1 a-y (lambda (an-a v) (set! get v) v)
set-a-x! (lambda (an-a v) (set! set v) v))] set-a-x! (lambda (an-a v) (set! set v) v))]
[p1 (make-p 100)] [p1 (make-p 100)]
[p-get #f] [p-get #f]
[p2 (chaperone-struct p1 green-ref (lambda (p v) (set! p-get v) v))] [p2 (chaperone-struct p1 green-ref (lambda (p v) (set! p-get v) v))]
[a3 (chaperone-struct a1 a-x (lambda (a y) y) prop:blue 8)]) [a3 (chaperone-struct a1 a-x (lambda (a y) y) prop:blue 8)])
(test 2 a-y a1) (test 2 a-y a1)
(test #f values get) (test #f values get)
(test #f values set) (test #f values set)
(test 2 a-y a2) (test 2 a-y a2)
(test 2 values get) (test 2 values get)
(test #f values set) (test #f values set)
(test (void) set-a-x! a1 0) (test (void) set-a-x! a1 0)
(test 0 a-x a1) (test 0 a-x a1)
(test 0 a-x a2) (test 0 a-x a2)
(test 2 values get) (test 2 values get)
(test #f values set) (test #f values set)
(test (void) set-a-x! a2 10) (test (void) set-a-x! a2 10)
(test 2 values get) (test 2 values get)
(test 10 values set) (test 10 values set)
(test 10 a-x a1) (test 10 a-x a1)
(test 10 a-x a2) (test 10 a-x a2)
(test 2 a-y a1) (test 2 a-y a1)
(test 2 a-y a2) (test 2 a-y a2)
(test #t green? p1) (test #t green? p1)
(test #t green? p2) (test #t green? p2)
(test 'green green-ref p1) (test 'green green-ref p1)
(test #f values p-get) (test #f values p-get)
(test 'green green-ref p2) (test 'green green-ref p2)
(test 'green values p-get) (test 'green values p-get)
(test #f blue? a1) (test #f blue? a1)
(test #f blue? a2) (test #f blue? a2)
(test #t blue? a3) (test #t blue? a3)
(test 8 blue-ref a3))) (test 8 blue-ref a3)))
(let* ([a1 (make-b 1 2 3)] (let* ([a1 (make-b 1 2 3)]
[get #f] [get #f]
[set #f] [set #f]
@ -550,10 +550,10 @@
;; ---------------------------------------- ;; ----------------------------------------
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-struct proxy-struct]) ([chaperone-struct impersonate-struct])
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let () (let ()
(define (test-sub linear? rev?) (define (test-sub linear? rev?)
(define-struct a (x [y #:mutable]) #:property prop:procedure 0) (define-struct a (x [y #:mutable]) #:property prop:procedure 0)
@ -607,7 +607,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(let () (let ()
(define-values (prop:blue blue? blue-ref) (make-proxy-property 'blue)) (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue))
(let* ([v1 (vector 1 2 3)] (let* ([v1 (vector 1 2 3)]
[v2 (chaperone-vector v1 (lambda (vec i v) v) (lambda (vec i v) v) [v2 (chaperone-vector v1 (lambda (vec i v) v) (lambda (vec i v) v)
prop:blue 89)] prop:blue 89)]
@ -641,7 +641,7 @@
(lambda (h k) (values k (lambda (h k v) v))) (lambda (h k) (values k (lambda (h k v) v)))
(lambda (h k v) (values k v)) (lambda (h k v) (values k v))
(lambda (h k) k) (lambda (h k) k))]) (lambda (h k) k) (lambda (h k) k))])
(test #t chaperone?/proxy h) (test #t chaperone?/impersonator h)
(test #t hash? h) (test #t hash? h)
(test #t (lambda (x) (hash? x)) h))) (test #t (lambda (x) (hash? x)) h)))
(list (list
@ -651,11 +651,11 @@
(for-each (for-each
(lambda (make-hash) (lambda (make-hash)
(let ([h (proxy-hash (make-hash) (let ([h (impersonate-hash (make-hash)
(lambda (h k) (values k (lambda (h k v) v))) (lambda (h k) (values k (lambda (h k v) v)))
(lambda (h k v) (values k v)) (lambda (h k v) (values k v))
(lambda (h k) k) (lambda (h k) k))]) (lambda (h k) k) (lambda (h k) k))])
(test #t proxy? h) (test #t impersonator? h)
(test #t hash? h) (test #t hash? h)
(test #t (lambda (x) (hash? x)) h))) (test #t (lambda (x) (hash? x)) h)))
(list (list
@ -665,14 +665,14 @@
(for-each (for-each
(lambda (make-hash) (lambda (make-hash)
(err/rt-test (err/rt-test
(proxy-hash (make-hash) (impersonator-hash (make-hash)
(lambda (h k) (values k (lambda (h k v) v))) (lambda (h k) (values k (lambda (h k v) v)))
(lambda (h k v) (values k v)) (lambda (h k v) (values k v))
(lambda (h k) k) (lambda (h k) k)))) (lambda (h k) k) (lambda (h k) k))))
(list (lambda () #hash()) (lambda () #hasheq()) (lambda () #hasheqv()))) (list (lambda () #hash()) (lambda () #hasheq()) (lambda () #hasheqv())))
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-hash proxy-hash]) ([chaperone-hash impersonate-hash])
(for-each (for-each
(lambda (make-hash) (lambda (make-hash)
(let* ([h1 (make-hash)] (let* ([h1 (make-hash)]
@ -796,9 +796,9 @@
;; ---------------------------------------- ;; ----------------------------------------
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-hash proxy-hash] ([chaperone-hash impersonate-hash]
[chaperone-procedure proxy-procedure]) [chaperone-procedure impersonate-procedure])
(letrec ([wrap (letrec ([wrap
(lambda (v) (lambda (v)
(cond (cond
@ -830,11 +830,11 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Check broken key proxy: ;; Check broken key impersonator:
(let ([check (let ([check
(lambda (orig) (lambda (orig)
(let ([h (proxy-hash (let ([h (impersonate-hash
orig orig
(λ (h k) (λ (h k)
(values 'bad1 (values 'bad1
@ -930,8 +930,8 @@
;; ---------------------------------------- ;; ----------------------------------------
(as-chaperone-or-proxy (as-chaperone-or-impersonator
([chaperone-procedure proxy-procedure]) ([chaperone-procedure impersonate-procedure])
(let () (let ()
(define (check-param current-directory) (define (check-param current-directory)
(parameterize ([current-directory (current-directory)]) (parameterize ([current-directory (current-directory)])
@ -982,20 +982,20 @@
(chaperone-procedure add1 void) (chaperone-procedure add1 void)
(chaperone-procedure add1 void)) (chaperone-procedure add1 void))
(test #t equal? (test #t equal?
(proxy-procedure add1 void) (impersonate-procedure add1 void)
(chaperone-procedure add1 void)) (chaperone-procedure add1 void))
(test #t equal? (test #t equal?
(chaperone-procedure add1 void) (chaperone-procedure add1 void)
(proxy-procedure add1 void)) (impersonate-procedure add1 void))
;; ---------------------------------------- ;; ----------------------------------------
;; evt chaperones ;; evt chaperones
(test #t evt? (chaperone-evt always-evt void)) (test #t evt? (chaperone-evt always-evt void))
(test #t chaperone-of?/proxy (chaperone-evt always-evt void) always-evt) (test #t chaperone-of?/impersonator (chaperone-evt always-evt void) always-evt)
(test #f chaperone-of? (chaperone-evt always-evt void) (chaperone-evt always-evt void)) (test #f chaperone-of? (chaperone-evt always-evt void) (chaperone-evt always-evt void))
(test #t chaperone-of?/proxy (chaperone-evt (chaperone-evt always-evt void) void) always-evt) (test #t chaperone-of?/impersonator (chaperone-evt (chaperone-evt always-evt void) void) always-evt)
(test always-evt sync (chaperone-evt always-evt (lambda (e) (values e values)))) (test always-evt sync (chaperone-evt always-evt (lambda (e) (values e values))))
(test #f sync/timeout 0 (chaperone-evt never-evt (lambda (e) (values e (lambda (v) (error "bad")))))) (test #f sync/timeout 0 (chaperone-evt never-evt (lambda (e) (values e (lambda (v) (error "bad"))))))
@ -1050,7 +1050,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(let () (let ()
(define (a-proxy-of v) (a-x v)) (define (a-impersonator-of v) (a-x v))
(define a-equal+hash (list (define a-equal+hash (list
(lambda (v1 v2 equal?) (lambda (v1 v2 equal?)
(equal? (a-y v1) (a-y v2))) (equal? (a-y v1) (a-y v2)))
@ -1059,29 +1059,29 @@
(lambda (v2 hash) (lambda (v2 hash)
(hash (a-y v2))))) (hash (a-y v2)))))
(define-struct a (x y) (define-struct a (x y)
#:property prop:proxy-of a-proxy-of #:property prop:impersonator-of a-impersonator-of
#:property prop:equal+hash a-equal+hash) #:property prop:equal+hash a-equal+hash)
(define-struct (a-more a) (z)) (define-struct (a-more a) (z))
(define-struct (a-new-proxy a) () (define-struct (a-new-impersonator a) ()
#:property prop:proxy-of a-proxy-of) #:property prop:impersonator-of a-impersonator-of)
(define-struct (a-new-equal a) () (define-struct (a-new-equal a) ()
#:property prop:equal+hash a-equal+hash) #:property prop:equal+hash a-equal+hash)
(let ([a1 (make-a #f 2)]) (let ([a1 (make-a #f 2)])
(test #t equal? (make-a #f 2) a1) (test #t equal? (make-a #f 2) a1)
(test #t equal? (make-a-more #f 2 7) a1) (test #t equal? (make-a-more #f 2 7) a1)
(test #t equal? (make-a-new-proxy #f 2) a1) (test #t equal? (make-a-new-impersonator #f 2) a1)
(test #f equal? (make-a-new-equal #f 2) a1) (test #f equal? (make-a-new-equal #f 2) a1)
(test #f equal? (make-a #f 3) a1) (test #f equal? (make-a #f 3) a1)
(test #f proxy-of? (make-a #f 2) a1) (test #f impersonator-of? (make-a #f 2) a1)
(test #t proxy-of? (make-a a1 3) a1) (test #t impersonator-of? (make-a a1 3) a1)
(test #t proxy-of? (make-a-more a1 3 8) a1) (test #t impersonator-of? (make-a-more a1 3 8) a1)
(test #f chaperone-of? (make-a a1 3) a1) (test #f chaperone-of? (make-a a1 3) a1)
(test #t equal? (make-a a1 3) a1) (test #t equal? (make-a a1 3) a1)
(test #t equal? (make-a-more a1 3 9) a1) (test #t equal? (make-a-more a1 3 9) a1)
(err/rt-test (equal? (make-a 0 1) (make-a 0 1))) (err/rt-test (equal? (make-a 0 1) (make-a 0 1)))
(err/rt-test (proxy-of? (make-a-new-proxy a1 1) a1)) (err/rt-test (impersonator-of? (make-a-new-impersonator a1 1) a1))
(err/rt-test (proxy-of? (make-a-new-equal a1 1) a1)) (err/rt-test (impersonator-of? (make-a-new-equal a1 1) a1))
(err/rt-test (equal? (make-a-new-equal a1 1) a1)) (err/rt-test (equal? (make-a-new-equal a1 1) a1))
(void))) (void)))
@ -1100,9 +1100,9 @@
(define g1 (chaperone-procedure f1 wrapper)) (define g1 (chaperone-procedure f1 wrapper))
(define g2 (chaperone-procedure f2 wrapper)) (define g2 (chaperone-procedure f2 wrapper))
(define g3 (chaperone-procedure f2 wrapper)) (define g3 (chaperone-procedure f2 wrapper))
(define h1 (proxy-procedure f1 wrapper)) (define h1 (impersonate-procedure f1 wrapper))
(define h2 (proxy-procedure f2 wrapper)) (define h2 (impersonate-procedure f2 wrapper))
(define h3 (proxy-procedure f2 wrapper)) (define h3 (impersonate-procedure f2 wrapper))
(test #t chaperone-of? g1 f1) (test #t chaperone-of? g1 f1)
(test #t chaperone-of? g2 f2) (test #t chaperone-of? g2 f2)
@ -1114,10 +1114,10 @@
(test #t equal? g3 f2) (test #t equal? g3 f2)
(test #t equal? g3 g2) (test #t equal? g3 g2)
(test #t proxy-of? h1 f1) (test #t impersonator-of? h1 f1)
(test #t proxy-of? h2 f2) (test #t impersonator-of? h2 f2)
(test #t proxy-of? h3 f2) (test #t impersonator-of? h3 f2)
(test #f proxy-of? h3 h2) (test #f impersonator-of? h3 h2)
(test #t equal? h1 f1) (test #t equal? h1 f1)
(test #t equal? h2 f2) (test #t equal? h2 f2)
@ -1136,16 +1136,16 @@
;; ---------------------------------------- ;; ----------------------------------------
;; A regression test mixing `procedure-rename', ;; A regression test mixing `procedure-rename',
;; chaperones, and proxy properties: ;; chaperones, and impersonator properties:
(let () (let ()
(define (f #:key k) k) (define (f #:key k) k)
(define null-checker (define null-checker
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-vals . args) (apply values kwd-vals args)) (λ (kwds kwd-vals . args) (apply values kwd-vals args))
(λ args (apply values args)))) (λ args (apply values args))))
(define-values (proxy-prop:p p? p-ref) (make-proxy-property 'p)) (define-values (impersonator-prop:p p? p-ref) (make-impersonator-property 'p))
(define new-f (define new-f
(chaperone-procedure f null-checker proxy-prop:p #t)) (chaperone-procedure f null-checker impersonator-prop:p #t))
(test #t procedure? (procedure-rename new-f 'g))) (test #t procedure? (procedure-rename new-f 'g)))
@ -1166,14 +1166,14 @@
saved)) saved))
(values (lambda (r) r) (values (lambda (r) r)
a)) a))
proxy-prop:application-mark impersonator-prop:application-mark
(cons 'z 12))) (cons 'z 12)))
(define h (chaperone-procedure (define h (chaperone-procedure
g g
(lambda (a) (lambda (a)
(values (lambda (r) r) (values (lambda (r) r)
a)) a))
proxy-prop:application-mark impersonator-prop:application-mark
(cons 'z 9))) (cons 'z 9)))
(define i (chaperone-procedure (define i (chaperone-procedure
f f
@ -1181,12 +1181,12 @@
(set! saved (cons (continuation-mark-set-first #f 'z) (set! saved (cons (continuation-mark-set-first #f 'z)
saved)) saved))
a) a)
proxy-prop:application-mark impersonator-prop:application-mark
(cons 'z 11))) (cons 'z 11)))
(define j (chaperone-procedure (define j (chaperone-procedure
i i
(lambda (a) a) (lambda (a) a)
proxy-prop:application-mark impersonator-prop:application-mark
(cons 'z 12))) (cons 'z 12)))
(test (list 12 '(12)) g 10) (test (list 12 '(12)) g 10)
(test '(#f) values saved) (test '(#f) values saved)

4
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,7 @@
5.0.99.2
proxy => impersonator
5.0.99.1
Internal: weak boxes are cleared before non-will-like Internal: weak boxes are cleared before non-will-like
finalizers; use late-weak boxes to get the old behavior finalizers; use late-weak boxes to get the old behavior

2
src/racket/include/mzwin.def
View File

@ -536,7 +536,7 @@ EXPORTS
scheme_eqv scheme_eqv
scheme_equal scheme_equal
scheme_chaperone_of scheme_chaperone_of
scheme_proxy_of scheme_impersonator_of
scheme_equal_hash_key scheme_equal_hash_key
scheme_equal_hash_key2 scheme_equal_hash_key2
scheme_recur_equal_hash_key scheme_recur_equal_hash_key

2
src/racket/include/mzwin3m.def
View File

@ -551,7 +551,7 @@ EXPORTS
scheme_eqv scheme_eqv
scheme_equal scheme_equal
scheme_chaperone_of scheme_chaperone_of
scheme_proxy_of scheme_impersonator_of
scheme_hash_key scheme_hash_key
scheme_equal_hash_key scheme_equal_hash_key
scheme_equal_hash_key2 scheme_equal_hash_key2

2
src/racket/include/racket.exp
View File

@ -553,7 +553,7 @@ scheme_eq
scheme_eqv scheme_eqv
scheme_equal scheme_equal
scheme_chaperone_of scheme_chaperone_of
scheme_proxy_of scheme_impersonator_of
scheme_equal_hash_key scheme_equal_hash_key
scheme_equal_hash_key2 scheme_equal_hash_key2
scheme_recur_equal_hash_key scheme_recur_equal_hash_key

2
src/racket/include/racket3m.exp
View File

@ -559,7 +559,7 @@ scheme_eq
scheme_eqv scheme_eqv
scheme_equal scheme_equal
scheme_chaperone_of scheme_chaperone_of
scheme_proxy_of scheme_impersonator_of
scheme_hash_key scheme_hash_key
scheme_equal_hash_key scheme_equal_hash_key
scheme_equal_hash_key2 scheme_equal_hash_key2

50
src/racket/src/bool.c
View File

@ -47,9 +47,9 @@ static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_p (int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *proxy_p (int argc, Scheme_Object *argv[]); static Scheme_Object *impersonator_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_of (int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_of (int argc, Scheme_Object *argv[]);
static Scheme_Object *proxy_of (int argc, Scheme_Object *argv[]); static Scheme_Object *impersonator_of (int argc, Scheme_Object *argv[]);
typedef struct Equal_Info { typedef struct Equal_Info {
long depth; /* always odd, so it looks like a fixnum */ long depth; /* always odd, so it looks like a fixnum */
@ -57,13 +57,13 @@ typedef struct Equal_Info {
Scheme_Hash_Table *ht; Scheme_Hash_Table *ht;
Scheme_Object *recur; Scheme_Object *recur;
Scheme_Object *next, *next_next; Scheme_Object *next, *next_next;
int for_chaperone; /* 2 => for proxy */ int for_chaperone; /* 2 => for impersonator */
} Equal_Info; } Equal_Info;
static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql); static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
static int vector_equal (Scheme_Object *vec1, Scheme_Object *vec2, Equal_Info *eql); static int vector_equal (Scheme_Object *vec1, Scheme_Object *vec2, Equal_Info *eql);
static int struct_equal (Scheme_Object *s1, Scheme_Object *s2, Equal_Info *eql); static int struct_equal (Scheme_Object *s1, Scheme_Object *s2, Equal_Info *eql);
static Scheme_Object *apply_proxy_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj); static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj);
void scheme_init_true_false(void) void scheme_init_true_false(void)
{ {
@ -109,15 +109,15 @@ void scheme_init_bool (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("chaperone?", p, env); scheme_add_global_constant("chaperone?", p, env);
p = scheme_make_immed_prim(proxy_p, "proxy?", 1, 1); p = scheme_make_immed_prim(impersonator_p, "impersonator?", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("proxy?", p, env); scheme_add_global_constant("impersonator?", p, env);
scheme_add_global_constant("chaperone-of?", scheme_add_global_constant("chaperone-of?",
scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2), scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2),
env); env);
scheme_add_global_constant("proxy-of?", scheme_add_global_constant("impersonator-of?",
scheme_make_prim_w_arity(proxy_of, "proxy-of?", 2, 2), scheme_make_prim_w_arity(impersonator_of, "impersonator-of?", 2, 2),
env); env);
} }
@ -382,7 +382,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
return 1; return 1;
else if (eql->for_chaperone else if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj1) && SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_PROXY) && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
|| (eql->for_chaperone > 1))) { || (eql->for_chaperone > 1))) {
obj1 = ((Scheme_Chaperone *)obj1)->prev; obj1 = ((Scheme_Chaperone *)obj1)->prev;
goto top; goto top;
@ -475,19 +475,19 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
if (eql->for_chaperone == 1) if (eql->for_chaperone == 1)
procs1 = NULL; procs1 = NULL;
else else
procs1 = scheme_struct_type_property_ref(scheme_proxy_of_property, (Scheme_Object *)st1); procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1) if (procs1)
procs1 = apply_proxy_of(eql->for_chaperone, procs1, obj1); procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone) if (eql->for_chaperone)
procs2 = NULL; procs2 = NULL;
else { else {
procs2 = scheme_struct_type_property_ref(scheme_proxy_of_property, (Scheme_Object *)st2); procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2) if (procs2)
procs2 = apply_proxy_of(eql->for_chaperone, procs2, obj2); procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2);
} }
if (procs1 || procs2) { if (procs1 || procs2) {
/* proxy-of property trumps other forms of checking */ /* impersonator-of property trumps other forms of checking */
if (procs1) obj1 = procs1; if (procs1) obj1 = procs1;
if (procs2) obj2 = procs2; if (procs2) obj2 = procs2;
goto top; goto top;
@ -663,12 +663,12 @@ Scheme_Object * scheme_make_false (void)
static Scheme_Object *chaperone_p(int argc, Scheme_Object *argv[]) static Scheme_Object *chaperone_p(int argc, Scheme_Object *argv[])
{ {
return ((SCHEME_CHAPERONEP(argv[0]) return ((SCHEME_CHAPERONEP(argv[0])
&& !(SCHEME_CHAPERONE_FLAGS(((Scheme_Chaperone *)argv[0])) & SCHEME_CHAPERONE_IS_PROXY)) && !(SCHEME_CHAPERONE_FLAGS(((Scheme_Chaperone *)argv[0])) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
? scheme_true ? scheme_true
: scheme_false); : scheme_false);
} }
static Scheme_Object *proxy_p(int argc, Scheme_Object *argv[]) static Scheme_Object *impersonator_p(int argc, Scheme_Object *argv[])
{ {
return (SCHEME_CHAPERONEP(argv[0]) ? scheme_true : scheme_false); return (SCHEME_CHAPERONEP(argv[0]) ? scheme_true : scheme_false);
} }
@ -678,9 +678,9 @@ static Scheme_Object *chaperone_of(int argc, Scheme_Object *argv[])
return (scheme_chaperone_of(argv[0], argv[1]) ? scheme_true : scheme_false); return (scheme_chaperone_of(argv[0], argv[1]) ? scheme_true : scheme_false);
} }
static Scheme_Object *proxy_of(int argc, Scheme_Object *argv[]) static Scheme_Object *impersonator_of(int argc, Scheme_Object *argv[])
{ {
return (scheme_proxy_of(argv[0], argv[1]) ? scheme_true : scheme_false); return (scheme_impersonator_of(argv[0], argv[1]) ? scheme_true : scheme_false);
} }
int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2) int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
@ -698,7 +698,7 @@ int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
return is_equal(obj1, obj2, &eql); return is_equal(obj1, obj2, &eql);
} }
int scheme_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2) int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2)
{ {
Equal_Info eql; Equal_Info eql;
@ -713,7 +713,7 @@ int scheme_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2)
return is_equal(obj1, obj2, &eql); return is_equal(obj1, obj2, &eql);
} }
static Scheme_Object *apply_proxy_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj) static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
{ {
Scheme_Object *a[1], *v, *oprocs; Scheme_Object *a[1], *v, *oprocs;
@ -723,10 +723,10 @@ static Scheme_Object *apply_proxy_of(int for_chaperone, Scheme_Object *procs, Sc
if (SCHEME_FALSEP(v)) if (SCHEME_FALSEP(v))
return NULL; return NULL;
oprocs = scheme_struct_type_property_ref(scheme_proxy_of_property, v); oprocs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v);
if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs))) if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs)))
scheme_arg_mismatch((for_chaperone ? "proxy-of?" : "equal?"), scheme_arg_mismatch((for_chaperone ? "impersonator-of?" : "equal?"),
"proxy-of property procedure returned a value with a different prop:proxy-of source: ", "impersonator-of property procedure returned a value with a different prop:impersonator-of source: ",
v); v);
procs = scheme_struct_type_property_ref(scheme_equal_property, obj); procs = scheme_struct_type_property_ref(scheme_equal_property, obj);
@ -734,8 +734,8 @@ static Scheme_Object *apply_proxy_of(int for_chaperone, Scheme_Object *procs, Sc
if (procs || oprocs) if (procs || oprocs)
if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0], if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0],
SCHEME_VEC_ELS(procs)[0])) SCHEME_VEC_ELS(procs)[0]))
scheme_arg_mismatch((for_chaperone ? "proxy-of?" : "equal?"), scheme_arg_mismatch((for_chaperone ? "impersonator-of?" : "equal?"),
"proxy-of property procedure returned a value with a different prop:equal+hash source: ", "impersonator-of property procedure returned a value with a different prop:equal+hash source: ",
v); v);
return v; return v;

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

File diff suppressed because it is too large Load Diff

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

@ -174,7 +174,7 @@ static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *proxy_procedure(int argc, Scheme_Object *argv[]); static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]);
@ -530,9 +530,9 @@ scheme_init_fun (Scheme_Env *env)
"chaperone-procedure", "chaperone-procedure",
2, -1), 2, -1),
env); env);
scheme_add_global_constant("proxy-procedure", scheme_add_global_constant("impersonate-procedure",
scheme_make_prim_w_arity(proxy_procedure, scheme_make_prim_w_arity(impersonate_procedure,
"proxy-procedure", "impersonate-procedure",
2, -1), 2, -1),
env); env);
@ -4084,7 +4084,7 @@ static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])
} }
static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating, static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating,
int is_proxy, int argc, Scheme_Object *argv[]) int is_impersonator, int argc, Scheme_Object *argv[])
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0], *orig, *naya; Scheme_Object *val = argv[0], *orig, *naya;
@ -4118,8 +4118,8 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
px->props = props; px->props = props;
px->redirects = argv[1]; px->redirects = argv[1];
if (is_proxy) if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY; SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
@ -4129,9 +4129,9 @@ static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[])
return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, argc, argv); return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, argc, argv);
} }
static Scheme_Object *proxy_procedure(int argc, Scheme_Object *argv[]) static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[])
{ {
return do_chaperone_procedure("proxy-procedure", "proxying", 1, argc, argv); return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, argc, argv);
} }
static Scheme_Object *apply_chaperone_k(void) static Scheme_Object *apply_chaperone_k(void)
@ -4206,10 +4206,10 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} }
px = (Scheme_Chaperone *)o; px = (Scheme_Chaperone *)o;
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
what = "chaperone"; what = "chaperone";
else else
what = "proxy"; what = "impersonator";
/* Ensure that the original procedure accepts `argc' arguments: */ /* Ensure that the original procedure accepts `argc' arguments: */
a[0] = px->prev; a[0] = px->prev;
@ -4224,7 +4224,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} }
if (px->props) { if (px->props) {
app_mark = scheme_hash_tree_get(px->props, scheme_app_mark_proxy_property); app_mark = scheme_hash_tree_get(px->props, scheme_app_mark_impersonator_property);
/* app_mark should be (cons mark val) */ /* app_mark should be (cons mark val) */
if (app_mark && !SCHEME_PAIRP(app_mark)) if (app_mark && !SCHEME_PAIRP(app_mark))
app_mark = NULL; app_mark = NULL;
@ -4267,7 +4267,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
memmove(argv2, argv2 + 1, sizeof(Scheme_Object*)*argc); memmove(argv2, argv2 + 1, sizeof(Scheme_Object*)*argc);
} else } else
post = NULL; post = NULL;
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) { if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
for (i = 0; i < argc; i++) { for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(argv2[i], argv[i])) { if (!scheme_chaperone_of(argv2[i], argv[i])) {
if (argc == 1) if (argc == 1)
@ -4390,7 +4390,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} }
if (c == argc) { if (c == argc) {
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) { if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
for (i = 0; i < argc; i++) { for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(argv2[i], argv[i])) { if (!scheme_chaperone_of(argv2[i], argv[i])) {
if (argc == 1) if (argc == 1)

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

@ -6602,9 +6602,9 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
ref4 = jit_bgti_p(jit_forward(), JIT_R1, hi_ty); ref4 = jit_bgti_p(jit_forward(), JIT_R1, hi_ty);
} }
if (can_chaperone < 0) { if (can_chaperone < 0) {
/* Make sure it's not a proxy */ /* Make sure it's not a impersonator */
jit_ldxi_s(JIT_R1, JIT_R0, (long)&SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)0x0)); jit_ldxi_s(JIT_R1, JIT_R0, (long)&SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)0x0));
ref5 = jit_bmsi_i(jit_forward(), JIT_R1, SCHEME_CHAPERONE_IS_PROXY); ref5 = jit_bmsi_i(jit_forward(), JIT_R1, SCHEME_CHAPERONE_IS_IMPERSONATOR);
} else } else
ref5 = NULL; ref5 = NULL;
if (int_ok) { if (int_ok) {
@ -6785,7 +6785,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "chaperone?")) { } else if (IS_NAMED_PRIM(rator, "chaperone?")) {
generate_inlined_type_test(jitter, app, scheme_proc_chaperone_type, scheme_chaperone_type, -1, for_branch, branch_short, need_sync); generate_inlined_type_test(jitter, app, scheme_proc_chaperone_type, scheme_chaperone_type, -1, for_branch, branch_short, need_sync);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "proxy?")) { } else if (IS_NAMED_PRIM(rator, "impersonator?")) {
generate_inlined_type_test(jitter, app, scheme_proc_chaperone_type, scheme_chaperone_type, 0, for_branch, branch_short, need_sync); generate_inlined_type_test(jitter, app, scheme_proc_chaperone_type, scheme_chaperone_type, 0, for_branch, branch_short, need_sync);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "vector?")) { } else if (IS_NAMED_PRIM(rator, "vector?")) {

60
src/racket/src/list.c
View File

@ -90,7 +90,7 @@ static Scheme_Object *box_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *unbox (int argc, Scheme_Object *argv[]); static Scheme_Object *unbox (int argc, Scheme_Object *argv[]);
static Scheme_Object *set_box (int argc, Scheme_Object *argv[]); static Scheme_Object *set_box (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_box(int argc, Scheme_Object **argv); static Scheme_Object *impersonate_box(int argc, Scheme_Object **argv);
static Scheme_Object *make_hash(int argc, Scheme_Object *argv[]); static Scheme_Object *make_hash(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_hasheq(int argc, Scheme_Object *argv[]); static Scheme_Object *make_hasheq(int argc, Scheme_Object *argv[]);
@ -127,7 +127,7 @@ static Scheme_Object *equal_hash_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_hash2_code(int argc, Scheme_Object *argv[]); static Scheme_Object *equal_hash2_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *eqv_hash_code(int argc, Scheme_Object *argv[]); static Scheme_Object *eqv_hash_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_hash(int argc, Scheme_Object **argv); static Scheme_Object *impersonate_hash(int argc, Scheme_Object **argv);
static Scheme_Object *make_weak_box(int argc, Scheme_Object *argv[]); static Scheme_Object *make_weak_box(int argc, Scheme_Object *argv[]);
static Scheme_Object *weak_box_value(int argc, Scheme_Object *argv[]); static Scheme_Object *weak_box_value(int argc, Scheme_Object *argv[]);
@ -473,9 +473,9 @@ scheme_init_list (Scheme_Env *env)
"chaperone-box", "chaperone-box",
3, -1), 3, -1),
env); env);
scheme_add_global_constant("proxy-box", scheme_add_global_constant("impersonate-box",
scheme_make_prim_w_arity(proxy_box, scheme_make_prim_w_arity(impersonate_box,
"proxy-box", "impersonate-box",
3, -1), 3, -1),
env); env);
@ -636,9 +636,9 @@ scheme_init_list (Scheme_Env *env)
"chaperone-hash", "chaperone-hash",
5, -1), 5, -1),
env); env);
scheme_add_global_constant("proxy-hash", scheme_add_global_constant("impersonate-hash",
scheme_make_prim_w_arity(proxy_hash, scheme_make_prim_w_arity(impersonate_hash,
"proxy-hash", "impersonate-hash",
5, -1), 5, -1),
env); env);
@ -1563,7 +1563,7 @@ static Scheme_Object *chaperone_unbox(Scheme_Object *obj)
a[1] = orig; a[1] = orig;
obj = _scheme_apply(SCHEME_CAR(px->redirects), 2, a); obj = _scheme_apply(SCHEME_CAR(px->redirects), 2, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(obj, orig)) if (!scheme_chaperone_of(obj, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"unbox: chaperone produced a result: %V that is not a chaperone of the original result: %V", "unbox: chaperone produced a result: %V that is not a chaperone of the original result: %V",
@ -1603,7 +1603,7 @@ static void chaperone_set_box(Scheme_Object *obj, Scheme_Object *v)
a[1] = v; a[1] = v;
v = _scheme_apply(SCHEME_CDR(px->redirects), 2, a); v = _scheme_apply(SCHEME_CDR(px->redirects), 2, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[1])) if (!scheme_chaperone_of(v, a[1]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V", "vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
@ -1658,7 +1658,7 @@ static Scheme_Object *set_box(int c, Scheme_Object *p[])
return scheme_void; return scheme_void;
} }
static Scheme_Object *do_chaperone_box(const char *name, int is_proxy, int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_box(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0]; Scheme_Object *val = argv[0];
@ -1668,8 +1668,8 @@ static Scheme_Object *do_chaperone_box(const char *name, int is_proxy, int argc,
if (SCHEME_CHAPERONEP(val)) if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val); val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_BOXP(val) || (is_proxy && !SCHEME_MUTABLEP(val))) if (!SCHEME_BOXP(val) || (is_impersonator && !SCHEME_MUTABLEP(val)))
scheme_wrong_type(name, is_proxy ? "mutable box" : "box", 0, argc, argv); scheme_wrong_type(name, is_impersonator ? "mutable box" : "box", 0, argc, argv);
scheme_check_proc_arity(name, 2, 1, argc, argv); scheme_check_proc_arity(name, 2, 1, argc, argv);
scheme_check_proc_arity(name, 2, 2, argc, argv); scheme_check_proc_arity(name, 2, 2, argc, argv);
@ -1684,8 +1684,8 @@ static Scheme_Object *do_chaperone_box(const char *name, int is_proxy, int argc,
px->props = props; px->props = props;
px->redirects = redirects; px->redirects = redirects;
if (is_proxy) if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY; SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
@ -1695,9 +1695,9 @@ static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv)
return do_chaperone_box("chaperone-box", 0, argc, argv); return do_chaperone_box("chaperone-box", 0, argc, argv);
} }
static Scheme_Object *proxy_box(int argc, Scheme_Object **argv) static Scheme_Object *impersonate_box(int argc, Scheme_Object **argv)
{ {
return do_chaperone_box("proxy-box", 1, argc, argv); return do_chaperone_box("impersonate-box", 1, argc, argv);
} }
static int compare_equal(void *v1, void *v2) static int compare_equal(void *v1, void *v2)
@ -2335,7 +2335,7 @@ static Scheme_Object *do_map_hash_table(int argc,
v = scheme_chaperone_hash_get(chaperone, v); v = scheme_chaperone_hash_get(chaperone, v);
if (!v) if (!v)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: no value found for post-proxy key: %V", "%s: no value found for post-impersonator key: %V",
name, name,
p[0]); p[0]);
} else } else
@ -2369,7 +2369,7 @@ static Scheme_Object *do_map_hash_table(int argc,
v = scheme_chaperone_hash_get(chaperone, v); v = scheme_chaperone_hash_get(chaperone, v);
if (!v) if (!v)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: no value found for post-proxy key: %V", "%s: no value found for post-impersonator key: %V",
name, name,
p[0]); p[0]);
} else { } else {
@ -2574,7 +2574,7 @@ static Scheme_Object *hash_table_index(const char *name, int argc, Scheme_Object
obj = scheme_chaperone_hash_get(chaperone, key); obj = scheme_chaperone_hash_get(chaperone, key);
if (!obj) if (!obj)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"hash-iterate-value: no value found for post-proxy key: %V", "hash-iterate-value: no value found for post-impersonator key: %V",
key); key);
return obj; return obj;
} else } else
@ -2626,7 +2626,7 @@ static Scheme_Object *hash_table_index(const char *name, int argc, Scheme_Object
obj = scheme_chaperone_hash_get(chaperone, key); obj = scheme_chaperone_hash_get(chaperone, key);
if (!obj) if (!obj)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"hash-iterate-value: no value found for post-proxy key: %V", "hash-iterate-value: no value found for post-impersonator key: %V",
key); key);
return obj; return obj;
} else } else
@ -2663,7 +2663,7 @@ static Scheme_Object *hash_table_iterate_key(int argc, Scheme_Object *argv[])
return hash_table_index("hash-iterate-key", argc, argv, 0); return hash_table_index("hash-iterate-key", argc, argv, 0);
} }
static Scheme_Object *do_chaperone_hash(const char *name, int is_proxy, int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0]; Scheme_Object *val = argv[0];
@ -2674,9 +2674,9 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_proxy, int argc
val = SCHEME_CHAPERONE_VAL(val); val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_HASHTP(val) if (!SCHEME_HASHTP(val)
&& (is_proxy || !SCHEME_HASHTRP(val)) && (is_impersonator || !SCHEME_HASHTRP(val))
&& !SCHEME_BUCKTP(val)) && !SCHEME_BUCKTP(val))
scheme_wrong_type(name, is_proxy ? "mutable hash" : "hash", 0, argc, argv); scheme_wrong_type(name, is_impersonator ? "mutable hash" : "hash", 0, argc, argv);
scheme_check_proc_arity(name, 2, 1, argc, argv); /* ref */ scheme_check_proc_arity(name, 2, 1, argc, argv); /* ref */
scheme_check_proc_arity(name, 3, 2, argc, argv); /* set! */ scheme_check_proc_arity(name, 3, 2, argc, argv); /* set! */
scheme_check_proc_arity(name, 2, 3, argc, argv); /* remove */ scheme_check_proc_arity(name, 2, 3, argc, argv); /* remove */
@ -2698,8 +2698,8 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_proxy, int argc
px->props = props; px->props = props;
px->redirects = redirects; px->redirects = redirects;
if (is_proxy) if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY; SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
@ -2709,9 +2709,9 @@ static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv)
return do_chaperone_hash("chaperone-hash", 0, argc, argv); return do_chaperone_hash("chaperone-hash", 0, argc, argv);
} }
static Scheme_Object *proxy_hash(int argc, Scheme_Object **argv) static Scheme_Object *impersonate_hash(int argc, Scheme_Object **argv)
{ {
return do_chaperone_hash("proxy-hash", 1, argc, argv); return do_chaperone_hash("impersonate-hash", 1, argc, argv);
} }
static Scheme_Object *transfer_chaperone(Scheme_Object *chaperone, Scheme_Object *v) static Scheme_Object *transfer_chaperone(Scheme_Object *chaperone, Scheme_Object *v)
@ -2871,7 +2871,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
red, red,
cnt); cnt);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(vals[0], k)) if (!scheme_chaperone_of(vals[0], k))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a key: %V that is not a chaperone of the original key: %V", "%s: chaperone produced a key: %V that is not a chaperone of the original key: %V",
@ -2907,7 +2907,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
what = "key"; what = "key";
} }
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(o, orig)) if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a %s: %V that is not a chaperone of the original %s: %V", "%s: chaperone produced a %s: %V that is not a chaperone of the original %s: %V",

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

@ -1813,7 +1813,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
|| SAME_TYPE(scheme_always_evt_type, SCHEME_TYPE(obj)) || SAME_TYPE(scheme_always_evt_type, SCHEME_TYPE(obj))
|| SAME_TYPE(scheme_never_evt_type, SCHEME_TYPE(obj)) || SAME_TYPE(scheme_never_evt_type, SCHEME_TYPE(obj))
|| SAME_TYPE(scheme_struct_property_type, SCHEME_TYPE(obj)) || SAME_TYPE(scheme_struct_property_type, SCHEME_TYPE(obj))
|| SAME_OBJ(scheme_app_mark_proxy_property, obj))) { || SAME_OBJ(scheme_app_mark_impersonator_property, obj))) {
/* Check whether this is a global constant */ /* Check whether this is a global constant */
Scheme_Object *val; Scheme_Object *val;
val = scheme_hash_get(global_constants_ht, obj); val = scheme_hash_get(global_constants_ht, obj);

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

@ -1050,7 +1050,7 @@ XFORM_NONGCING MZ_EXTERN int scheme_eq(Scheme_Object *obj1, Scheme_Object *obj2)
XFORM_NONGCING MZ_EXTERN int scheme_eqv(Scheme_Object *obj1, Scheme_Object *obj2); XFORM_NONGCING MZ_EXTERN int scheme_eqv(Scheme_Object *obj1, Scheme_Object *obj2);
MZ_EXTERN int scheme_equal(Scheme_Object *obj1, Scheme_Object *obj2); MZ_EXTERN int scheme_equal(Scheme_Object *obj1, Scheme_Object *obj2);
MZ_EXTERN int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2); MZ_EXTERN int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2);
MZ_EXTERN int scheme_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2); MZ_EXTERN int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2);
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o); XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o);

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

@ -872,7 +872,7 @@ int (*scheme_eq)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_eqv)(Scheme_Object *obj1, Scheme_Object *obj2); int (*scheme_eqv)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_equal)(Scheme_Object *obj1, Scheme_Object *obj2); int (*scheme_equal)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_chaperone_of)(Scheme_Object *obj1, Scheme_Object *obj2); int (*scheme_chaperone_of)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_proxy_of)(Scheme_Object *obj1, Scheme_Object *obj2); int (*scheme_impersonator_of)(Scheme_Object *obj1, Scheme_Object *obj2);
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
long (*scheme_hash_key)(Scheme_Object *o); long (*scheme_hash_key)(Scheme_Object *o);
#endif #endif

2
src/racket/src/schemex.inc
View File

@ -605,7 +605,7 @@
scheme_extension_table->scheme_eqv = scheme_eqv; scheme_extension_table->scheme_eqv = scheme_eqv;
scheme_extension_table->scheme_equal = scheme_equal; scheme_extension_table->scheme_equal = scheme_equal;
scheme_extension_table->scheme_chaperone_of = scheme_chaperone_of; scheme_extension_table->scheme_chaperone_of = scheme_chaperone_of;
scheme_extension_table->scheme_proxy_of = scheme_proxy_of; scheme_extension_table->scheme_impersonator_of = scheme_impersonator_of;
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
scheme_extension_table->scheme_hash_key = scheme_hash_key; scheme_extension_table->scheme_hash_key = scheme_hash_key;
#endif #endif

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

@ -605,7 +605,7 @@
#define scheme_eqv (scheme_extension_table->scheme_eqv) #define scheme_eqv (scheme_extension_table->scheme_eqv)
#define scheme_equal (scheme_extension_table->scheme_equal) #define scheme_equal (scheme_extension_table->scheme_equal)
#define scheme_chaperone_of (scheme_extension_table->scheme_chaperone_of) #define scheme_chaperone_of (scheme_extension_table->scheme_chaperone_of)
#define scheme_proxy_of (scheme_extension_table->scheme_proxy_of) #define scheme_impersonator_of (scheme_extension_table->scheme_impersonator_of)
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
#define scheme_hash_key (scheme_extension_table->scheme_hash_key) #define scheme_hash_key (scheme_extension_table->scheme_hash_key)
#endif #endif

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

@ -384,9 +384,9 @@ THREAD_LOCAL_DECL(extern Scheme_Object *scheme_system_idle_channel);
extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property; extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
extern Scheme_Object *scheme_equal_property; extern Scheme_Object *scheme_equal_property;
extern Scheme_Object *scheme_proxy_of_property; extern Scheme_Object *scheme_impersonator_of_property;
extern Scheme_Object *scheme_app_mark_proxy_property; extern Scheme_Object *scheme_app_mark_impersonator_property;
extern Scheme_Object *scheme_reduced_procedure_struct; extern Scheme_Object *scheme_reduced_procedure_struct;
@ -763,7 +763,7 @@ Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv);
Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym); Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym);
typedef struct Scheme_Chaperone { typedef struct Scheme_Chaperone {
Scheme_Inclhash_Object iso; /* 0x1 => proxy, rather than a checking chaperone */ Scheme_Inclhash_Object iso; /* 0x1 => impersonator, rather than a checking chaperone */
Scheme_Object *val; /* root object */ Scheme_Object *val; /* root object */
Scheme_Object *prev; /* immediately chaperoned object */ Scheme_Object *prev; /* immediately chaperoned object */
Scheme_Hash_Tree *props; Scheme_Hash_Tree *props;
@ -771,7 +771,7 @@ typedef struct Scheme_Chaperone {
} Scheme_Chaperone; } Scheme_Chaperone;
#define SCHEME_CHAPERONE_FLAGS(c) MZ_OPT_HASH_KEY(&(c)->iso) #define SCHEME_CHAPERONE_FLAGS(c) MZ_OPT_HASH_KEY(&(c)->iso)
#define SCHEME_CHAPERONE_IS_PROXY 0x1 #define SCHEME_CHAPERONE_IS_IMPERSONATOR 0x1
#define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val) #define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val)

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.0.99.1" #define MZSCHEME_VERSION "5.0.99.2"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 99 #define MZSCHEME_VERSION_Z 99
#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -32,13 +32,13 @@ READ_ONLY Scheme_Object *scheme_source_property;
READ_ONLY Scheme_Object *scheme_input_port_property; READ_ONLY Scheme_Object *scheme_input_port_property;
READ_ONLY Scheme_Object *scheme_output_port_property; READ_ONLY Scheme_Object *scheme_output_port_property;
READ_ONLY Scheme_Object *scheme_equal_property; READ_ONLY Scheme_Object *scheme_equal_property;
READ_ONLY Scheme_Object *scheme_proxy_of_property; READ_ONLY Scheme_Object *scheme_impersonator_of_property;
READ_ONLY Scheme_Object *scheme_make_struct_type_proc; READ_ONLY Scheme_Object *scheme_make_struct_type_proc;
READ_ONLY Scheme_Object *scheme_current_inspector_proc; READ_ONLY Scheme_Object *scheme_current_inspector_proc;
READ_ONLY Scheme_Object *scheme_recur_symbol; READ_ONLY Scheme_Object *scheme_recur_symbol;
READ_ONLY Scheme_Object *scheme_display_symbol; READ_ONLY Scheme_Object *scheme_display_symbol;
READ_ONLY Scheme_Object *scheme_write_special_symbol; READ_ONLY Scheme_Object *scheme_write_special_symbol;
READ_ONLY Scheme_Object *scheme_app_mark_proxy_property; READ_ONLY Scheme_Object *scheme_app_mark_impersonator_property;
READ_ONLY static Scheme_Object *location_struct; READ_ONLY static Scheme_Object *location_struct;
READ_ONLY static Scheme_Object *write_property; READ_ONLY static Scheme_Object *write_property;
@ -89,7 +89,7 @@ static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_property_p(int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_property_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_proxy_of_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_impersonator_of_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_print_attribute_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_print_attribute_property_value_ok(int argc, Scheme_Object *argv[]);
static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]);
@ -167,7 +167,7 @@ static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv);
static Scheme_Struct_Type *hash_prefab(Scheme_Struct_Type *type); static Scheme_Struct_Type *hash_prefab(Scheme_Struct_Type *type);
static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_struct(int argc, Scheme_Object **argv); static Scheme_Object *impersonate_struct(int argc, Scheme_Object **argv);
static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv);
static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]); static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]);
@ -351,13 +351,13 @@ scheme_init_struct (Scheme_Env *env)
} }
{ {
guard = scheme_make_prim_w_arity(check_proxy_of_property_value_ok, guard = scheme_make_prim_w_arity(check_impersonator_of_property_value_ok,
"guard-for-prop:proxy-of", "guard-for-prop:impersonator-of",
2, 2); 2, 2);
REGISTER_SO(scheme_proxy_of_property); REGISTER_SO(scheme_impersonator_of_property);
scheme_proxy_of_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("proxy-of"), scheme_impersonator_of_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("impersonator-of"),
guard); guard);
scheme_add_global_constant("prop:proxy-of", scheme_proxy_of_property, env); scheme_add_global_constant("prop:impersonator-of", scheme_impersonator_of_property, env);
} }
{ {
@ -608,9 +608,9 @@ scheme_init_struct (Scheme_Env *env)
"struct-type-property-accessor-procedure?", "struct-type-property-accessor-procedure?",
1, 1), 1, 1),
env); env);
scheme_add_global_constant("proxy-property-accessor-procedure?", scheme_add_global_constant("impersonator-property-accessor-procedure?",
scheme_make_prim_w_arity(chaperone_prop_getter_p, scheme_make_prim_w_arity(chaperone_prop_getter_p,
"proxy-property-accessor-procedure?", "impersonator-property-accessor-procedure?",
1, 1), 1, 1),
env); env);
@ -703,9 +703,9 @@ scheme_init_struct (Scheme_Env *env)
"chaperone-struct", "chaperone-struct",
1, -1), 1, -1),
env); env);
scheme_add_global_constant("proxy-struct", scheme_add_global_constant("impersonate-struct",
scheme_make_prim_w_arity(proxy_struct, scheme_make_prim_w_arity(impersonate_struct,
"proxy-struct", "impersonate-struct",
1, -1), 1, -1),
env); env);
scheme_add_global_constant("chaperone-struct-type", scheme_add_global_constant("chaperone-struct-type",
@ -713,23 +713,23 @@ scheme_init_struct (Scheme_Env *env)
"chaperone-struct-type", "chaperone-struct-type",
1, -1), 1, -1),
env); env);
scheme_add_global_constant("make-proxy-property", scheme_add_global_constant("make-impersonator-property",
scheme_make_prim_w_arity2(make_chaperone_property, scheme_make_prim_w_arity2(make_chaperone_property,
"make-proxy-property", "make-impersonator-property",
1, 1, 1, 1,
3, 3), 3, 3),
env); env);
scheme_add_global_constant("proxy-property?", scheme_add_global_constant("impersonator-property?",
scheme_make_folding_prim(chaperone_property_p, scheme_make_folding_prim(chaperone_property_p,
"proxy-property?", "impersonator-property?",
1, 1, 1), 1, 1, 1),
env); env);
{ {
REGISTER_SO(scheme_app_mark_proxy_property); REGISTER_SO(scheme_app_mark_impersonator_property);
scheme_app_mark_proxy_property = make_chaperone_property_from_c(scheme_intern_symbol("application-mark")); scheme_app_mark_impersonator_property = make_chaperone_property_from_c(scheme_intern_symbol("application-mark"));
scheme_add_global_constant("proxy-prop:application-mark", scheme_add_global_constant("impersonator-prop:application-mark",
scheme_app_mark_proxy_property, scheme_app_mark_impersonator_property,
env); env);
} }
} }
@ -981,7 +981,7 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object
a[1] = orig; a[1] = orig;
v = _scheme_apply(red, 2, a); v = _scheme_apply(red, 2, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, orig)) if (!scheme_chaperone_of(v, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V", "%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
@ -1030,7 +1030,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
if (type == scheme_struct_property_type) if (type == scheme_struct_property_type)
who = "make-struct-type-property"; who = "make-struct-type-property";
else else
who = "make-proxy-property"; who = "make-impersonator-property";
if (!SCHEME_SYMBOLP(argv[0])) if (!SCHEME_SYMBOLP(argv[0]))
scheme_wrong_type(who, "symbol", 0, argc, argv); scheme_wrong_type(who, "symbol", 0, argc, argv);
@ -1138,7 +1138,7 @@ Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name)
Scheme_Object *scheme_chaperone_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s) Scheme_Object *scheme_chaperone_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s)
{ {
if (SCHEME_CHAPERONEP(s)) if (SCHEME_CHAPERONEP(s))
return do_chaperone_prop_accessor("proxy-property-ref", prop, s); return do_chaperone_prop_accessor("impersonator-property-ref", prop, s);
else else
return do_prop_accessor(prop, s); return do_prop_accessor(prop, s);
} }
@ -1517,20 +1517,20 @@ static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *arg
return v; return v;
} }
static Scheme_Object *check_proxy_of_property_value_ok(int argc, Scheme_Object *argv[]) static Scheme_Object *check_impersonator_of_property_value_ok(int argc, Scheme_Object *argv[])
{ {
/* This is the guard for prop:proxy-of */ /* This is the guard for prop:impersonator-of */
Scheme_Object *v; Scheme_Object *v;
v = argv[0]; v = argv[0];
if (!scheme_check_proc_arity(NULL, 1, 0, argc, argv)) { if (!scheme_check_proc_arity(NULL, 1, 0, argc, argv)) {
scheme_arg_mismatch("guard-for-prop:proxy-of", scheme_arg_mismatch("guard-for-prop:impersonator-of",
"not a procedure of arity 1: ", "not a procedure of arity 1: ",
v); v);
} }
/* Add a tag to track origin of the proxy-of property: */ /* Add a tag to track origin of the impersonator-of property: */
v = scheme_make_pair(scheme_make_symbol("tag"), v); v = scheme_make_pair(scheme_make_symbol("tag"), v);
return v; return v;
@ -1860,7 +1860,7 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in
red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i]; red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i];
o = _scheme_apply(red, 2, a); o = _scheme_apply(red, 2, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(o, orig)) if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V", "%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
@ -1905,7 +1905,7 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem
a[1] = v; a[1] = v;
v = _scheme_apply(red, 2, a); v = _scheme_apply(red, 2, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[1])) if (!scheme_chaperone_of(v, a[1]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V", "%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
@ -2377,16 +2377,16 @@ static Scheme_Object *proc_struct_type_p(int argc, Scheme_Object *argv[])
static Scheme_Object *apply_chaperones(const char *who, Scheme_Object *procs, int argc, Scheme_Object **a) static Scheme_Object *apply_chaperones(const char *who, Scheme_Object *procs, int argc, Scheme_Object **a)
{ {
Scheme_Object *v, **vals, *v1[1]; Scheme_Object *v, **vals, *v1[1];
int cnt, i, is_proxy; int cnt, i, is_impersonator;
Scheme_Thread *p; Scheme_Thread *p;
while (SCHEME_PAIRP(procs)) { while (SCHEME_PAIRP(procs)) {
v = SCHEME_CAR(procs); v = SCHEME_CAR(procs);
if (SCHEME_BOXP(v)) { if (SCHEME_BOXP(v)) {
is_proxy = 1; is_impersonator = 1;
v = SCHEME_BOX_VAL(v); v = SCHEME_BOX_VAL(v);
} else } else
is_proxy = 0; is_impersonator = 0;
v = _scheme_apply_multi(v, argc, a); v = _scheme_apply_multi(v, argc, a);
@ -2412,7 +2412,7 @@ static Scheme_Object *apply_chaperones(const char *who, Scheme_Object *procs, in
cnt, argc); cnt, argc);
} }
if (!is_proxy) { if (!is_impersonator) {
for (i = 0; i < argc; i++) { for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(vals[i], a[i])) if (!scheme_chaperone_of(vals[i], a[i]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
@ -2440,7 +2440,7 @@ static Scheme_Object *struct_info_chaperone(Scheme_Object *o, Scheme_Object *si,
if (SCHEME_VECTORP(px->redirects)) { if (SCHEME_VECTORP(px->redirects)) {
if (SCHEME_VEC_ELS(px->redirects)[1]) { if (SCHEME_VEC_ELS(px->redirects)[1]) {
proc = SCHEME_VEC_ELS(px->redirects)[1]; proc = SCHEME_VEC_ELS(px->redirects)[1];
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY) if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
proc = scheme_box(proc); proc = scheme_box(proc);
procs = scheme_make_pair(proc, procs); procs = scheme_make_pair(proc, procs);
} }
@ -2586,7 +2586,7 @@ static Scheme_Object *struct_type_info_chaperone(Scheme_Object *o, Scheme_Object
px = (Scheme_Chaperone *)o; px = (Scheme_Chaperone *)o;
if (SCHEME_PAIRP(px->redirects)) { if (SCHEME_PAIRP(px->redirects)) {
proc = SCHEME_CAR(px->redirects); proc = SCHEME_CAR(px->redirects);
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY) if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
proc = scheme_box(proc); proc = scheme_box(proc);
procs = scheme_make_pair(proc, procs); procs = scheme_make_pair(proc, procs);
} }
@ -2635,7 +2635,7 @@ static Scheme_Object *type_constr_chaperone(Scheme_Object *o, Scheme_Object *v)
px = (Scheme_Chaperone *)o; px = (Scheme_Chaperone *)o;
if (SCHEME_PAIRP(px->redirects)) { if (SCHEME_PAIRP(px->redirects)) {
proc = SCHEME_CADR(px->redirects); proc = SCHEME_CADR(px->redirects);
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY) if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
proc = scheme_box(proc); proc = scheme_box(proc);
procs = scheme_make_pair(proc, procs); procs = scheme_make_pair(proc, procs);
} }
@ -3120,14 +3120,14 @@ Scheme_Object *handle_evt_p(int argc, Scheme_Object *argv[])
return NULL; return NULL;
} }
static Scheme_Object *do_chaperone_result_guard_proc(int is_proxy, void *data, int argc, Scheme_Object *argv[]) static Scheme_Object *do_chaperone_result_guard_proc(int is_impersonator, void *data, int argc, Scheme_Object *argv[])
{ {
Scheme_Object *proc = (Scheme_Object *)data, *o, *a[1]; Scheme_Object *proc = (Scheme_Object *)data, *o, *a[1];
a[0] = argv[0]; a[0] = argv[0];
o = _scheme_apply(proc, 1, a); o = _scheme_apply(proc, 1, a);
if (!is_proxy) if (!is_impersonator)
if (!scheme_chaperone_of(o, a[0])) if (!scheme_chaperone_of(o, a[0]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"evt result chaperone: chaperone produced a value: %V that is not a chaperone of the original result: %V", "evt result chaperone: chaperone produced a value: %V that is not a chaperone of the original result: %V",
@ -3142,12 +3142,12 @@ static Scheme_Object *chaperone_result_guard_proc(void *data, int argc, Scheme_O
return do_chaperone_result_guard_proc(0, data, argc, argv); return do_chaperone_result_guard_proc(0, data, argc, argv);
} }
static Scheme_Object *proxy_result_guard_proc(void *data, int argc, Scheme_Object *argv[]) static Scheme_Object *impersonator_result_guard_proc(void *data, int argc, Scheme_Object *argv[])
{ {
return do_chaperone_result_guard_proc(1, data, argc, argv); return do_chaperone_result_guard_proc(1, data, argc, argv);
} }
static Scheme_Object *do_chaperone_guard_proc(int is_proxy, void *data, int argc, Scheme_Object *argv[]) static Scheme_Object *do_chaperone_guard_proc(int is_impersonator, void *data, int argc, Scheme_Object *argv[])
{ {
Scheme_Object *evt = SCHEME_CAR((Scheme_Object *)data); Scheme_Object *evt = SCHEME_CAR((Scheme_Object *)data);
Scheme_Object *proc = SCHEME_CDR((Scheme_Object *)data); Scheme_Object *proc = SCHEME_CDR((Scheme_Object *)data);
@ -3175,11 +3175,11 @@ static Scheme_Object *do_chaperone_guard_proc(int is_proxy, void *data, int argc
if (cnt != 2) if (cnt != 2)
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"evt %s: %V: returned %d values, expected 2", "evt %s: %V: returned %d values, expected 2",
(is_proxy ? "proxy" : "chaperone"), (is_impersonator ? "impersonator" : "chaperone"),
proc, proc,
cnt); cnt);
if (!is_proxy) if (!is_impersonator)
if (!scheme_chaperone_of(vals[0], evt)) if (!scheme_chaperone_of(vals[0], evt))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"evt chaperone: chaperone produced a value: %V that is not a chaperone of the original event: %V", "evt chaperone: chaperone produced a value: %V that is not a chaperone of the original event: %V",
@ -3188,13 +3188,13 @@ static Scheme_Object *do_chaperone_guard_proc(int is_proxy, void *data, int argc
if (!scheme_check_proc_arity(NULL, 1, 1, 1, vals)) if (!scheme_check_proc_arity(NULL, 1, 1, 1, vals))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"evt %s: expected a value of type <procedure (arity 2)> as second %s result, received: %V", "evt %s: expected a value of type <procedure (arity 2)> as second %s result, received: %V",
(is_proxy ? "proxy" : "chaperone"), (is_impersonator ? "impersonator" : "chaperone"),
(is_proxy ? "proxy" : "chaperone"), (is_impersonator ? "impersonator" : "chaperone"),
vals[1]); vals[1]);
a[0] = vals[0]; a[0] = vals[0];
o = scheme_make_closed_prim_w_arity((is_proxy o = scheme_make_closed_prim_w_arity((is_impersonator
? proxy_result_guard_proc ? impersonator_result_guard_proc
: chaperone_result_guard_proc), : chaperone_result_guard_proc),
(void *)vals[1], (void *)vals[1],
"evt-result-chaperone", "evt-result-chaperone",
@ -3209,12 +3209,12 @@ static Scheme_Object *chaperone_guard_proc(void *data, int argc, Scheme_Object *
return do_chaperone_guard_proc(0, data, argc, argv); return do_chaperone_guard_proc(0, data, argc, argv);
} }
static Scheme_Object *proxy_guard_proc(void *data, int argc, Scheme_Object *argv[]) static Scheme_Object *impersonator_guard_proc(void *data, int argc, Scheme_Object *argv[])
{ {
return do_chaperone_guard_proc(1, data, argc, argv); return do_chaperone_guard_proc(1, data, argc, argv);
} }
static Scheme_Object *do_chaperone_evt(const char *name, int is_proxy, int argc, Scheme_Object *argv[]) static Scheme_Object *do_chaperone_evt(const char *name, int is_impersonator, int argc, Scheme_Object *argv[])
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *o, *val, *a[1]; Scheme_Object *o, *val, *a[1];
@ -3231,13 +3231,13 @@ static Scheme_Object *do_chaperone_evt(const char *name, int is_proxy, int argc,
props = scheme_parse_chaperone_props(name, 2, argc, argv); props = scheme_parse_chaperone_props(name, 2, argc, argv);
o = scheme_make_pair(argv[0], argv[1]); o = scheme_make_pair(argv[0], argv[1]);
o = scheme_make_closed_prim_w_arity((is_proxy o = scheme_make_closed_prim_w_arity((is_impersonator
? proxy_guard_proc ? impersonator_guard_proc
: chaperone_guard_proc), : chaperone_guard_proc),
(void *)o, (void *)o,
(is_proxy (is_impersonator
? "evt-chaperone" ? "chaperone-evt"
: "evt-proxy"), : "impersonate-evt"),
1, 1); 1, 1);
a[0] = o; a[0] = o;
o = nack_evt(1, a); o = nack_evt(1, a);
@ -3252,8 +3252,8 @@ static Scheme_Object *do_chaperone_evt(const char *name, int is_proxy, int argc,
px->props = props; px->props = props;
px->redirects = o; px->redirects = o;
if (is_proxy) if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY; SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
@ -5121,7 +5121,7 @@ static Scheme_Object *check_exn_source_property_value_ok(int argc, Scheme_Object
/**********************************************************************/ /**********************************************************************/
static Scheme_Object *do_chaperone_struct(const char *name, int is_proxy, int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
/* (chaperone-struct v mutator/selector replacement ...) */ /* (chaperone-struct v mutator/selector replacement ...) */
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
@ -5166,15 +5166,15 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_proxy, int ar
} else if (SCHEME_TRUEP(struct_getter_p(1, a))) { } else if (SCHEME_TRUEP(struct_getter_p(1, a))) {
kind = "accessor"; kind = "accessor";
offset = 0; offset = 0;
} else if (!is_proxy && SCHEME_TRUEP(struct_prop_getter_p(1, a))) { } else if (!is_impersonator && SCHEME_TRUEP(struct_prop_getter_p(1, a))) {
kind = "struct-type property accessor"; kind = "struct-type property accessor";
offset = -1; offset = -1;
} else if (!is_proxy && SAME_OBJ(proc, struct_info_proc)) { } else if (!is_impersonator && SAME_OBJ(proc, struct_info_proc)) {
kind = "struct-info"; kind = "struct-info";
offset = -2; offset = -2;
} else { } else {
scheme_wrong_type(name, scheme_wrong_type(name,
(is_proxy (is_impersonator
? "structure accessor or structure mutator" ? "structure accessor or structure mutator"
: "structure accessor, structure mutator, struct-type property accessor, or `struct-info'"), : "structure accessor, structure mutator, struct-type property accessor, or `struct-info'"),
i, argc, argv); i, argc, argv);
@ -5228,7 +5228,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_proxy, int ar
name, name,
kind, kind, kind, kind,
a[0]); a[0]);
if (is_proxy) { if (is_impersonator) {
/* Must not be an immutable field. */ /* Must not be an immutable field. */
if (stype->immutables) { if (stype->immutables) {
if (stype->immutables[pi->field - (pi->struct_type->name_pos if (stype->immutables[pi->field - (pi->struct_type->name_pos
@ -5289,8 +5289,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_proxy, int ar
px->props = props; px->props = props;
px->redirects = redirects; px->redirects = redirects;
if (is_proxy) if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY; SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
@ -5300,12 +5300,12 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
return do_chaperone_struct("chaperone-struct", 0, argc, argv); return do_chaperone_struct("chaperone-struct", 0, argc, argv);
} }
static Scheme_Object *proxy_struct(int argc, Scheme_Object **argv) static Scheme_Object *impersonate_struct(int argc, Scheme_Object **argv)
{ {
return do_chaperone_struct("proxy-struct", 1, argc, argv); return do_chaperone_struct("impersonate-struct", 1, argc, argv);
} }
static Scheme_Object *do_chaperone_struct_type(const char *name, int is_proxy, int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_struct_type(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0]; Scheme_Object *val = argv[0];
@ -5344,8 +5344,8 @@ static Scheme_Object *do_chaperone_struct_type(const char *name, int is_proxy, i
px->prev = argv[0]; px->prev = argv[0];
px->redirects = redirects; px->redirects = redirects;
if (is_proxy) if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY; SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
@ -5368,7 +5368,7 @@ Scheme_Hash_Tree *scheme_parse_chaperone_props(const char *who, int start_at, in
while (start_at < argc) { while (start_at < argc) {
v = argv[start_at]; v = argv[start_at];
if (!SAME_TYPE(SCHEME_TYPE(v), scheme_chaperone_property_type)) if (!SAME_TYPE(SCHEME_TYPE(v), scheme_chaperone_property_type))
scheme_wrong_type(who, "proxy-property", start_at, argc, argv); scheme_wrong_type(who, "impersonator-property", start_at, argc, argv);
if (start_at + 1 >= argc) if (start_at + 1 >= argc)
scheme_arg_mismatch(who, scheme_arg_mismatch(who,

26
src/racket/src/vector.c
View File

@ -45,7 +45,7 @@ static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_vector(int argc, Scheme_Object **argv); static Scheme_Object *impersonate_vector(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]);
@ -147,9 +147,9 @@ scheme_init_vector (Scheme_Env *env)
"chaperone-vector", "chaperone-vector",
3, -1), 3, -1),
env); env);
scheme_add_global_constant("proxy-vector", scheme_add_global_constant("impersonate-vector",
scheme_make_prim_w_arity(proxy_vector, scheme_make_prim_w_arity(impersonate_vector,
"proxy-vector", "impersonate-vector",
3, -1), 3, -1),
env); env);
} }
@ -425,7 +425,7 @@ Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
red = SCHEME_CAR(px->redirects); red = SCHEME_CAR(px->redirects);
o = _scheme_apply(red, 3, a); o = _scheme_apply(red, 3, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(o, orig)) if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-ref: chaperone produced a result: %V that is not a chaperone of the original result: %V", "vector-ref: chaperone produced a result: %V that is not a chaperone of the original result: %V",
@ -480,7 +480,7 @@ void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
red = SCHEME_CDR(px->redirects); red = SCHEME_CDR(px->redirects);
v = _scheme_apply(red, 3, a); v = _scheme_apply(red, 3, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[2])) if (!scheme_chaperone_of(v, a[2]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V", "vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
@ -802,7 +802,7 @@ static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
return SCHEME_MULTIPLE_VALUES; return SCHEME_MULTIPLE_VALUES;
} }
static Scheme_Object *do_chaperone_vector(const char *name, int is_proxy, int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0]; Scheme_Object *val = argv[0];
@ -813,8 +813,8 @@ static Scheme_Object *do_chaperone_vector(const char *name, int is_proxy, int ar
val = SCHEME_CHAPERONE_VAL(val); val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_VECTORP(val) if (!SCHEME_VECTORP(val)
|| (is_proxy && !SCHEME_MUTABLEP(val))) || (is_impersonator && !SCHEME_MUTABLEP(val)))
scheme_wrong_type(name, is_proxy ? "mutable vector" : "vector", 0, argc, argv); scheme_wrong_type(name, is_impersonator ? "mutable vector" : "vector", 0, argc, argv);
scheme_check_proc_arity(name, 3, 1, argc, argv); scheme_check_proc_arity(name, 3, 1, argc, argv);
scheme_check_proc_arity(name, 3, 2, argc, argv); scheme_check_proc_arity(name, 3, 2, argc, argv);
@ -829,8 +829,8 @@ static Scheme_Object *do_chaperone_vector(const char *name, int is_proxy, int ar
px->prev = argv[0]; px->prev = argv[0];
px->redirects = redirects; px->redirects = redirects;
if (is_proxy) if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY; SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
@ -840,9 +840,9 @@ static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv)
return do_chaperone_vector("chaperone-vector", 0, argc, argv); return do_chaperone_vector("chaperone-vector", 0, argc, argv);
} }
static Scheme_Object *proxy_vector(int argc, Scheme_Object **argv) static Scheme_Object *impersonate_vector(int argc, Scheme_Object **argv)
{ {
return do_chaperone_vector("proxy-vector", 1, argc, argv); return do_chaperone_vector("impersonate-vector", 1, argc, argv);
} }
/************************************************************/ /************************************************************/