v5.0.99.2: proxy' -> impersonator'
This commit is contained in:
Matthew Flatt
parent
81488335cd
commit
7f67b6569c
|
|
@ -50,7 +50,7 @@
|
|||
(apply values res-checker kwd-vals args))
|
||||
(λ args
|
||||
(apply values res-checker args)))
|
||||
proxy-prop:contracted ctc)
|
||||
impersonator-prop:contracted ctc)
|
||||
(raise-blame-error blame val "expected a procedure"))))))
|
||||
(define ctc
|
||||
(if (and (chaperone-contract? rngs-x) ...)
|
||||
|
|
@ -60,7 +60,7 @@
|
|||
#:first-order procedure?)
|
||||
(make-contract
|
||||
#:name name
|
||||
#:projection (proj proxy-procedure)
|
||||
#:projection (proj impersonate-procedure)
|
||||
#:first-order procedure?)))
|
||||
ctc)))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -97,8 +97,8 @@ v4 todo:
|
|||
#'(p-app-x ...)
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s args)))))
|
||||
proxy-prop:contracted ctc
|
||||
proxy-prop:application-mark (cons contract-key (list p-app-x ...)))))))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark (cons contract-key (list p-app-x ...)))))))
|
||||
(define ctc
|
||||
(if (and (chaperone-contract? rngs-x) ...)
|
||||
(make-chaperone-contract
|
||||
|
|
@ -107,7 +107,7 @@ v4 todo:
|
|||
#:first-order procedure?)
|
||||
(make-contract
|
||||
#:name name
|
||||
#:projection (projection proxy-procedure)
|
||||
#:projection (projection impersonate-procedure)
|
||||
#:first-order procedure?)))
|
||||
ctc)))]))
|
||||
|
||||
|
|
@ -440,10 +440,10 @@ v4 todo:
|
|||
#:first-order ->-first-order
|
||||
#:stronger ->-stronger?))
|
||||
|
||||
(define-struct (proxy-> base->) ()
|
||||
(define-struct (impersonator-> base->) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection (->-proj proxy-procedure)
|
||||
#:projection (->-proj impersonate-procedure)
|
||||
#:name ->-name
|
||||
#:first-order ->-first-order
|
||||
#:stronger ->-stronger?))
|
||||
|
|
@ -470,9 +470,9 @@ v4 todo:
|
|||
(make-chaperone-> pre post doms/c opt-doms/c rest/c
|
||||
kwds/c mandatory-kwds opt-kwds/c optional-kwds
|
||||
rngs/c rng-any? func)
|
||||
(make-proxy-> pre post doms/c opt-doms/c rest/c
|
||||
kwds/c mandatory-kwds opt-kwds/c optional-kwds
|
||||
rngs/c rng-any? func)))))
|
||||
(make-impersonator-> pre post doms/c opt-doms/c rest/c
|
||||
kwds/c mandatory-kwds opt-kwds/c optional-kwds
|
||||
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)
|
||||
(cond
|
||||
|
|
@ -605,8 +605,8 @@ v4 todo:
|
|||
(syntax->list #'(kwd-names ...)))
|
||||
null
|
||||
(if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...))))
|
||||
proxy-prop:contracted ctc
|
||||
proxy-prop:application-mark (cons contract-key (list rng-names ...)))))])
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark (cons contract-key (list rng-names ...)))))])
|
||||
(syntax-property
|
||||
(syntax
|
||||
(build--> '->
|
||||
|
|
@ -930,8 +930,8 @@ v4 todo:
|
|||
(map list (syntax->list #'(optional-dom-kwd ...))
|
||||
(syntax->list #'(optional-dom-kwd-proj ...)))
|
||||
(if rng-ctc (syntax->list #'(rng-proj ...)) #f))
|
||||
proxy-prop:contracted ctc
|
||||
proxy-prop:application-mark (cons contract-key (list rng-proj ...))))))))))))]))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark (cons contract-key (list rng-proj ...))))))))))))]))
|
||||
|
||||
(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))
|
||||
(loop (cdr args)
|
||||
(cdr non-kwd-ctcs)))])))))))
|
||||
proxy-prop:contracted ->d-stct))))))
|
||||
impersonator-prop:contracted ->d-stct))))))
|
||||
|
||||
(define (build-values-string desc dep-pre-args)
|
||||
(cond
|
||||
|
|
@ -1377,14 +1377,14 @@ v4 todo:
|
|||
(append mandatory-kwds optional-kwds)
|
||||
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
|
||||
(λ (x y) (keyword<? (car x) (car y))))])
|
||||
(make-proxy-->d mtd?
|
||||
mandatory-dom-ctcs optional-dom-ctcs
|
||||
(map cdr kwd/ctc-pairs)
|
||||
rest-ctc pre-cond range post-cond
|
||||
(map car kwd/ctc-pairs)
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
name-wrapper)))
|
||||
(make-impersonator-->d mtd?
|
||||
mandatory-dom-ctcs optional-dom-ctcs
|
||||
(map cdr kwd/ctc-pairs)
|
||||
rest-ctc pre-cond range post-cond
|
||||
(map car kwd/ctc-pairs)
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
name-wrapper)))
|
||||
|
||||
(define (->d-name ctc)
|
||||
(let* ([counting-id 'x]
|
||||
|
|
@ -1471,10 +1471,10 @@ v4 todo:
|
|||
;; appropriately. b) might be okay, but we should think about
|
||||
;; it first. At the very least, the projection function would
|
||||
;; need to add checks in the appropriate places.
|
||||
(define-struct (proxy-->d base-->d) ()
|
||||
(define-struct (impersonator-->d base-->d) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection (->d-proj proxy-procedure)
|
||||
#:projection (->d-proj impersonate-procedure)
|
||||
#:name ->d-name
|
||||
#:first-order ->d-first-order
|
||||
#:stronger ->d-stronger?))
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@
|
|||
(box-wrapper val
|
||||
(λ (b v) (pos-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) ()
|
||||
#:property prop:chaperone-contract
|
||||
|
|
@ -90,12 +90,12 @@
|
|||
#:first-order box/c-first-order
|
||||
#:projection (ho-projection chaperone-box)))
|
||||
|
||||
(define-struct (proxy-box/c base-box/c) ()
|
||||
(define-struct (impersonator-box/c base-box/c) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name box/c-name
|
||||
#:first-order box/c-first-order
|
||||
#:projection (ho-projection proxy-box)))
|
||||
#:projection (ho-projection impersonate-box)))
|
||||
|
||||
(define-syntax (wrap-box/c stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -144,5 +144,5 @@
|
|||
[(chaperone-contract? ctc)
|
||||
(make-chaperone-box/c ctc immutable)]
|
||||
[else
|
||||
(make-proxy-box/c ctc immutable)])))
|
||||
(make-impersonator-box/c ctc immutable)])))
|
||||
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@
|
|||
contract-first-order-passes?
|
||||
|
||||
prop:contracted
|
||||
proxy-prop:contracted
|
||||
impersonator-prop:contracted
|
||||
has-contract?
|
||||
value-contract
|
||||
|
||||
|
|
@ -59,14 +59,14 @@
|
|||
|
||||
(define (has-contract? v)
|
||||
(or (has-prop:contracted? v)
|
||||
(has-proxy-prop:contracted? v)))
|
||||
(has-impersonator-prop:contracted? v)))
|
||||
|
||||
(define (value-contract v)
|
||||
(cond
|
||||
[(has-prop:contracted? v)
|
||||
(get-prop:contracted v)]
|
||||
[(has-proxy-prop:contracted? v)
|
||||
(get-proxy-prop:contracted v)]
|
||||
[(has-impersonator-prop:contracted? v)
|
||||
(get-impersonator-prop:contracted v)]
|
||||
[else #f]))
|
||||
|
||||
(define-values (prop:contracted has-prop:contracted? get-prop:contracted)
|
||||
|
|
@ -80,8 +80,8 @@
|
|||
(lambda (s) v))))])
|
||||
(values prop pred (λ (v) ((get v) v)))))
|
||||
|
||||
(define-values (proxy-prop:contracted has-proxy-prop:contracted? get-proxy-prop:contracted)
|
||||
(make-proxy-property 'proxy-prop:contracted))
|
||||
(define-values (impersonator-prop:contracted has-impersonator-prop:contracted? get-impersonator-prop:contracted)
|
||||
(make-impersonator-property 'impersonator-prop:contracted))
|
||||
|
||||
(define-syntax (any stx)
|
||||
(raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx))
|
||||
|
|
@ -339,7 +339,7 @@
|
|||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?))
|
||||
(define-struct (proxy-and/c base-and/c) ()
|
||||
(define-struct (impersonator-and/c base-and/c) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection and-proj
|
||||
|
|
@ -358,7 +358,7 @@
|
|||
(λ (x) (for/and ([pred (in-list preds)]) (pred x)))))]
|
||||
[(andmap chaperone-contract? 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 (any-projection b) any-function)
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@
|
|||
[(chaperone-contract? rng-ctc)
|
||||
(make-chaperone-hash/c dom-ctc rng-ctc immutable)]
|
||||
[else
|
||||
(make-proxy-hash/c dom-ctc rng-ctc immutable)])))
|
||||
(make-impersonator-hash/c dom-ctc rng-ctc immutable)])))
|
||||
|
||||
(define (check-hash/c ctc)
|
||||
(let ([dom-ctc (base-hash/c-dom ctc)]
|
||||
|
|
@ -180,7 +180,7 @@
|
|||
(neg-dom-proj k))
|
||||
(λ (h k)
|
||||
(pos-dom-proj k))
|
||||
proxy-prop:contracted ctc))))))))
|
||||
impersonator-prop:contracted ctc))))))))
|
||||
|
||||
(define-struct (chaperone-hash/c base-hash/c) ()
|
||||
#:omit-define-syntaxes
|
||||
|
|
@ -190,10 +190,10 @@
|
|||
#:first-order hash/c-first-order
|
||||
#:projection (ho-projection chaperone-hash)))
|
||||
|
||||
(define-struct (proxy-hash/c base-hash/c) ()
|
||||
(define-struct (impersonator-hash/c base-hash/c) ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name hash/c-name
|
||||
#:first-order hash/c-first-order
|
||||
#:projection (ho-projection proxy-hash)))
|
||||
#:projection (ho-projection impersonate-hash)))
|
||||
|
|
|
|||
|
|
@ -119,11 +119,11 @@
|
|||
[(null? (cdr ho-contracts))
|
||||
(if (chaperone-contract? (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
|
||||
(if (andmap chaperone-contract? 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)
|
||||
(let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
|
||||
|
|
@ -167,7 +167,7 @@
|
|||
#:first-order single-or/c-first-order
|
||||
#: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
|
||||
(build-contract-property
|
||||
#:projection single-or/c-projection
|
||||
|
|
@ -253,7 +253,7 @@
|
|||
#:first-order multi-or/c-first-order
|
||||
#: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
|
||||
(build-contract-property
|
||||
#:projection multi-or/c-proj
|
||||
|
|
|
|||
|
|
@ -85,7 +85,7 @@
|
|||
(elem-pos-proj val))
|
||||
(λ (vec i val)
|
||||
(elem-neg-proj val))
|
||||
proxy-prop:contracted ctc))))))))
|
||||
impersonator-prop:contracted ctc))))))))
|
||||
|
||||
(define-struct (chaperone-vectorof base-vectorof) ()
|
||||
#:property prop:chaperone-contract
|
||||
|
|
@ -94,12 +94,12 @@
|
|||
#:first-order vectorof-first-order
|
||||
#:projection (vectorof-ho-projection chaperone-vector)))
|
||||
|
||||
(define-struct (proxy-vectorof base-vectorof) ()
|
||||
(define-struct (impersonator-vectorof base-vectorof) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name vectorof-name
|
||||
#:first-order vectorof-first-order
|
||||
#:projection (vectorof-ho-projection proxy-vector)))
|
||||
#:projection (vectorof-ho-projection impersonate-vector)))
|
||||
|
||||
(define-syntax (wrap-vectorof stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -149,7 +149,7 @@
|
|||
[(chaperone-contract? ctc)
|
||||
(make-chaperone-vectorof ctc immutable)]
|
||||
[else
|
||||
(make-proxy-vectorof ctc immutable)])))
|
||||
(make-impersonator-vectorof ctc immutable)])))
|
||||
|
||||
(define/subexpression-pos-prop (vector-immutableof c)
|
||||
(vectorof c #:immutable #t))
|
||||
|
|
@ -239,7 +239,7 @@
|
|||
((vector-ref elem-pos-projs i) val))
|
||||
(λ (vec 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) ()
|
||||
#:property prop:chaperone-contract
|
||||
|
|
@ -248,12 +248,12 @@
|
|||
#:first-order vector/c-first-order
|
||||
#: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
|
||||
(build-contract-property
|
||||
#:name vector/c-name
|
||||
#: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)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -303,7 +303,7 @@
|
|||
[(andmap chaperone-contract? ctcs)
|
||||
(make-chaperone-vector/c ctcs immutable)]
|
||||
[else
|
||||
(make-proxy-vector/c ctcs immutable)])))
|
||||
(make-impersonator-vector/c ctcs immutable)])))
|
||||
|
||||
(define/subexpression-pos-prop (vector-immutable/c . args)
|
||||
(apply vector/c args #:immutable #t))
|
||||
|
|
|
|||
|
|
@ -23,22 +23,22 @@
|
|||
new:procedure->method
|
||||
new:procedure-rename
|
||||
new:chaperone-procedure
|
||||
new:proxy-procedure)
|
||||
new:impersonate-procedure)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-values (prop:keyword-proxy keyword-proxy? keyword-proxy-ref)
|
||||
(make-struct-type-property 'keyword-proxy))
|
||||
(define (keyword-procedure-proxy-of v)
|
||||
(define-values (prop:keyword-impersonator keyword-impersonator? keyword-impersonator-ref)
|
||||
(make-struct-type-property 'keyword-impersonator))
|
||||
(define (keyword-procedure-impersonator-of v)
|
||||
(cond
|
||||
[(keyword-proxy? v) ((keyword-proxy-ref v) v)]
|
||||
[(keyword-impersonator? v) ((keyword-impersonator-ref v) v)]
|
||||
[else #f]))
|
||||
|
||||
(define-values (struct:keyword-procedure mk-kw-proc keyword-procedure?
|
||||
keyword-procedure-ref keyword-procedure-set!)
|
||||
(make-struct-type 'keyword-procedure #f 4 0 #f
|
||||
(list (cons prop:checked-procedure #t)
|
||||
(cons prop:proxy-of keyword-procedure-proxy-of))
|
||||
(cons prop:impersonator-of keyword-procedure-impersonator-of))
|
||||
(current-inspector)
|
||||
#f
|
||||
'(0 1 2 3)))
|
||||
|
|
@ -131,13 +131,13 @@
|
|||
;; is used for each evaluation of a keyword lambda.)
|
||||
;; The `procedure' property is a per-type method that has exactly
|
||||
;; 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!)
|
||||
(make-struct-type (or name 'unknown)
|
||||
(if proxy?
|
||||
(if impersonator?
|
||||
(if method?
|
||||
struct:keyword-method-proxy
|
||||
struct:keyword-procedure-proxy)
|
||||
struct:keyword-method-impersonator
|
||||
struct:keyword-procedure-impersonator)
|
||||
(if method?
|
||||
struct:keyword-method
|
||||
struct:keyword-procedure))
|
||||
|
|
@ -156,26 +156,26 @@
|
|||
|
||||
|
||||
;; 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
|
||||
struct:keyword-procedure
|
||||
1 0 #f
|
||||
(list (cons prop:keyword-proxy (lambda (v) (kpp-ref v 0))))))
|
||||
(define-values (struct:keyword-method-proxy make-kmp keyword-method-proxy? kmp-ref kmp-set!)
|
||||
(list (cons prop:keyword-impersonator (lambda (v) (kpp-ref v 0))))))
|
||||
(define-values (struct:keyword-method-impersonator make-kmp keyword-method-impersonator? kmp-ref kmp-set!)
|
||||
(make-struct-type 'procedure
|
||||
struct:keyword-method
|
||||
1 0 #f
|
||||
(list (cons prop:keyword-proxy (lambda (v) (kmp-ref v 0))))))
|
||||
(define-values (struct:okpp make-optional-keyword-procedure-proxy okpp? okpp-ref okpp-set!)
|
||||
(list (cons prop:keyword-impersonator (lambda (v) (kmp-ref v 0))))))
|
||||
(define-values (struct:okpp make-optional-keyword-procedure-impersonator okpp? okpp-ref okpp-set!)
|
||||
(make-struct-type 'procedure
|
||||
struct:okp
|
||||
1 0 #f
|
||||
(list (cons prop:keyword-proxy (lambda (v) (okpp-ref v 0))))))
|
||||
(define-values (struct:okmp make-optional-keyword-method-proxy okmp? okmp-ref okmp-set!)
|
||||
(list (cons prop:keyword-impersonator (lambda (v) (okpp-ref v 0))))))
|
||||
(define-values (struct:okmp make-optional-keyword-method-impersonator okmp? okmp-ref okmp-set!)
|
||||
(make-struct-type 'procedure
|
||||
struct:okp
|
||||
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))])
|
||||
chaperone-procedure))
|
||||
|
||||
(define new:proxy-procedure
|
||||
(let ([proxy-procedure
|
||||
(define new:impersonate-procedure
|
||||
(let ([impersonate-procedure
|
||||
(lambda (proc wrap-proc . props)
|
||||
(do-chaperone-procedure #t proxy-procedure 'proxy-procedure proc wrap-proc props))])
|
||||
proxy-procedure))
|
||||
(do-chaperone-procedure #t impersonate-procedure 'impersonate-procedure proc wrap-proc props))])
|
||||
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))
|
||||
(not (procedure? wrap-proc))
|
||||
;; if any bad prop, let `chaperone-procedure' complain
|
||||
(let loop ([props props])
|
||||
(cond
|
||||
[(null? props) #f]
|
||||
[(proxy-property? (car props))
|
||||
[(impersonator-property? (car props))
|
||||
(let ([props (cdr props)])
|
||||
(or (null? props)
|
||||
(loop (cdr props))))]
|
||||
|
|
@ -1225,7 +1225,7 @@
|
|||
name
|
||||
(format
|
||||
"~a procedure requires more keywords than original procedure: "
|
||||
(if is-proxy? "proxying" "chaperoning"))
|
||||
(if is-impersonator? "impersonating" "chaperoning"))
|
||||
proc))
|
||||
(unless (or (not b-allow)
|
||||
(and a-allow
|
||||
|
|
@ -1234,7 +1234,7 @@
|
|||
name
|
||||
(format
|
||||
"~a procedure does not accept all keywords of original procedure: "
|
||||
(if is-proxy? "proxying" "chaperoning"))
|
||||
(if is-impersonator? "impersonating" "chaperoning"))
|
||||
proc))
|
||||
(let* ([kw-chaperone
|
||||
(let ([p (keyword-procedure-proc wrap-proc)])
|
||||
|
|
@ -1266,7 +1266,7 @@
|
|||
wrap-proc))
|
||||
(for-each
|
||||
(lambda (kw new-arg arg)
|
||||
(unless is-proxy?
|
||||
(unless is-impersonator?
|
||||
(unless (chaperone-of? new-arg arg)
|
||||
(raise-mismatch-error
|
||||
'|keyword procedure chaperone|
|
||||
|
|
@ -1283,10 +1283,10 @@
|
|||
[new-proc
|
||||
(cond
|
||||
[(okp? proc)
|
||||
(if is-proxy?
|
||||
(if is-impersonator?
|
||||
((if (okm? proc)
|
||||
make-optional-keyword-method-proxy
|
||||
make-optional-keyword-procedure-proxy)
|
||||
make-optional-keyword-method-impersonator
|
||||
make-optional-keyword-procedure-impersonator)
|
||||
(keyword-procedure-checker proc)
|
||||
(chaperone-procedure (keyword-procedure-proc proc)
|
||||
kw-chaperone)
|
||||
|
|
@ -1305,7 +1305,7 @@
|
|||
(chaperone-procedure proc
|
||||
(okp-ref wrap-proc 0)))))]
|
||||
[else
|
||||
(if is-proxy?
|
||||
(if is-impersonator?
|
||||
;; Constructor must be from `make-required':
|
||||
(let* ([name+fail (keyword-procedure-name+fail proc)]
|
||||
[mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc) #t)])
|
||||
|
|
|
|||
|
|
@ -126,11 +126,11 @@
|
|||
(rename new:procedure->method procedure->method)
|
||||
(rename new:procedure-rename procedure-rename)
|
||||
(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
|
||||
procedure-arity procedure-reduce-arity raise-arity-error
|
||||
procedure->method procedure-rename
|
||||
chaperone-procedure proxy-procedure)
|
||||
chaperone-procedure impersonate-procedure)
|
||||
(all-from "reqprov.rkt")
|
||||
(all-from "for.rkt")
|
||||
(all-from "kernstruct.rkt")
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ strings, byte strings, numbers, pairs, mutable pairs, vectors, boxes, hash
|
|||
tables, and inspectable structures. In the last five cases, equality
|
||||
is recursively defined; if both @scheme[v1] and @scheme[v2] contain
|
||||
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[
|
||||
(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
|
||||
@scheme[eq?], and @scheme[equal-hash-code] and
|
||||
@scheme[equal-secondary-hash-code] results are based only on
|
||||
@scheme[eq-hash-code]. If a structure has a @racket[prop:proxy-of]
|
||||
property, then the @racket[prop:proxy-of] property takes precedence over
|
||||
@scheme[eq-hash-code]. If a structure has a @racket[prop:impersonator-of]
|
||||
property, then the @racket[prop:impersonator-of] property takes precedence over
|
||||
@racket[prop:equal+hash] if the property value's procedure returns a
|
||||
non-@racket[#f] value when applied to the structure.
|
||||
|
||||
|
|
|
|||
|
|
@ -8,16 +8,16 @@
|
|||
@(define-syntax-rule (operations 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
|
||||
redirects certain of the value's operations. Proxies apply only to procedures,
|
||||
An @deftech{impersonator} is a wrapper for a value where the wrapper
|
||||
redirects certain of the value's operations. Impersonators apply only to procedures,
|
||||
@tech{structures} for which an accessor or mutator is available,
|
||||
@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.
|
||||
|
||||
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,
|
||||
raising an exception) or chaperoning values supplied to or produced by
|
||||
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
|
||||
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
|
||||
value for any another. A proxy cannot be applied to an immutable value
|
||||
A non-@tech{chaperone} @tech{impersonator}, in contrast, can refine an operation to swap one
|
||||
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
|
||||
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
|
||||
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
|
||||
the proxy:
|
||||
the impersonator:
|
||||
|
||||
@operations[@t{a structure-field accesor}
|
||||
@t{a structure-field mutator}
|
||||
|
|
@ -47,50 +47,50 @@ the proxy:
|
|||
hash-ref hash-set hash-set! hash-remove hash-remove!]
|
||||
|
||||
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-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
|
||||
proxy can include @deftech{proxy properties} for a proxied
|
||||
value. A @tech{proxy property} is similar to a @tech{structure
|
||||
type property}, but it applies to chaperones instead of structure
|
||||
impersonator can include @deftech{impersonator properties} for an impersonated
|
||||
value. An @tech{impersonator property} is similar to a @tech{structure
|
||||
type property}, but it applies to impersonators instead of structure
|
||||
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
|
||||
treat proxies the same as unproxied values. In rare cases,
|
||||
@scheme[proxy?] may be needed to guard against redirection by a
|
||||
proxy of an operation to an arbitrary procedure.}
|
||||
Programs and libraries generally should avoid @scheme[impersonator?] and
|
||||
treat impersonators the same as non-impersonator values. In rare cases,
|
||||
@scheme[impersonator?] may be needed to guard against redirection by an
|
||||
impersonator of an operation to an arbitrary procedure.}
|
||||
|
||||
|
||||
@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
|
||||
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
|
||||
proxies to @scheme[v2].
|
||||
impersonators to @scheme[v2].
|
||||
|
||||
For values that include no proxies, @scheme[v1] and @scheme[v2] can
|
||||
be considered proxies of each other if they are @scheme[equal?].
|
||||
For values that include no impersonators, @scheme[v1] and @scheme[v2] can
|
||||
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
|
||||
@scheme[v1] through one of the proxy constructors (e.g.,
|
||||
@scheme[proxy-procedure] or @racket[chaperone-procedure]).
|
||||
@scheme[v1] through one of the impersonator constructors (e.g.,
|
||||
@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?]{
|
||||
|
|
@ -109,16 +109,16 @@ from @scheme[v1] through one of the chaperone constructors (e.g.,
|
|||
@scheme[chaperone-procedure]).}
|
||||
|
||||
@; ------------------------------------------------------------
|
||||
@section{Proxy Constructors}
|
||||
@section{Impersonator Constructors}
|
||||
|
||||
@defproc[(proxy-procedure [proc procedure?]
|
||||
[wrapper-proc procedure?]
|
||||
[prop proxy-property?]
|
||||
[prop-val any] ... ...)
|
||||
(and/c procedure? proxy?)]{
|
||||
@defproc[(impersonate-procedure [proc procedure?]
|
||||
[wrapper-proc procedure?]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(and/c procedure? impersonator?)]{
|
||||
|
||||
Returns a proxied procedure that has the same arity, name, and
|
||||
other attributes as @scheme[proc]. When the proxied procedure is
|
||||
Returns an impersonator procedure that has the same arity, name, and
|
||||
other attributes as @scheme[proc]. When the impersonator procedure is
|
||||
applied, the arguments are first passed to @scheme[wrapper-proc], and
|
||||
then the results from @scheme[wrapper-proc] are passed to
|
||||
@scheme[proc]. The @scheme[wrapper-proc] can also supply a procedure
|
||||
|
|
@ -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
|
||||
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
|
||||
procedure to proxy @scheme[proc]'s result), then @scheme[proc] is
|
||||
called in @tech{tail position} with respect to the call to the proxy.
|
||||
procedure to impersonator @scheme[proc]'s result), then @scheme[proc] is
|
||||
called in @tech{tail position} with respect to the call to the impersonator.
|
||||
|
||||
For applications that include keyword arguments, @scheme[wrapper-proc]
|
||||
must return an additional value before any other values but after the
|
||||
result-proxying procedure (if any). The additional value must be a
|
||||
list of proxys of the keyword arguments that were supplied to the
|
||||
proxied procedure (i.e., not counting optional arguments that were
|
||||
result-impersonating procedure (if any). The additional value must be a
|
||||
list of replacements for the keyword arguments that were supplied to the
|
||||
impersonator (i.e., not counting optional arguments that were
|
||||
not supplied). The arguments must be ordered according to the sorted
|
||||
order of the supplied arguments' keywords.
|
||||
|
||||
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
|
||||
to @scheme[procedure-proxy] must be even) add proxy properties
|
||||
or override proxy-property values of @scheme[proc].
|
||||
to @scheme[procedure-impersonator] must be even) add impersonator properties
|
||||
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]
|
||||
is wrapped with @racket[with-continuation-mark] using @racket[(car
|
||||
prop-val)] as the mark key and @racket[(cdr prop-val)] as the mark
|
||||
value. In addition, if @racket[continuation-mark-set-first] with
|
||||
@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
|
||||
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]).}
|
||||
|
||||
|
||||
@defproc[(proxy-struct [v any/c]
|
||||
[orig-proc (or/c struct-accessor-procedure?
|
||||
struct-mutator-procedure?)]
|
||||
[redirect-proc procedure?] ... ...
|
||||
[prop proxy-property?]
|
||||
[prop-val any] ... ...)
|
||||
@defproc[(impersonate-struct [v any/c]
|
||||
[orig-proc (or/c struct-accessor-procedure?
|
||||
struct-mutator-procedure?)]
|
||||
[redirect-proc procedure?] ... ...
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
any/c]{
|
||||
|
||||
Returns a proxied value like @scheme[v], but with certain
|
||||
operations on the proxied redirected. The @scheme[orig-proc]s
|
||||
Returns an impersonator of @scheme[v], with redirect certain
|
||||
operations on the impersonated value. The @scheme[orig-proc]s
|
||||
indicate the operations to redirect, and the corresponding
|
||||
@scheme[redirect-proc]s supply the redirections.
|
||||
|
||||
|
|
@ -183,14 +183,14 @@ The protocol for a @scheme[redirect-proc] depends on the corresponding
|
|||
|
||||
@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
|
||||
@scheme[_field-v] that @scheme[orig-proc] produces for
|
||||
@scheme[v]; it must return a replacement for
|
||||
@scheme[_field-v]. The corresponding field must not be
|
||||
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]
|
||||
supplied to the mutator; it must return a replacement for
|
||||
@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
|
||||
to @scheme[proxy-procedure] must be odd) add proxy properties
|
||||
or override proxy-property values of @scheme[v].}
|
||||
to @scheme[impersonate-struct] must be odd) add impersonator properties
|
||||
or override impersonator-property values of @scheme[v].}
|
||||
|
||||
@defproc[(proxy-vector [vec (and/c vector? (not/c immutable?))]
|
||||
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
|
||||
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
|
||||
[prop proxy-property?]
|
||||
[prop-val any] ... ...)
|
||||
(and/c vector? proxy?)]{
|
||||
@defproc[(impersonate-vector [vec (and/c vector? (not/c immutable?))]
|
||||
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
|
||||
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(and/c vector? impersonator?)]{
|
||||
|
||||
Returns a proxied value like @scheme[vec], but with
|
||||
@scheme[vector-ref] and @scheme[vector-set!] operations on the
|
||||
proxied vector redirected.
|
||||
Returns an impersonator of @scheme[vec], which redirects the
|
||||
@scheme[vector-ref] and @scheme[vector-set!] operations.
|
||||
|
||||
The @scheme[ref-proc] must accept @scheme[vec], an index passed to
|
||||
@scheme[vector-ref], and the value that @scheme[vector-ref] on
|
||||
@scheme[vec] produces for the given index; it must produce a
|
||||
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
|
||||
@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.
|
||||
|
||||
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
|
||||
to @scheme[proxy-vector] must be odd) add proxy properties
|
||||
or override proxy-property values of @scheme[vec].}
|
||||
to @scheme[impersonate-vector] must be odd) add impersonator properties
|
||||
or override impersonator-property values of @scheme[vec].}
|
||||
|
||||
@defproc[(proxy-box [box (and/c box? (not/c immutable?))]
|
||||
[unbox-proc (box? any/c . -> . any/c)]
|
||||
[set-proc (box? any/c . -> . any/c)]
|
||||
[prop proxy-property?]
|
||||
[prop-val any] ... ...)
|
||||
(and/c box? proxy?)]{
|
||||
@defproc[(impersonate-box [box (and/c box? (not/c immutable?))]
|
||||
[unbox-proc (box? any/c . -> . any/c)]
|
||||
[set-proc (box? any/c . -> . any/c)]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(and/c box? impersonator?)]{
|
||||
|
||||
Returns a proxied value like @scheme[bx], but with
|
||||
@scheme[unbox] and @scheme[set-box!] operations on the
|
||||
proxied box redirected.
|
||||
Returns an impersonator of @scheme[bx], which redirects the
|
||||
@scheme[unbox] and @scheme[set-box!] operations.
|
||||
|
||||
The @scheme[unbox-proc] must accept @scheme[bx] and the value that
|
||||
@scheme[unbox] on @scheme[bx] produces index; it must produce a replacement
|
||||
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
|
||||
@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.
|
||||
|
||||
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
|
||||
to @scheme[proxy-box] must be odd) add proxy properties
|
||||
or override proxy-property values of @scheme[bx].}
|
||||
to @scheme[impersonate-box] must be odd) add impersonator properties
|
||||
or override impersonator-property values of @scheme[bx].}
|
||||
|
||||
|
||||
@defproc[(proxy-hash [hash (and/c hash? (not/c immutable?))]
|
||||
[ref-proc (hash? any/c . -> . (values
|
||||
any/c
|
||||
(hash? any/c any/c . -> . any/c)))]
|
||||
[set-proc (hash? any/c any/c . -> . (values any/c any/c))]
|
||||
[remove-proc (hash? any/c . -> . any/c)]
|
||||
[key-proc (hash? any/c . -> . any/c)]
|
||||
[prop proxy-property?]
|
||||
[prop-val any] ... ...)
|
||||
(and/c hash? proxy?)]{
|
||||
@defproc[(impersonate-hash [hash (and/c hash? (not/c immutable?))]
|
||||
[ref-proc (hash? any/c . -> . (values
|
||||
any/c
|
||||
(hash? any/c any/c . -> . any/c)))]
|
||||
[set-proc (hash? any/c any/c . -> . (values any/c any/c))]
|
||||
[remove-proc (hash? any/c . -> . any/c)]
|
||||
[key-proc (hash? any/c . -> . any/c)]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(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
|
||||
applicable) and @scheme[hash-remove] or @scheme[hash-remove!] (as
|
||||
application) operations on the proxied hash table redirected. When
|
||||
@scheme[hash-set] or @scheme[hash-remove] is used on a proxied hash
|
||||
table, the resulting hash table is given all of the proxys of the
|
||||
given hash table. In addition, operations like
|
||||
applicable), and @scheme[hash-remove] or @scheme[hash-remove!] (as
|
||||
application) operations. When
|
||||
@scheme[hash-set] or @scheme[hash-remove] is used on an impersonator of a hash
|
||||
table, the result is an impersonator with the same redirecting procedures.
|
||||
In addition, operations like
|
||||
@scheme[hash-iterate-key] or @scheme[hash-map], which extract
|
||||
keys from the table, use @scheme[key-proc] to filter keys extracted
|
||||
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
|
||||
case the procedure is called with @scheme[hash], the previously
|
||||
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
|
||||
@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
|
||||
replacement for the key, which is used with @scheme[hash-remove!] or
|
||||
@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
|
||||
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].
|
||||
|
||||
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
|
||||
to @scheme[proxy-hash] must be odd) add proxy properties
|
||||
or override proxy-property values of @scheme[hash].}
|
||||
to @scheme[impersonate-hash] must be odd) add impersonator properties
|
||||
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
|
||||
supplies a procedure for extracting a proxied value from a structure
|
||||
that represents a proxy. The property is used for @racket[proxy-of]
|
||||
supplies a procedure for extracting an impersonated value from a structure
|
||||
that represents an impersonator. The property is used for @racket[impersonator-of]
|
||||
as well as @racket[equal?].
|
||||
|
||||
The property value must be a procedure of one argument, which is a
|
||||
structure whose structure type has the property. The result can be
|
||||
@scheme[#f] to indicate the structure does not represent a proxy,
|
||||
otherwise the result is a value for which the original structure is a
|
||||
proxy (so the original structure is a @racket[proxy-of?] and it is
|
||||
@scheme[#f] to indicate the structure does not represent an impersonator,
|
||||
otherwise the result is a value for which the original structure is an
|
||||
impersonator (so the original structure is an @racket[impersonator-of?] and
|
||||
@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
|
||||
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}
|
||||
|
||||
@defproc[(chaperone-procedure [proc procedure?]
|
||||
[wrapper-proc procedure?]
|
||||
[prop proxy-property?]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(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
|
||||
chaperone of (in the sense of @scheme[chaperone-of?]) the supplied
|
||||
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
|
||||
result-chaperoning procedure (if any). The additional value must be a
|
||||
list of chaperones of the keyword arguments that were supplied to the
|
||||
chaperoned procedure (i.e., not counting optional arguments that were
|
||||
chaperone procedure (i.e., not counting optional arguments that were
|
||||
not supplied). The arguments must be ordered according to the sorted
|
||||
order of the supplied arguments' keywords.}
|
||||
|
||||
|
|
@ -366,18 +364,18 @@ order of the supplied arguments' keywords.}
|
|||
struct-type-property-accessor-procedure?
|
||||
(one-of/c struct-info))]
|
||||
[redirect-proc procedure?] ... ...
|
||||
[prop proxy-property?]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
any/c]{
|
||||
|
||||
Like @racket[proxy-struct], but with the following refinements:
|
||||
Like @racket[impersonate-struct], but with the following refinements:
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{With a structure-field accessor as @racket[orig-proc],
|
||||
@scheme[redirect-proc] must accept two arguments, @scheme[v] and
|
||||
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.}
|
||||
|
||||
@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],
|
||||
@scheme[redirect-proc] must accept two arguments, @scheme[v] and
|
||||
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].}
|
||||
|
||||
@item{With @scheme[struct-info] as @racket[orig-proc], the
|
||||
|
|
@ -408,11 +406,11 @@ unchaperoned.}
|
|||
@defproc[(chaperone-vector [vec vector?]
|
||||
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
|
||||
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
|
||||
[prop proxy-property?]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(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
|
||||
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
|
||||
|
|
@ -421,7 +419,7 @@ not be used if @scheme[vec] is immutable.}
|
|||
@defproc[(chaperone-box [bx box?]
|
||||
[unbox-proc (box? any/c . -> . any/c)]
|
||||
[set-proc (box? any/c . -> . any/c)]
|
||||
[prop proxy-property?]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(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))]
|
||||
[remove-proc (hash? any/c . -> . any/c)]
|
||||
[key-proc (hash? any/c . -> . any/c)]
|
||||
[prop proxy-property?]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(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
|
||||
return a found value or a chaperone of the value. The
|
||||
@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?]
|
||||
[make-constructor-proc (procedure? . -> . procedure?)]
|
||||
[guard-proc procedure?]
|
||||
[prop proxy-property?]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(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.
|
||||
|
||||
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
|
||||
to @scheme[chaperone-struct-type] must be even) add proxy properties
|
||||
or override proxy-property values of @scheme[struct-type].}
|
||||
to @scheme[chaperone-struct-type] must be even) add impersonator properties
|
||||
or override impersonator-property values of @scheme[struct-type].}
|
||||
|
||||
@defproc[(chaperone-evt [evt evt?]
|
||||
[proc (evt? . -> . (values evt? (any/c . -> . any/c)))]
|
||||
[prop proxy-property?]
|
||||
[prop impersonator-property?]
|
||||
[prop-val any] ... ...)
|
||||
(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.
|
||||
|
||||
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
|
||||
to @scheme[chaperone-struct-type] must be even) add proxy properties
|
||||
or override proxy-property values of @scheme[evt].}
|
||||
to @scheme[chaperone-evt] must be even) add impersonator properties
|
||||
or override impersonator-property values of @scheme[evt].}
|
||||
|
||||
@; ------------------------------------------------------------
|
||||
@section{Proxy Properties}
|
||||
@section{Impersonator Properties}
|
||||
|
||||
@defproc[(make-proxy-property [name symbol?])
|
||||
(values proxy-property?
|
||||
@defproc[(make-impersonator-property [name symbol?])
|
||||
(values impersonator-property?
|
||||
(-> 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[
|
||||
|
||||
@item{a @deftech{proxy property descriptor}, for use with
|
||||
@scheme[chaperone-procedure], @scheme[chaperone-struct], and
|
||||
other chaperone constructors;}
|
||||
@item{an @deftech{impersonator property descriptor}, for use with
|
||||
@scheme[impersonate-procedure], @scheme[chaperone-procedure],
|
||||
and other impersonator constructors;}
|
||||
|
||||
@item{a @deftech{proxy property predicate} procedure, which takes
|
||||
an arbitrary value and returns @scheme[#t] if the value is a
|
||||
chaperone with a value for the property, @scheme[#f]
|
||||
@item{an @deftech{impersonator property predicate} procedure, which takes
|
||||
an arbitrary value and returns @scheme[#t] if the value is an
|
||||
impersonator with a value for the property, @scheme[#f]
|
||||
otherwise;}
|
||||
|
||||
@item{an @deftech{proxy property accessor} procedure, which
|
||||
returns the value associated with a chaperone for the property;
|
||||
if a value given to the accessor is not a chaperone or does not
|
||||
have a value for the property (ie if the corresponding chaperone
|
||||
@item{an @deftech{impersonator property accessor} procedure, which
|
||||
returns the value associated with an impersonator for the property;
|
||||
if a value given to the accessor is not an impersonator or does not
|
||||
have a value for the property (i.e. if the corresponding impersonator
|
||||
property predicate returns @racket[#f]), the accessor raises
|
||||
@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.}
|
||||
|
||||
@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
|
||||
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].}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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?]{
|
||||
|
|
@ -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
|
||||
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?]{
|
||||
|
|
@ -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
|
||||
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?]{
|
||||
|
|
@ -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
|
||||
@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
|
||||
@tech{chaperone} or @tech{proxy} of the input for mutable hash tables.
|
||||
@tech{chaperone} or @tech{impersonator} of the input for mutable hash tables.
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -194,8 +194,8 @@ Unsafe variants of @scheme[car], @scheme[cdr], @scheme[mcar],
|
|||
@deftogether[(
|
||||
@defproc[(unsafe-unbox [b box?]) fixnum?]
|
||||
@defproc[(unsafe-set-box! [b box?] [k fixnum?]) void?]
|
||||
@defproc[(unsafe-unbox* [v (and/c box? (not/c chaperone?))]) any/c]
|
||||
@defproc[(unsafe-set-box*! [v (and/c box? (not/c chaperone?))] [val any/c]) void?]
|
||||
@defproc[(unsafe-unbox* [v (and/c box? (not/c impersonator?))]) any/c]
|
||||
@defproc[(unsafe-set-box*! [v (and/c box? (not/c impersonator?))] [val any/c]) void?]
|
||||
)]{
|
||||
|
||||
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-ref [v vector?] [k fixnum?]) any/c]
|
||||
@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*-ref [v (and/c vector? (not/c chaperone?))] [k fixnum?]) any/c]
|
||||
@defproc[(unsafe-vector*-set! [v (and/c vector? (not/c chaperone?))] [k fixnum?] [val any/c]) void?]
|
||||
@defproc[(unsafe-vector*-length [v (and/c vector? (not/c impersonator?))]) fixnum?]
|
||||
@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 impersonator?))] [k fixnum?] [val any/c]) void?]
|
||||
)]{
|
||||
|
||||
Unsafe versions of @scheme[vector-length], @scheme[vector-ref], and
|
||||
|
|
@ -284,8 +284,8 @@ Unsafe versions of @scheme[u16vector-ref] and
|
|||
@deftogether[(
|
||||
@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*-ref [v (not/c chaperone?)] [k fixnum?]) any/c]
|
||||
@defproc[(unsafe-struct*-set! [v (not/c chaperone?)] [k fixnum?] [val any/c]) void?]
|
||||
@defproc[(unsafe-struct*-ref [v (not/c impersonator?)] [k fixnum?]) any/c]
|
||||
@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
|
||||
|
|
|
|||
|
|
@ -5,41 +5,41 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (chaperone-of?/proxy a b)
|
||||
(test #t proxy-of? a b)
|
||||
(define (chaperone-of?/impersonator a b)
|
||||
(test #t impersonator-of? a b)
|
||||
(chaperone-of? a b))
|
||||
|
||||
(define (chaperone?/proxy a)
|
||||
(test #t proxy? a)
|
||||
(define (chaperone?/impersonator a)
|
||||
(test #t impersonator? 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 ...)
|
||||
body ...)
|
||||
(list orig proxy) ...))
|
||||
(list orig impersonator) ...))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(test #t chaperone-of?/proxy 10 10)
|
||||
(test #t chaperone-of?/proxy '(10) '(10))
|
||||
(test #t chaperone-of?/proxy '#(1 2 3) '#(1 2 3))
|
||||
(test #t chaperone-of?/proxy '#&(1 2 3) '#&(1 2 3))
|
||||
(test #t chaperone-of?/impersonator 10 10)
|
||||
(test #t chaperone-of?/impersonator '(10) '(10))
|
||||
(test #t chaperone-of?/impersonator '#(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 #t chaperone-of?/proxy
|
||||
(test #f chaperone-of?/impersonator (make-string 1 #\x) (make-string 1 #\x))
|
||||
(test #t chaperone-of?/impersonator
|
||||
(string->immutable-string (make-string 1 #\x))
|
||||
(string->immutable-string (make-string 1 #\x)))
|
||||
|
||||
(define (either-chaperone-of?/proxy a b)
|
||||
(or (chaperone-of?/proxy a b)
|
||||
(chaperone-of?/proxy b a)))
|
||||
(test #f either-chaperone-of?/proxy
|
||||
(define (either-chaperone-of?/impersonator a b)
|
||||
(or (chaperone-of?/impersonator a b)
|
||||
(chaperone-of?/impersonator b a)))
|
||||
(test #f either-chaperone-of?/impersonator
|
||||
(string->immutable-string "x")
|
||||
(make-string 1 #\x))
|
||||
(test #f either-chaperone-of?/proxy
|
||||
(test #f either-chaperone-of?/impersonator
|
||||
'#(1 2 3)
|
||||
(vector 1 2 3))
|
||||
(test #f either-chaperone-of?/proxy
|
||||
(test #f either-chaperone-of?/impersonator
|
||||
'#&17
|
||||
(box 17))
|
||||
|
||||
|
|
@ -50,19 +50,19 @@
|
|||
(define-struct q (u [w #:mutable]) #:transparent)
|
||||
(define-struct (q2 q) (v) #:transparent)
|
||||
(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 #t chaperone-of?/proxy (make-p 1 2) (make-p 1 2))
|
||||
(test #f chaperone-of?/proxy (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 #f chaperone-of?/proxy (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 impersonator-of? (make-o 1 2) (make-o 1 2))
|
||||
(test #t chaperone-of?/impersonator (make-p 1 2) (make-p 1 2))
|
||||
(test #f chaperone-of?/impersonator (make-p 1 (box 2)) (make-p 1 (box 2)))
|
||||
(test #t chaperone-of?/impersonator (make-p2 1 2 3) (make-p2 1 2 3))
|
||||
(test #f chaperone-of?/impersonator (make-q 1 2) (make-q 1 2))
|
||||
(test #f chaperone-of?/impersonator (make-q2 1 2 3) (make-q2 1 2 3)))
|
||||
|
||||
(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))])
|
||||
(test #t proxy-of? p2 p)
|
||||
(test #t proxy-of? p2 p1)
|
||||
(test #t proxy? p1)
|
||||
(test #t impersonator-of? p2 p)
|
||||
(test #t impersonator-of? p2 p1)
|
||||
(test #t impersonator? p1)
|
||||
(test #f chaperone? p1)
|
||||
(test #t chaperone? p2)
|
||||
(test #f chaperone-of? p2 p)
|
||||
|
|
@ -70,18 +70,18 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(test #t chaperone?/proxy (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 #t chaperone?/impersonator (chaperone-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? (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)) (proxy-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)))
|
||||
(err/rt-test (proxy-box (box-immutable 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?/impersonator (chaperone-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
|
||||
([chaperone-box proxy-box]
|
||||
[chaperone-of? proxy-of?])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-box impersonate-box]
|
||||
[chaperone-of? impersonator-of?])
|
||||
(let* ([b (box 0)]
|
||||
[b2 (chaperone-box b
|
||||
(lambda (b v)
|
||||
|
|
@ -114,11 +114,11 @@
|
|||
(test #f unbox b2)
|
||||
(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 ([b2 (proxy-box b
|
||||
(lambda (b v) #f)
|
||||
(lambda (b v) #f))])
|
||||
(let ([b2 (impersonate-box b
|
||||
(lambda (b v) #f)
|
||||
(lambda (b v) #f))])
|
||||
(test #f unbox b2)
|
||||
(test (void) set-box! b2 0)
|
||||
(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? (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)) (proxy-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)))
|
||||
(err/rt-test (proxy-vector (vector-immutable 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?/impersonator (chaperone-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)))
|
||||
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-vector proxy-vector]
|
||||
[chaperone-of? proxy-of?])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-vector impersonate-vector]
|
||||
[chaperone-of? impersonator-of?])
|
||||
(let* ([b (vector 1 2 3)]
|
||||
[b2 (chaperone-vector b
|
||||
(lambda (b i v)
|
||||
|
|
@ -167,8 +167,8 @@
|
|||
;; test chaperone-of checks in a chaperone:
|
||||
(let ([b (vector 0)])
|
||||
(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
|
||||
(with-handlers ([exn:fail:contract? (lambda (exn) 'ok)])
|
||||
(vector-ref b2 0)))
|
||||
|
|
@ -176,11 +176,11 @@
|
|||
(test #f vector-ref b2 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 ([b2 (proxy-vector b
|
||||
(lambda (b i v) #f)
|
||||
(lambda (b i v) #f))])
|
||||
(let ([b2 (impersonate-vector b
|
||||
(lambda (b i v) #f)
|
||||
(lambda (b i v) #f))])
|
||||
(test #f vector-ref b2 0)
|
||||
(test (void) vector-set! b2 0 #f)
|
||||
(test #f vector-ref b 0)
|
||||
|
|
@ -188,26 +188,26 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(test #t chaperone?/proxy (chaperone-procedure (lambda (x) x) (lambda (y) y)))
|
||||
(test #t proxy? (proxy-procedure (lambda (x) x) (lambda (y) y)))
|
||||
(test #t chaperone?/impersonator (chaperone-procedure (lambda (x) x) (lambda (y) y)))
|
||||
(test #t impersonator? (impersonate-procedure (lambda (x) x) (lambda (y) y)))
|
||||
(test #t 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)) (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 (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 (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))
|
||||
|
||||
(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))
|
||||
|
||||
;; Single argument, no post filter:
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let* ([f (lambda (x) (list x x))]
|
||||
[in #f]
|
||||
[f2 (chaperone-procedure
|
||||
|
|
@ -221,8 +221,8 @@
|
|||
(test 111 values in)))
|
||||
|
||||
;; Multiple arguments, no post filter:
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let* ([f (lambda (x y) (list x y))]
|
||||
[in #f]
|
||||
[f2 (chaperone-procedure
|
||||
|
|
@ -236,8 +236,8 @@
|
|||
(test (vector 1110 1111) values in)))
|
||||
|
||||
;; Single argument, post filter on single value:
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let* ([f (lambda (x) (list x x))]
|
||||
[in #f]
|
||||
[out #f]
|
||||
|
|
@ -257,8 +257,8 @@
|
|||
(test '(11 11) values out)))
|
||||
|
||||
;; Multiple arguments, post filter on multiple values:
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let* ([f (lambda (x y z) (values y (list x z)))]
|
||||
[in #f]
|
||||
[out #f]
|
||||
|
|
@ -278,8 +278,8 @@
|
|||
(test (vector 'b '(a c)) values out)))
|
||||
|
||||
;; Optional keyword arguments:
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
|
||||
[in #f]
|
||||
[f2 (chaperone-procedure
|
||||
|
|
@ -305,8 +305,8 @@
|
|||
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))))
|
||||
|
||||
;; Optional keyword arguments with result chaperone:
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
|
||||
[in #f]
|
||||
[out #f]
|
||||
|
|
@ -338,8 +338,8 @@
|
|||
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))))
|
||||
|
||||
;; Required keyword arguments:
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
|
||||
[in #f]
|
||||
[f2 (chaperone-procedure
|
||||
|
|
@ -365,8 +365,8 @@
|
|||
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))))
|
||||
|
||||
;; Required keyword arguments:
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
|
||||
[in #f]
|
||||
[out #f]
|
||||
|
|
@ -396,36 +396,36 @@
|
|||
(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 ((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 ((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-not-chaperone #f)
|
||||
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-struct proxy-struct]
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-struct impersonate-struct]
|
||||
[is-chaperone is-not-chaperone]
|
||||
[chaperone?/proxy proxy?])
|
||||
[chaperone?/impersonator impersonator?])
|
||||
(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-struct a ([x #:mutable] y))
|
||||
(define-struct (b a) ([z #:mutable]))
|
||||
(define-struct p (u) #:property prop:green 'green)
|
||||
(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?/proxy (chaperone-struct (make-b 1 2 3) 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?/impersonator (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v)))
|
||||
(when is-chaperone
|
||||
(test #t chaperone?/proxy (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-p 1) green-ref (lambda (a v) v))))
|
||||
(test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue))
|
||||
(when is-chaperone
|
||||
(test #t chaperone?/proxy (chaperone-struct
|
||||
(chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue)
|
||||
a-x (lambda (a v) v)
|
||||
prop:blue 'blue)))
|
||||
(test #t chaperone?/impersonator (chaperone-struct
|
||||
(chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue)
|
||||
a-x (lambda (a v) v)
|
||||
prop:blue 'blue)))
|
||||
(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-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)
|
||||
blue-ref (lambda (a v) v)))
|
||||
(when is-chaperone
|
||||
(let* ([a1 (make-a 1 2)]
|
||||
[get #f]
|
||||
[set #f]
|
||||
[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))]
|
||||
[p1 (make-p 100)]
|
||||
[p-get #f]
|
||||
[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)])
|
||||
(test 2 a-y a1)
|
||||
(test #f values get)
|
||||
(test #f values set)
|
||||
(test 2 a-y a2)
|
||||
(test 2 values get)
|
||||
(test #f values set)
|
||||
(test (void) set-a-x! a1 0)
|
||||
(test 0 a-x a1)
|
||||
(test 0 a-x a2)
|
||||
(test 2 values get)
|
||||
(test #f values set)
|
||||
(test (void) set-a-x! a2 10)
|
||||
(test 2 values get)
|
||||
(test 10 values set)
|
||||
(test 10 a-x a1)
|
||||
(test 10 a-x a2)
|
||||
(test 2 a-y a1)
|
||||
(test 2 a-y a2)
|
||||
(test #t green? p1)
|
||||
(test #t green? p2)
|
||||
(test 'green green-ref p1)
|
||||
(test #f values p-get)
|
||||
(test 'green green-ref p2)
|
||||
(test 'green values p-get)
|
||||
(test #f blue? a1)
|
||||
(test #f blue? a2)
|
||||
(test #t blue? a3)
|
||||
(test 8 blue-ref a3)))
|
||||
(let* ([a1 (make-a 1 2)]
|
||||
[get #f]
|
||||
[set #f]
|
||||
[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))]
|
||||
[p1 (make-p 100)]
|
||||
[p-get #f]
|
||||
[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)])
|
||||
(test 2 a-y a1)
|
||||
(test #f values get)
|
||||
(test #f values set)
|
||||
(test 2 a-y a2)
|
||||
(test 2 values get)
|
||||
(test #f values set)
|
||||
(test (void) set-a-x! a1 0)
|
||||
(test 0 a-x a1)
|
||||
(test 0 a-x a2)
|
||||
(test 2 values get)
|
||||
(test #f values set)
|
||||
(test (void) set-a-x! a2 10)
|
||||
(test 2 values get)
|
||||
(test 10 values set)
|
||||
(test 10 a-x a1)
|
||||
(test 10 a-x a2)
|
||||
(test 2 a-y a1)
|
||||
(test 2 a-y a2)
|
||||
(test #t green? p1)
|
||||
(test #t green? p2)
|
||||
(test 'green green-ref p1)
|
||||
(test #f values p-get)
|
||||
(test 'green green-ref p2)
|
||||
(test 'green values p-get)
|
||||
(test #f blue? a1)
|
||||
(test #f blue? a2)
|
||||
(test #t blue? a3)
|
||||
(test 8 blue-ref a3)))
|
||||
(let* ([a1 (make-b 1 2 3)]
|
||||
[get #f]
|
||||
[set #f]
|
||||
|
|
@ -550,10 +550,10 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-struct proxy-struct])
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-struct impersonate-struct])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let ()
|
||||
(define (test-sub linear? rev?)
|
||||
(define-struct a (x [y #:mutable]) #:property prop:procedure 0)
|
||||
|
|
@ -607,7 +607,7 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(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)]
|
||||
[v2 (chaperone-vector v1 (lambda (vec i v) v) (lambda (vec i v) v)
|
||||
prop:blue 89)]
|
||||
|
|
@ -641,7 +641,7 @@
|
|||
(lambda (h k) (values k (lambda (h k v) v)))
|
||||
(lambda (h k v) (values k v))
|
||||
(lambda (h k) k) (lambda (h k) k))])
|
||||
(test #t chaperone?/proxy h)
|
||||
(test #t chaperone?/impersonator h)
|
||||
(test #t hash? h)
|
||||
(test #t (lambda (x) (hash? x)) h)))
|
||||
(list
|
||||
|
|
@ -651,11 +651,11 @@
|
|||
|
||||
(for-each
|
||||
(lambda (make-hash)
|
||||
(let ([h (proxy-hash (make-hash)
|
||||
(lambda (h k) (values k (lambda (h k v) v)))
|
||||
(lambda (h k v) (values k v))
|
||||
(lambda (h k) k) (lambda (h k) k))])
|
||||
(test #t proxy? h)
|
||||
(let ([h (impersonate-hash (make-hash)
|
||||
(lambda (h k) (values k (lambda (h k v) v)))
|
||||
(lambda (h k v) (values k v))
|
||||
(lambda (h k) k) (lambda (h k) k))])
|
||||
(test #t impersonator? h)
|
||||
(test #t hash? h)
|
||||
(test #t (lambda (x) (hash? x)) h)))
|
||||
(list
|
||||
|
|
@ -665,14 +665,14 @@
|
|||
(for-each
|
||||
(lambda (make-hash)
|
||||
(err/rt-test
|
||||
(proxy-hash (make-hash)
|
||||
(lambda (h k) (values k (lambda (h k v) v)))
|
||||
(lambda (h k v) (values k v))
|
||||
(lambda (h k) k) (lambda (h k) k))))
|
||||
(impersonator-hash (make-hash)
|
||||
(lambda (h k) (values k (lambda (h k v) v)))
|
||||
(lambda (h k v) (values k v))
|
||||
(lambda (h k) k) (lambda (h k) k))))
|
||||
(list (lambda () #hash()) (lambda () #hasheq()) (lambda () #hasheqv())))
|
||||
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-hash proxy-hash])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-hash impersonate-hash])
|
||||
(for-each
|
||||
(lambda (make-hash)
|
||||
(let* ([h1 (make-hash)]
|
||||
|
|
@ -796,9 +796,9 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-hash proxy-hash]
|
||||
[chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-hash impersonate-hash]
|
||||
[chaperone-procedure impersonate-procedure])
|
||||
(letrec ([wrap
|
||||
(lambda (v)
|
||||
(cond
|
||||
|
|
@ -830,11 +830,11 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Check broken key proxy:
|
||||
;; Check broken key impersonator:
|
||||
|
||||
(let ([check
|
||||
(lambda (orig)
|
||||
(let ([h (proxy-hash
|
||||
(let ([h (impersonate-hash
|
||||
orig
|
||||
(λ (h k)
|
||||
(values 'bad1
|
||||
|
|
@ -930,8 +930,8 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(as-chaperone-or-proxy
|
||||
([chaperone-procedure proxy-procedure])
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure])
|
||||
(let ()
|
||||
(define (check-param current-directory)
|
||||
(parameterize ([current-directory (current-directory)])
|
||||
|
|
@ -982,20 +982,20 @@
|
|||
(chaperone-procedure add1 void)
|
||||
(chaperone-procedure add1 void))
|
||||
(test #t equal?
|
||||
(proxy-procedure add1 void)
|
||||
(impersonate-procedure add1 void)
|
||||
(chaperone-procedure add1 void))
|
||||
(test #t equal?
|
||||
(chaperone-procedure add1 void)
|
||||
(proxy-procedure add1 void))
|
||||
(impersonate-procedure add1 void))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; evt chaperones
|
||||
|
||||
(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 #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 #f sync/timeout 0 (chaperone-evt never-evt (lambda (e) (values e (lambda (v) (error "bad"))))))
|
||||
|
||||
|
|
@ -1050,7 +1050,7 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(let ()
|
||||
(define (a-proxy-of v) (a-x v))
|
||||
(define (a-impersonator-of v) (a-x v))
|
||||
(define a-equal+hash (list
|
||||
(lambda (v1 v2 equal?)
|
||||
(equal? (a-y v1) (a-y v2)))
|
||||
|
|
@ -1059,29 +1059,29 @@
|
|||
(lambda (v2 hash)
|
||||
(hash (a-y v2)))))
|
||||
(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)
|
||||
(define-struct (a-more a) (z))
|
||||
(define-struct (a-new-proxy a) ()
|
||||
#:property prop:proxy-of a-proxy-of)
|
||||
(define-struct (a-new-impersonator a) ()
|
||||
#:property prop:impersonator-of a-impersonator-of)
|
||||
(define-struct (a-new-equal a) ()
|
||||
#:property prop:equal+hash a-equal+hash)
|
||||
|
||||
(let ([a1 (make-a #f 2)])
|
||||
(test #t equal? (make-a #f 2) 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 #f 3) a1)
|
||||
(test #f proxy-of? (make-a #f 2) a1)
|
||||
(test #t proxy-of? (make-a a1 3) a1)
|
||||
(test #t proxy-of? (make-a-more a1 3 8) a1)
|
||||
(test #f impersonator-of? (make-a #f 2) a1)
|
||||
(test #t impersonator-of? (make-a a1 3) a1)
|
||||
(test #t impersonator-of? (make-a-more a1 3 8) a1)
|
||||
(test #f chaperone-of? (make-a a1 3) a1)
|
||||
(test #t equal? (make-a a1 3) 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 (proxy-of? (make-a-new-proxy a1 1) a1))
|
||||
(err/rt-test (proxy-of? (make-a-new-equal a1 1) a1))
|
||||
(err/rt-test (impersonator-of? (make-a-new-impersonator 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))
|
||||
(void)))
|
||||
|
||||
|
|
@ -1100,9 +1100,9 @@
|
|||
(define g1 (chaperone-procedure f1 wrapper))
|
||||
(define g2 (chaperone-procedure f2 wrapper))
|
||||
(define g3 (chaperone-procedure f2 wrapper))
|
||||
(define h1 (proxy-procedure f1 wrapper))
|
||||
(define h2 (proxy-procedure f2 wrapper))
|
||||
(define h3 (proxy-procedure f2 wrapper))
|
||||
(define h1 (impersonate-procedure f1 wrapper))
|
||||
(define h2 (impersonate-procedure f2 wrapper))
|
||||
(define h3 (impersonate-procedure f2 wrapper))
|
||||
|
||||
(test #t chaperone-of? g1 f1)
|
||||
(test #t chaperone-of? g2 f2)
|
||||
|
|
@ -1114,10 +1114,10 @@
|
|||
(test #t equal? g3 f2)
|
||||
(test #t equal? g3 g2)
|
||||
|
||||
(test #t proxy-of? h1 f1)
|
||||
(test #t proxy-of? h2 f2)
|
||||
(test #t proxy-of? h3 f2)
|
||||
(test #f proxy-of? h3 h2)
|
||||
(test #t impersonator-of? h1 f1)
|
||||
(test #t impersonator-of? h2 f2)
|
||||
(test #t impersonator-of? h3 f2)
|
||||
(test #f impersonator-of? h3 h2)
|
||||
|
||||
(test #t equal? h1 f1)
|
||||
(test #t equal? h2 f2)
|
||||
|
|
@ -1132,20 +1132,20 @@
|
|||
(test #f equal? h1 f3)
|
||||
(test #f equal? h2 f1)
|
||||
(test #f equal? h3 f1))
|
||||
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; A regression test mixing `procedure-rename',
|
||||
;; chaperones, and proxy properties:
|
||||
;; chaperones, and impersonator properties:
|
||||
(let ()
|
||||
(define (f #:key k) k)
|
||||
(define null-checker
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-vals . args) (apply values kwd-vals 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
|
||||
(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)))
|
||||
|
||||
|
|
@ -1166,14 +1166,14 @@
|
|||
saved))
|
||||
(values (lambda (r) r)
|
||||
a))
|
||||
proxy-prop:application-mark
|
||||
impersonator-prop:application-mark
|
||||
(cons 'z 12)))
|
||||
(define h (chaperone-procedure
|
||||
g
|
||||
(lambda (a)
|
||||
(values (lambda (r) r)
|
||||
a))
|
||||
proxy-prop:application-mark
|
||||
impersonator-prop:application-mark
|
||||
(cons 'z 9)))
|
||||
(define i (chaperone-procedure
|
||||
f
|
||||
|
|
@ -1181,12 +1181,12 @@
|
|||
(set! saved (cons (continuation-mark-set-first #f 'z)
|
||||
saved))
|
||||
a)
|
||||
proxy-prop:application-mark
|
||||
impersonator-prop:application-mark
|
||||
(cons 'z 11)))
|
||||
(define j (chaperone-procedure
|
||||
i
|
||||
(lambda (a) a)
|
||||
proxy-prop:application-mark
|
||||
impersonator-prop:application-mark
|
||||
(cons 'z 12)))
|
||||
(test (list 12 '(12)) g 10)
|
||||
(test '(#f) values saved)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
5.0.99.2
|
||||
proxy => impersonator
|
||||
|
||||
5.0.99.1
|
||||
Internal: weak boxes are cleared before non-will-like
|
||||
finalizers; use late-weak boxes to get the old behavior
|
||||
|
||||
|
|
|
|||
|
|
@ -536,7 +536,7 @@ EXPORTS
|
|||
scheme_eqv
|
||||
scheme_equal
|
||||
scheme_chaperone_of
|
||||
scheme_proxy_of
|
||||
scheme_impersonator_of
|
||||
scheme_equal_hash_key
|
||||
scheme_equal_hash_key2
|
||||
scheme_recur_equal_hash_key
|
||||
|
|
|
|||
|
|
@ -551,7 +551,7 @@ EXPORTS
|
|||
scheme_eqv
|
||||
scheme_equal
|
||||
scheme_chaperone_of
|
||||
scheme_proxy_of
|
||||
scheme_impersonator_of
|
||||
scheme_hash_key
|
||||
scheme_equal_hash_key
|
||||
scheme_equal_hash_key2
|
||||
|
|
|
|||
|
|
@ -553,7 +553,7 @@ scheme_eq
|
|||
scheme_eqv
|
||||
scheme_equal
|
||||
scheme_chaperone_of
|
||||
scheme_proxy_of
|
||||
scheme_impersonator_of
|
||||
scheme_equal_hash_key
|
||||
scheme_equal_hash_key2
|
||||
scheme_recur_equal_hash_key
|
||||
|
|
|
|||
|
|
@ -559,7 +559,7 @@ scheme_eq
|
|||
scheme_eqv
|
||||
scheme_equal
|
||||
scheme_chaperone_of
|
||||
scheme_proxy_of
|
||||
scheme_impersonator_of
|
||||
scheme_hash_key
|
||||
scheme_equal_hash_key
|
||||
scheme_equal_hash_key2
|
||||
|
|
|
|||
|
|
@ -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 *equalish_prim (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 *proxy_of (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *impersonator_of (int argc, Scheme_Object *argv[]);
|
||||
|
||||
typedef struct Equal_Info {
|
||||
long depth; /* always odd, so it looks like a fixnum */
|
||||
|
|
@ -57,13 +57,13 @@ typedef struct Equal_Info {
|
|||
Scheme_Hash_Table *ht;
|
||||
Scheme_Object *recur;
|
||||
Scheme_Object *next, *next_next;
|
||||
int for_chaperone; /* 2 => for proxy */
|
||||
int for_chaperone; /* 2 => for impersonator */
|
||||
} Equal_Info;
|
||||
|
||||
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 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)
|
||||
{
|
||||
|
|
@ -109,15 +109,15 @@ void scheme_init_bool (Scheme_Env *env)
|
|||
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
|
||||
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_add_global_constant("proxy?", p, env);
|
||||
scheme_add_global_constant("impersonator?", p, env);
|
||||
|
||||
scheme_add_global_constant("chaperone-of?",
|
||||
scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2),
|
||||
env);
|
||||
scheme_add_global_constant("proxy-of?",
|
||||
scheme_make_prim_w_arity(proxy_of, "proxy-of?", 2, 2),
|
||||
scheme_add_global_constant("impersonator-of?",
|
||||
scheme_make_prim_w_arity(impersonator_of, "impersonator-of?", 2, 2),
|
||||
env);
|
||||
}
|
||||
|
||||
|
|
@ -382,7 +382,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
|
|||
return 1;
|
||||
else if (eql->for_chaperone
|
||||
&& 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))) {
|
||||
obj1 = ((Scheme_Chaperone *)obj1)->prev;
|
||||
goto top;
|
||||
|
|
@ -475,19 +475,19 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
|
|||
if (eql->for_chaperone == 1)
|
||||
procs1 = NULL;
|
||||
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)
|
||||
procs1 = apply_proxy_of(eql->for_chaperone, procs1, obj1);
|
||||
procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1);
|
||||
if (eql->for_chaperone)
|
||||
procs2 = NULL;
|
||||
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)
|
||||
procs2 = apply_proxy_of(eql->for_chaperone, procs2, obj2);
|
||||
procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2);
|
||||
}
|
||||
|
||||
if (procs1 || procs2) {
|
||||
/* proxy-of property trumps other forms of checking */
|
||||
/* impersonator-of property trumps other forms of checking */
|
||||
if (procs1) obj1 = procs1;
|
||||
if (procs2) obj2 = procs2;
|
||||
goto top;
|
||||
|
|
@ -663,12 +663,12 @@ Scheme_Object * scheme_make_false (void)
|
|||
static Scheme_Object *chaperone_p(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
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_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);
|
||||
}
|
||||
|
|
@ -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);
|
||||
}
|
||||
|
||||
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)
|
||||
|
|
@ -698,7 +698,7 @@ int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
|
|||
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;
|
||||
|
||||
|
|
@ -713,7 +713,7 @@ int scheme_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2)
|
|||
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;
|
||||
|
||||
|
|
@ -723,10 +723,10 @@ static Scheme_Object *apply_proxy_of(int for_chaperone, Scheme_Object *procs, Sc
|
|||
if (SCHEME_FALSEP(v))
|
||||
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)))
|
||||
scheme_arg_mismatch((for_chaperone ? "proxy-of?" : "equal?"),
|
||||
"proxy-of property procedure returned a value with a different prop:proxy-of source: ",
|
||||
scheme_arg_mismatch((for_chaperone ? "impersonator-of?" : "equal?"),
|
||||
"impersonator-of property procedure returned a value with a different prop:impersonator-of source: ",
|
||||
v);
|
||||
|
||||
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 || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0],
|
||||
SCHEME_VEC_ELS(procs)[0]))
|
||||
scheme_arg_mismatch((for_chaperone ? "proxy-of?" : "equal?"),
|
||||
"proxy-of property procedure returned a value with a different prop:equal+hash source: ",
|
||||
scheme_arg_mismatch((for_chaperone ? "impersonator-of?" : "equal?"),
|
||||
"impersonator-of property procedure returned a value with a different prop:equal+hash source: ",
|
||||
v);
|
||||
|
||||
return v;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -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_equal_closure_p(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_closure_p(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",
|
||||
2, -1),
|
||||
env);
|
||||
scheme_add_global_constant("proxy-procedure",
|
||||
scheme_make_prim_w_arity(proxy_procedure,
|
||||
"proxy-procedure",
|
||||
scheme_add_global_constant("impersonate-procedure",
|
||||
scheme_make_prim_w_arity(impersonate_procedure,
|
||||
"impersonate-procedure",
|
||||
2, -1),
|
||||
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,
|
||||
int is_proxy, int argc, Scheme_Object *argv[])
|
||||
int is_impersonator, int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Chaperone *px;
|
||||
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->redirects = argv[1];
|
||||
|
||||
if (is_proxy)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
|
||||
if (is_impersonator)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
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)
|
||||
|
|
@ -4206,10 +4206,10 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
|
|||
}
|
||||
px = (Scheme_Chaperone *)o;
|
||||
|
||||
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
|
||||
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
|
||||
what = "chaperone";
|
||||
else
|
||||
what = "proxy";
|
||||
what = "impersonator";
|
||||
|
||||
/* Ensure that the original procedure accepts `argc' arguments: */
|
||||
a[0] = px->prev;
|
||||
|
|
@ -4224,7 +4224,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
|
|||
}
|
||||
|
||||
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) */
|
||||
if (app_mark && !SCHEME_PAIRP(app_mark))
|
||||
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);
|
||||
} else
|
||||
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++) {
|
||||
if (!scheme_chaperone_of(argv2[i], argv[i])) {
|
||||
if (argc == 1)
|
||||
|
|
@ -4390,7 +4390,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
|
|||
}
|
||||
|
||||
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++) {
|
||||
if (!scheme_chaperone_of(argv2[i], argv[i])) {
|
||||
if (argc == 1)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
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));
|
||||
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
|
||||
ref5 = NULL;
|
||||
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?")) {
|
||||
generate_inlined_type_test(jitter, app, scheme_proc_chaperone_type, scheme_chaperone_type, -1, for_branch, branch_short, need_sync);
|
||||
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);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "vector?")) {
|
||||
|
|
|
|||
|
|
@ -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 *set_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_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 *eqv_hash_code(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 *weak_box_value(int argc, Scheme_Object *argv[]);
|
||||
|
|
@ -473,9 +473,9 @@ scheme_init_list (Scheme_Env *env)
|
|||
"chaperone-box",
|
||||
3, -1),
|
||||
env);
|
||||
scheme_add_global_constant("proxy-box",
|
||||
scheme_make_prim_w_arity(proxy_box,
|
||||
"proxy-box",
|
||||
scheme_add_global_constant("impersonate-box",
|
||||
scheme_make_prim_w_arity(impersonate_box,
|
||||
"impersonate-box",
|
||||
3, -1),
|
||||
env);
|
||||
|
||||
|
|
@ -636,9 +636,9 @@ scheme_init_list (Scheme_Env *env)
|
|||
"chaperone-hash",
|
||||
5, -1),
|
||||
env);
|
||||
scheme_add_global_constant("proxy-hash",
|
||||
scheme_make_prim_w_arity(proxy_hash,
|
||||
"proxy-hash",
|
||||
scheme_add_global_constant("impersonate-hash",
|
||||
scheme_make_prim_w_arity(impersonate_hash,
|
||||
"impersonate-hash",
|
||||
5, -1),
|
||||
env);
|
||||
|
||||
|
|
@ -1563,7 +1563,7 @@ static Scheme_Object *chaperone_unbox(Scheme_Object *obj)
|
|||
a[1] = orig;
|
||||
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))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"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;
|
||||
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]))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"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;
|
||||
}
|
||||
|
||||
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_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))
|
||||
val = SCHEME_CHAPERONE_VAL(val);
|
||||
|
||||
if (!SCHEME_BOXP(val) || (is_proxy && !SCHEME_MUTABLEP(val)))
|
||||
scheme_wrong_type(name, is_proxy ? "mutable box" : "box", 0, argc, argv);
|
||||
if (!SCHEME_BOXP(val) || (is_impersonator && !SCHEME_MUTABLEP(val)))
|
||||
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, 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->redirects = redirects;
|
||||
|
||||
if (is_proxy)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
|
||||
if (is_impersonator)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
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)
|
||||
|
|
@ -2335,7 +2335,7 @@ static Scheme_Object *do_map_hash_table(int argc,
|
|||
v = scheme_chaperone_hash_get(chaperone, v);
|
||||
if (!v)
|
||||
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,
|
||||
p[0]);
|
||||
} else
|
||||
|
|
@ -2369,7 +2369,7 @@ static Scheme_Object *do_map_hash_table(int argc,
|
|||
v = scheme_chaperone_hash_get(chaperone, v);
|
||||
if (!v)
|
||||
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,
|
||||
p[0]);
|
||||
} 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);
|
||||
if (!obj)
|
||||
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);
|
||||
return obj;
|
||||
} 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);
|
||||
if (!obj)
|
||||
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);
|
||||
return obj;
|
||||
} 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);
|
||||
}
|
||||
|
||||
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_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);
|
||||
|
||||
if (!SCHEME_HASHTP(val)
|
||||
&& (is_proxy || !SCHEME_HASHTRP(val))
|
||||
&& (is_impersonator || !SCHEME_HASHTRP(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, 3, 2, argc, argv); /* set! */
|
||||
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->redirects = redirects;
|
||||
|
||||
if (is_proxy)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
|
||||
if (is_impersonator)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
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)
|
||||
|
|
@ -2871,7 +2871,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
|
|||
red,
|
||||
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))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%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";
|
||||
}
|
||||
|
||||
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
|
||||
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
|
||||
if (!scheme_chaperone_of(o, orig))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%s: chaperone produced a %s: %V that is not a chaperone of the original %s: %V",
|
||||
|
|
|
|||
|
|
@ -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_never_evt_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 */
|
||||
Scheme_Object *val;
|
||||
val = scheme_hash_get(global_constants_ht, obj);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
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_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2);
|
||||
MZ_EXTERN int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2);
|
||||
|
||||
#ifdef MZ_PRECISE_GC
|
||||
XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o);
|
||||
|
|
|
|||
|
|
@ -872,7 +872,7 @@ int (*scheme_eq)(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_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
|
||||
long (*scheme_hash_key)(Scheme_Object *o);
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -605,7 +605,7 @@
|
|||
scheme_extension_table->scheme_eqv = scheme_eqv;
|
||||
scheme_extension_table->scheme_equal = scheme_equal;
|
||||
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
|
||||
scheme_extension_table->scheme_hash_key = scheme_hash_key;
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -605,7 +605,7 @@
|
|||
#define scheme_eqv (scheme_extension_table->scheme_eqv)
|
||||
#define scheme_equal (scheme_extension_table->scheme_equal)
|
||||
#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
|
||||
#define scheme_hash_key (scheme_extension_table->scheme_hash_key)
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -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_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;
|
||||
|
||||
|
|
@ -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);
|
||||
|
||||
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 *prev; /* immediately chaperoned object */
|
||||
Scheme_Hash_Tree *props;
|
||||
|
|
@ -771,7 +771,7 @@ typedef struct Scheme_Chaperone {
|
|||
} Scheme_Chaperone;
|
||||
|
||||
#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)
|
||||
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "5.0.99.1"
|
||||
#define MZSCHEME_VERSION "5.0.99.2"
|
||||
|
||||
#define MZSCHEME_VERSION_X 5
|
||||
#define MZSCHEME_VERSION_Y 0
|
||||
#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_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
|||
|
|
@ -32,13 +32,13 @@ READ_ONLY Scheme_Object *scheme_source_property;
|
|||
READ_ONLY Scheme_Object *scheme_input_port_property;
|
||||
READ_ONLY Scheme_Object *scheme_output_port_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_current_inspector_proc;
|
||||
READ_ONLY Scheme_Object *scheme_recur_symbol;
|
||||
READ_ONLY Scheme_Object *scheme_display_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 *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 *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_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_print_attribute_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_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 *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-for-prop:proxy-of",
|
||||
guard = scheme_make_prim_w_arity(check_impersonator_of_property_value_ok,
|
||||
"guard-for-prop:impersonator-of",
|
||||
2, 2);
|
||||
REGISTER_SO(scheme_proxy_of_property);
|
||||
scheme_proxy_of_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("proxy-of"),
|
||||
REGISTER_SO(scheme_impersonator_of_property);
|
||||
scheme_impersonator_of_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("impersonator-of"),
|
||||
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?",
|
||||
1, 1),
|
||||
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,
|
||||
"proxy-property-accessor-procedure?",
|
||||
"impersonator-property-accessor-procedure?",
|
||||
1, 1),
|
||||
env);
|
||||
|
||||
|
|
@ -703,9 +703,9 @@ scheme_init_struct (Scheme_Env *env)
|
|||
"chaperone-struct",
|
||||
1, -1),
|
||||
env);
|
||||
scheme_add_global_constant("proxy-struct",
|
||||
scheme_make_prim_w_arity(proxy_struct,
|
||||
"proxy-struct",
|
||||
scheme_add_global_constant("impersonate-struct",
|
||||
scheme_make_prim_w_arity(impersonate_struct,
|
||||
"impersonate-struct",
|
||||
1, -1),
|
||||
env);
|
||||
scheme_add_global_constant("chaperone-struct-type",
|
||||
|
|
@ -713,23 +713,23 @@ scheme_init_struct (Scheme_Env *env)
|
|||
"chaperone-struct-type",
|
||||
1, -1),
|
||||
env);
|
||||
scheme_add_global_constant("make-proxy-property",
|
||||
scheme_add_global_constant("make-impersonator-property",
|
||||
scheme_make_prim_w_arity2(make_chaperone_property,
|
||||
"make-proxy-property",
|
||||
"make-impersonator-property",
|
||||
1, 1,
|
||||
3, 3),
|
||||
env);
|
||||
scheme_add_global_constant("proxy-property?",
|
||||
scheme_add_global_constant("impersonator-property?",
|
||||
scheme_make_folding_prim(chaperone_property_p,
|
||||
"proxy-property?",
|
||||
"impersonator-property?",
|
||||
1, 1, 1),
|
||||
env);
|
||||
|
||||
{
|
||||
REGISTER_SO(scheme_app_mark_proxy_property);
|
||||
scheme_app_mark_proxy_property = make_chaperone_property_from_c(scheme_intern_symbol("application-mark"));
|
||||
scheme_add_global_constant("proxy-prop:application-mark",
|
||||
scheme_app_mark_proxy_property,
|
||||
REGISTER_SO(scheme_app_mark_impersonator_property);
|
||||
scheme_app_mark_impersonator_property = make_chaperone_property_from_c(scheme_intern_symbol("application-mark"));
|
||||
scheme_add_global_constant("impersonator-prop:application-mark",
|
||||
scheme_app_mark_impersonator_property,
|
||||
env);
|
||||
}
|
||||
}
|
||||
|
|
@ -981,7 +981,7 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object
|
|||
a[1] = orig;
|
||||
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))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%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)
|
||||
who = "make-struct-type-property";
|
||||
else
|
||||
who = "make-proxy-property";
|
||||
who = "make-impersonator-property";
|
||||
|
||||
if (!SCHEME_SYMBOLP(argv[0]))
|
||||
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)
|
||||
{
|
||||
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
|
||||
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;
|
||||
}
|
||||
|
||||
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;
|
||||
|
||||
v = argv[0];
|
||||
|
||||
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: ",
|
||||
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);
|
||||
|
||||
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];
|
||||
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))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%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;
|
||||
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]))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"%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)
|
||||
{
|
||||
Scheme_Object *v, **vals, *v1[1];
|
||||
int cnt, i, is_proxy;
|
||||
int cnt, i, is_impersonator;
|
||||
Scheme_Thread *p;
|
||||
|
||||
while (SCHEME_PAIRP(procs)) {
|
||||
v = SCHEME_CAR(procs);
|
||||
if (SCHEME_BOXP(v)) {
|
||||
is_proxy = 1;
|
||||
is_impersonator = 1;
|
||||
v = SCHEME_BOX_VAL(v);
|
||||
} else
|
||||
is_proxy = 0;
|
||||
is_impersonator = 0;
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
if (!is_proxy) {
|
||||
if (!is_impersonator) {
|
||||
for (i = 0; i < argc; i++) {
|
||||
if (!scheme_chaperone_of(vals[i], a[i]))
|
||||
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_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);
|
||||
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;
|
||||
if (SCHEME_PAIRP(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);
|
||||
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;
|
||||
if (SCHEME_PAIRP(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);
|
||||
procs = scheme_make_pair(proc, procs);
|
||||
}
|
||||
|
|
@ -3120,14 +3120,14 @@ Scheme_Object *handle_evt_p(int argc, Scheme_Object *argv[])
|
|||
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];
|
||||
|
||||
a[0] = argv[0];
|
||||
o = _scheme_apply(proc, 1, a);
|
||||
|
||||
if (!is_proxy)
|
||||
if (!is_impersonator)
|
||||
if (!scheme_chaperone_of(o, a[0]))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"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);
|
||||
}
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
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 *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)
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
|
||||
"evt %s: %V: returned %d values, expected 2",
|
||||
(is_proxy ? "proxy" : "chaperone"),
|
||||
(is_impersonator ? "impersonator" : "chaperone"),
|
||||
proc,
|
||||
cnt);
|
||||
|
||||
if (!is_proxy)
|
||||
if (!is_impersonator)
|
||||
if (!scheme_chaperone_of(vals[0], evt))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"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))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"evt %s: expected a value of type <procedure (arity 2)> as second %s result, received: %V",
|
||||
(is_proxy ? "proxy" : "chaperone"),
|
||||
(is_proxy ? "proxy" : "chaperone"),
|
||||
(is_impersonator ? "impersonator" : "chaperone"),
|
||||
(is_impersonator ? "impersonator" : "chaperone"),
|
||||
vals[1]);
|
||||
|
||||
a[0] = vals[0];
|
||||
o = scheme_make_closed_prim_w_arity((is_proxy
|
||||
? proxy_result_guard_proc
|
||||
o = scheme_make_closed_prim_w_arity((is_impersonator
|
||||
? impersonator_result_guard_proc
|
||||
: chaperone_result_guard_proc),
|
||||
(void *)vals[1],
|
||||
"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);
|
||||
}
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
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_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);
|
||||
|
||||
o = scheme_make_pair(argv[0], argv[1]);
|
||||
o = scheme_make_closed_prim_w_arity((is_proxy
|
||||
? proxy_guard_proc
|
||||
o = scheme_make_closed_prim_w_arity((is_impersonator
|
||||
? impersonator_guard_proc
|
||||
: chaperone_guard_proc),
|
||||
(void *)o,
|
||||
(is_proxy
|
||||
? "evt-chaperone"
|
||||
: "evt-proxy"),
|
||||
(is_impersonator
|
||||
? "chaperone-evt"
|
||||
: "impersonate-evt"),
|
||||
1, 1);
|
||||
a[0] = o;
|
||||
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->redirects = o;
|
||||
|
||||
if (is_proxy)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
|
||||
if (is_impersonator)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
|
||||
|
||||
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 ...) */
|
||||
{
|
||||
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))) {
|
||||
kind = "accessor";
|
||||
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";
|
||||
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";
|
||||
offset = -2;
|
||||
} else {
|
||||
scheme_wrong_type(name,
|
||||
(is_proxy
|
||||
(is_impersonator
|
||||
? "structure accessor or structure mutator"
|
||||
: "structure accessor, structure mutator, struct-type property accessor, or `struct-info'"),
|
||||
i, argc, argv);
|
||||
|
|
@ -5228,7 +5228,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_proxy, int ar
|
|||
name,
|
||||
kind, kind,
|
||||
a[0]);
|
||||
if (is_proxy) {
|
||||
if (is_impersonator) {
|
||||
/* Must not be an immutable field. */
|
||||
if (stype->immutables) {
|
||||
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->redirects = redirects;
|
||||
|
||||
if (is_proxy)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
|
||||
if (is_impersonator)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
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_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->redirects = redirects;
|
||||
|
||||
if (is_proxy)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
|
||||
if (is_impersonator)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
|
||||
|
||||
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) {
|
||||
v = argv[start_at];
|
||||
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)
|
||||
scheme_arg_mismatch(who,
|
||||
|
|
|
|||
|
|
@ -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_values (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_ref (int argc, Scheme_Object *argv[]);
|
||||
|
|
@ -147,9 +147,9 @@ scheme_init_vector (Scheme_Env *env)
|
|||
"chaperone-vector",
|
||||
3, -1),
|
||||
env);
|
||||
scheme_add_global_constant("proxy-vector",
|
||||
scheme_make_prim_w_arity(proxy_vector,
|
||||
"proxy-vector",
|
||||
scheme_add_global_constant("impersonate-vector",
|
||||
scheme_make_prim_w_arity(impersonate_vector,
|
||||
"impersonate-vector",
|
||||
3, -1),
|
||||
env);
|
||||
}
|
||||
|
|
@ -425,7 +425,7 @@ Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
|
|||
red = SCHEME_CAR(px->redirects);
|
||||
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))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"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);
|
||||
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]))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"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;
|
||||
}
|
||||
|
||||
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_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);
|
||||
|
||||
if (!SCHEME_VECTORP(val)
|
||||
|| (is_proxy && !SCHEME_MUTABLEP(val)))
|
||||
scheme_wrong_type(name, is_proxy ? "mutable vector" : "vector", 0, argc, argv);
|
||||
|| (is_impersonator && !SCHEME_MUTABLEP(val)))
|
||||
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, 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->redirects = redirects;
|
||||
|
||||
if (is_proxy)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
|
||||
if (is_impersonator)
|
||||
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
/************************************************************/
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user