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

add proxies and rename chaperone properties to proxy properties

Browse Source 
where a proxy is less constrained in its conversions but more
 constrained in where it can be used
This commit is contained in:
Matthew Flatt 2010-08-31 19:10:42 -06:00
parent be3ca941bb
commit 69658697b1
25 changed files with 2311 additions and 1705 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -22,7 +22,8 @@
new-prop:procedure new-prop:procedure
new:procedure->method new:procedure->method
new:procedure-rename new:procedure-rename
new:chaperone-procedure) new:chaperone-procedure
new:proxy-procedure)
;; ---------------------------------------- ;; ----------------------------------------
@ -1139,112 +1140,126 @@
(define new:chaperone-procedure (define new:chaperone-procedure
(let ([chaperone-procedure (let ([chaperone-procedure
(lambda (proc wrap-proc . props) (lambda (proc wrap-proc . props)
(if (or (not (keyword-procedure? proc)) (do-chaperone-procedure #t chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
(not (procedure? wrap-proc))) chaperone-procedure ))
(apply chaperone-procedure proc wrap-proc props)
(let-values ([(a) (procedure-arity proc)]
[(b) (procedure-arity wrap-proc)]
[(a-req a-allow) (procedure-keywords proc)]
[(b-req b-allow) (procedure-keywords wrap-proc)])
(define (includes? a b)
(cond
[(number? b) (cond
[(number? a) (= b a)]
[(arity-at-least? a)
(b . >= . (arity-at-least-value a))]
[else
(ormap (lambda (b a) (includes? a b))
a)])]
[(arity-at-least? b) (cond
[(number? a) #f]
[(arity-at-least? a)
((arity-at-least-value b) . >= . (arity-at-least-value a))]
[else (ormap (lambda (b a) (includes? b a))
a)])]
[else (andmap (lambda (b) (includes? a b)) b)]))
(unless (includes? b a) (define new:proxy-procedure
;; Let core report error: (let ([chaperone-procedure
(apply chaperone-procedure proc wrap-proc props)) (lambda (proc wrap-proc . props)
(unless (subset? b-req a-req) (do-chaperone-procedure #f proxy-procedure 'proxy-procedure proc wrap-proc props))])
(raise-mismatch-error chaperone-procedure ))
'chaperone-procedure
"chaperoning procedure requires more keywords than original procedure: " (define (do-chaperone-procedure is-proxy? chaperone-procedure name proc wrap-proc props)
proc)) (if (or (not (keyword-procedure? proc))
(unless (or (not b-allow) (not (procedure? wrap-proc)))
(and a-allow (apply chaperone-procedure proc wrap-proc props)
(subset? a-allow b-allow))) (let-values ([(a) (procedure-arity proc)]
(raise-mismatch-error [(b) (procedure-arity wrap-proc)]
'chaperone-procedure [(a-req a-allow) (procedure-keywords proc)]
"chaperoning procedure does not accept all keywords of original procedure: " [(b-req b-allow) (procedure-keywords wrap-proc)])
proc)) (define (includes? a b)
(let* ([kw-chaperone (cond
(let ([p (keyword-procedure-proc wrap-proc)]) [(number? b) (cond
(lambda (kws args . rest) [(number? a) (= b a)]
(call-with-values (lambda () (apply p kws args rest)) [(arity-at-least? a)
(lambda results (b . >= . (arity-at-least-value a))]
(let ([len (length results)] [else
[alen (length rest)]) (ormap (lambda (b a) (includes? a b))
(unless (<= (+ alen 1) len (+ alen 2)) a)])]
[(arity-at-least? b) (cond
[(number? a) #f]
[(arity-at-least? a)
((arity-at-least-value b) . >= . (arity-at-least-value a))]
[else (ormap (lambda (b a) (includes? b a))
a)])]
[else (andmap (lambda (b) (includes? a b)) b)]))
(unless (includes? b a)
;; Let core report error:
(apply chaperone-procedure proc wrap-proc props))
(unless (subset? b-req a-req)
(raise-mismatch-error
name
(format
"~a procedure requires more keywords than original procedure: "
(if is-proxy? "proxying" "chaperoning"))
proc))
(unless (or (not b-allow)
(and a-allow
(subset? a-allow b-allow)))
(raise-mismatch-error
name
(format
"~a procedure does not accept all keywords of original procedure: "
(if is-proxy? "proxying" "chaperoning"))
proc))
(let* ([kw-chaperone
(let ([p (keyword-procedure-proc wrap-proc)])
(lambda (kws args . rest)
(call-with-values (lambda () (apply p kws args rest))
(lambda results
(let ([len (length results)]
[alen (length rest)])
(unless (<= (+ alen 1) len (+ alen 2))
(raise-mismatch-error
'|keyword procedure chaperone|
(format
"expected ~a or ~a results, received ~a results from chaperoning procedure: "
(+ alen 1)
(+ alen 2)
len)
wrap-proc))
(let ([extra? (= len (+ alen 2))])
(let ([new-args ((if extra? cadr car) results)])
(unless (and (list? new-args)
(= (length new-args) (length args)))
(raise-mismatch-error
'|keyword procedure chaperone|
(format
"expected a list of keyword-argument values as first result~a from chaperoning procedure: "
(if (= len alen)
""
" (after the result chaperoning procedure)"))
wrap-proc))
(for-each
(lambda (kw new-arg arg)
(unless is-proxy?
(unless (chaperone-of? new-arg arg)
(raise-mismatch-error (raise-mismatch-error
'|keyword procedure chaperone| '|keyword procedure chaperone|
(format (format
"expected ~a or ~a results, received ~a results from chaperoning procedure: " "~a keyword result is not a chaperone of original argument from chaperoning procedure: "
(+ alen 1) kw)
(+ alen 2) wrap-proc))))
len) kws
wrap-proc)) new-args
(let ([extra? (= len (+ alen 2))]) args))
(let ([new-args ((if extra? cadr car) results)]) (if extra?
(unless (and (list? new-args) (apply values (car results) kws (cdr results))
(= (length new-args) (length args))) (apply values kws results))))))))]
(raise-mismatch-error [new-proc
'|keyword procedure chaperone| (cond
(format [(okp? proc)
"expected a list of keyword-argument values as first result~a from chaperoning procedure: " (make-optional-keyword-procedure
(if (= len alen) (keyword-procedure-checker proc)
"" (chaperone-procedure (keyword-procedure-proc proc)
" (after the result chaperoning procedure)")) kw-chaperone)
wrap-proc)) (keyword-procedure-required proc)
(for-each (keyword-procedure-allowed proc)
(lambda (kw new-arg arg) (chaperone-procedure (okp-ref proc 0)
(unless (chaperone-of? new-arg arg) (okp-ref wrap-proc 0)))]
(raise-mismatch-error [else
'|keyword procedure chaperone| ;; Constructor must be from `make-required':
(format (let* ([name+fail (keyword-procedure-name+fail proc)]
"~a keyword result is not a chaperone of original argument from chaperoning procedure: " [mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc))])
kw) (mk
wrap-proc))) (keyword-procedure-checker proc)
kws (chaperone-procedure (keyword-procedure-proc proc) kw-chaperone)
new-args (keyword-procedure-required proc)
args)) (keyword-procedure-allowed proc)))])])
(if extra? (if (null? props)
(apply values (car results) kws (cdr results)) new-proc
(apply values kws results))))))))] (apply chaperone-struct new-proc
[new-proc ;; chaperone-struct insists on having at least one selector:
(cond keyword-procedure-allowed values
[(okp? proc) props)))))))
(make-optional-keyword-procedure
(keyword-procedure-checker proc)
(chaperone-procedure (keyword-procedure-proc proc)
kw-chaperone)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)
(chaperone-procedure (okp-ref proc 0)
(okp-ref wrap-proc 0)))]
[else
;; 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))])
(mk
(keyword-procedure-checker proc)
(chaperone-procedure (keyword-procedure-proc proc) kw-chaperone)
(keyword-procedure-required proc)
(keyword-procedure-allowed proc)))])])
(if (null? props)
new-proc
(apply chaperone-struct new-proc
;; chaperone-struct insists on having at least one selector:
keyword-procedure-allowed values
props))))))])
chaperone-procedure)))

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

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

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

@ -40,7 +40,7 @@ Two values are @scheme[equal?] if and only if they are @scheme[eqv?],
unless otherwise specified for a particular datatype. unless otherwise specified for a particular datatype.
Datatypes with further specification of @scheme[equal?] include Datatypes with further specification of @scheme[equal?] include
strings, byte strings, numbers, pairs, mutable pairs, vectors, hash strings, byte strings, numbers, pairs, mutable pairs, vectors, boxes, hash
tables, and inspectable structures. In the last five cases, equality tables, and inspectable structures. In the last five cases, equality
is recursively defined; if both @scheme[v1] and @scheme[v2] contain is recursively defined; if both @scheme[v1] and @scheme[v2] contain
reference cycles, they are equal when the infinite unfoldings of the reference cycles, they are equal when the infinite unfoldings of the

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

@ -8,30 +8,35 @@
@(define-syntax-rule (operations i ...) @(define-syntax-rule (operations i ...)
(itemlist #:style 'compact @item{@op[i]} ...)) (itemlist #:style 'compact @item{@op[i]} ...))
@title[#:tag "chaperones"]{Chaperones} @title[#:tag "chaperones"]{Proxies and Chaperones}
A @deftech{chaperone} is a wrapper for a value where the wrapper A @deftech{proxy} is a wrapper for a value where the wrapper
implements primitive support for @tech{contract}-like checks on the redirects certain of the value's operations. Proxies apply only to procedures,
value's operations. Chaperones apply only to procedures,
@tech{structures} for which an accessor or mutator is available, @tech{structures} for which an accessor or mutator is available,
@tech{structure types}, @tech{hash tables}, @tech{vectors}, @tech{structure types}, @tech{hash tables}, @tech{vectors},
@tech{box}es. A chaperoned value is @scheme[equal?] to the original and @tech{box}es. A proxied value is @scheme[equal?] to the original
value, but not @scheme[eq?] to the original value. value, but not @scheme[eq?] to the original value.
A chaperone's refinement of a value's operation is restricted to side A @deftech{chaperone} is a kind of proxy whose refinement of a value's
effects (including, in particular, raising an exception) or operation is restricted to side effects (including, in particular,
chaperoning values supplied to or produced by the operation. For raising an exception) or chaperoning values supplied to or produced by
example, a vector chaperone can redirect @scheme[vector-ref] to raise the operation. For example, a vector chaperone can redirect
an exception if the accessed vector slot contains a string, or it can @scheme[vector-ref] to raise an exception if the accessed vector slot
cause the result of @scheme[vector-ref] to be a chaperoned variant of contains a string, or it can cause the result of @scheme[vector-ref]
the value that is in the accessed vector slot, but it cannot redirect to be a chaperoned variant of the value that is in the accessed vector
@scheme[vector-ref] to produce a value that is arbitrarily different slot, but it cannot redirect @scheme[vector-ref] to produce a value
from the value in the vector slot. that is arbitrarily different from the value in the vector slot.
A non-@tech{chaperone} @tech{proxy}, in contrast, can refine an operation to swap one
value for any another. A proxy 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.
Beware that each of the following operations can be redirected to Beware that each of the following operations can be redirected to
arbitrary procedure through chaperones on the operation's arbitrary procedure through proxies on the operation's
argument---assuming that the operation is available to the creator of argument---assuming that the operation is available to the creator of
the chaperone: the proxy:
@operations[@t{a structure-field accesor} @operations[@t{a structure-field accesor}
@t{a structure-field mutator} @t{a structure-field mutator}
@ -42,26 +47,48 @@ the chaperone:
hash-ref hash-set hash-set! hash-remove hash-remove!] hash-ref hash-set hash-set! hash-remove hash-remove!]
Derived operations, such as printing a value, can be redirected Derived operations, such as printing a value, can be redirected
through chaperones due to their use of accessor functions. The through proxies due to their use of accessor functions. The
@scheme[equal?], @scheme[equal-hash-code], and @scheme[equal?], @scheme[equal-hash-code], and
@scheme[equal-secondary-hash-code] operations, in contrast, may bypass @scheme[equal-secondary-hash-code] operations, in contrast, may bypass
chaperones (but they are not obliged to). proxies (but they are not obliged to).
In addition to redirecting operations that work on a value, a In addition to redirecting operations that work on a value, a
chaperone can include @deftech{chaperone properties} for a chaperoned proxy can include @deftech{proxy properties} for a proxied
value. A @tech{chaperone property} is similar to a @tech{structure value. A @tech{proxy property} is similar to a @tech{structure
type property}, but it applies to chaperones instead of structure type property}, but it applies to chaperones instead of structure
types and their instances. types and their instances.
@defproc[(proxy? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a proxy, @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.}
@defproc[(chaperone? [v any/c]) boolean?]{ @defproc[(chaperone? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a chaperone, @scheme[#f] otherwise. Returns @scheme[#t] if @scheme[v] is a chaperone, @scheme[#f] otherwise.
Programs and libraries generally should avoid @scheme[chaperone?] and Programs and libraries generally should avoid @scheme[chaperone?] for
treat chaperones the same as unchaperoned values. In rare cases, the same reason that they should avoid @racket[proxy?].}
@scheme[chaperone?] may be needed to guard against redirection by a
chaperone of an operation to an arbitrary procedure.}
@defproc[(proxy-of? [v1 any/c] [v2 any/c]) boolean?]{
Indicates whether @scheme[v1] can be considered equivalent modulo
proxies 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?].
Otherwise, all proxies 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]).}
@defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{ @defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{
@ -80,16 +107,16 @@ from @scheme[v1] through one of the chaperone constructors (e.g.,
@scheme[chaperone-procedure]).} @scheme[chaperone-procedure]).}
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@section{Chaperone Constructors} @section{Proxy Constructors}
@defproc[(chaperone-procedure [proc procedure?] @defproc[(proxy-procedure [proc procedure?]
[wrapper-proc procedure?] [wrapper-proc procedure?]
[prop chaperone-property?] [prop proxy-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c procedure? chaperone?)]{ (and/c procedure? proxy?)]{
Returns a chaperoned procedure that has the same arity, name, and Returns a proxied procedure that has the same arity, name, and
other attributes as @scheme[proc]. When the chaperoned procedure is other attributes as @scheme[proc]. When the proxied procedure is
applied, the arguments are first passed to @scheme[wrapper-proc], and applied, the arguments are first passed to @scheme[wrapper-proc], and
then the results from @scheme[wrapper-proc] are passed to then the results from @scheme[wrapper-proc] are passed to
@scheme[proc]. The @scheme[wrapper-proc] can also supply a procedure @scheme[proc]. The @scheme[wrapper-proc] can also supply a procedure
@ -104,42 +131,35 @@ of the required keywords of @scheme[proc].
For applications without keywords, the result of @scheme[wrapper-proc] For applications without keywords, the result of @scheme[wrapper-proc]
must be either the same number of values as supplied to it or one more must be either the same number of values as supplied to it or one more
than the number of supplied values, where an extra result is supplied than the number of supplied values, where an extra result is supplied
before the others. For each supplied value, the corresponding result before the others. The additional result, if any, must be a procedure
must be the same or a chaperone of (in the sense of that accepts as many results as produced by @scheme[proc]; it must
@scheme[chaperone-of?]) the supplied value. The additional result, if return the same number of results. If @scheme[wrapper-proc] returns
any, that precedes the chaperoned values must be a procedure that the same number of values as it is given (i.e., it does not return a
accepts as many results as produced by @scheme[proc]; it must return procedure to proxy @scheme[proc]'s result), then @scheme[proc] is
the same number of results, each of which is the same or a chaperone called in @tech{tail position} with respect to the call to the proxy.
of the corresponding original result. If @scheme[wrapper-proc]
returns the same number of values as it is given (i.e., it does not
return a procedure to chaperone @scheme[proc]'s result), then
@scheme[proc] is called in @tech{tail position} with respect to the
call to the chaperone.
For applications that include keyword arguments, @scheme[wrapper-proc] For applications that include keyword arguments, @scheme[wrapper-proc]
must return an additional value before any other values but after the must return an additional value before any other values but after the
result-chaperoning procedure (if any). The additional value must be a result-proxying procedure (if any). The additional value must be a
list of chaperones of the keyword arguments that were supplied to the list of proxys of the keyword arguments that were supplied to the
chaperoned procedure (i.e., not counting optional arguments that were proxied procedure (i.e., not counting optional arguments that were
not supplied). The arguments must be ordered according to the sorted not supplied). The arguments must be ordered according to the sorted
order of the supplied arguments' keywords. order of the supplied arguments' keywords.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[procedure-chaperone] must be even) add chaperone properties to @scheme[procedure-proxy] must be even) add proxy properties
or override chaperone-property values of @scheme[proc].} or override proxy-property values of @scheme[proc].}
@defproc[(chaperone-struct [v any/c] @defproc[(proxy-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure? [orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure? struct-mutator-procedure?)]
struct-type-property-accessor-procedure? [redirect-proc procedure?] ... ...
(one-of/c struct-info))] [prop proxy-property?]
[redirect-proc procedure?] ... ... [prop-val any] ... ...)
[prop chaperone-property?]
[prop-val any] ... ...)
any/c]{ any/c]{
Returns a chaperoned value like @scheme[v], but with certain Returns a proxied value like @scheme[v], but with certain
operations on the chaperoned redirected. The @scheme[orig-proc]s operations on the proxied redirected. The @scheme[orig-proc]s
indicate the operations to redirect, and the corresponding indicate the operations to redirect, and the corresponding
@scheme[redirect-proc]s supply the redirections. @scheme[redirect-proc]s supply the redirections.
@ -148,22 +168,194 @@ The protocol for a @scheme[redirect-proc] depends on the corresponding
@itemlist[ @itemlist[
@item{A structure-field or property accessor: @scheme[redirect-proc] must @item{A structure-field: @scheme[redirect-proc]
accept two arguments, @scheme[v] and the value @scheme[_field-v] must accept two arguments, @scheme[v] and the value
that @scheme[orig-proc] produces for @scheme[v]; it must return @scheme[_field-v] that @scheme[orig-proc] produces for
chaperone of @scheme[_field-v].} @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 two @item{A structure field mutator: @scheme[redirect-proc] must accept
arguments, @scheme[v] and the value @scheme[_field-v] supplied two arguments, @scheme[v] and the value @scheme[_field-v]
to the mutator; it must return chaperone of @scheme[_field-v] supplied to the mutator; it must return a replacement for
to be propagated to @scheme[orig-proc] and @scheme[v].} @scheme[_field-v] to be propagated to @scheme[orig-proc] and
@scheme[v].}
@item{@scheme[struct-info]: @scheme[redirect-proc] must accept two ]
values, which are the results of @scheme[struct-info] on
@scheme[v]; it must return two values that are chaperones of Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
its arguments. The @scheme[orig-proc] is not called if to @scheme[proxy-procedure] must be odd) add proxy properties
@scheme[struct-info] would return @scheme[#f] as its first or override proxy-property values of @scheme[v].}
argument.}
@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?)]{
Returns a proxied value like @scheme[vec], but with
@scheme[vector-ref] and @scheme[vector-set!] operations on the
proxied vector redirected.
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.
The @scheme[set-proc] must accept @scheme[vec], an index passed to
@scheme[vector-set!], and the value passed to @scheme[vector-set!]; it
must produce a replacement for the value, which is used
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].}
@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?)]{
Returns a proxied value like @scheme[bx], but with
@scheme[unbox] and @scheme[set-box!] operations on the
proxied box redirected.
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.
The @scheme[set-proc] must accept @scheme[bx] and the value passed to
@scheme[set-box!]; it must produce a replacement
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].}
@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?)]{
Returns a proxied value like @scheme[hash], but with
@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
@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
@scheme[hash-iterate-map] implicitly use @scheme[hash-ref] and
therefore redirect through @scheme[ref-proc].
The @scheme[ref-proc] must accept @scheme[hash] and a key passed
@scheme[hash-ref]. It must return a replacement key
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.
The @scheme[set-proc] must accept @scheme[hash], a key passed to
@scheme[hash-set!] or @scheme[hash-set], and the value passed to
@scheme[hash-set!] or @scheme[hash-set]; it must produce two values: a
replacement for the key and a replacement for the value. The returned
key and value are used with @scheme[hash-set!] or @scheme[hash-set] on
the original @scheme[hash] to install the value.
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.
The @scheme[key-proc] must accept @scheme[hash] and a key that has
been extracted from @scheme[hash] (by @scheme[hash-iterate-key] or
other operations that use @scheme[hash-iterate-key] internally); it
must produce a replacement for the key, which is then reported as a
key extracted from the table.
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].}
@; ------------------------------------------------------------
@section{Chaperone Constructors}
@defproc[(chaperone-procedure [proc procedure?]
[wrapper-proc procedure?]
[prop proxy-property?]
[prop-val any] ... ...)
(and/c procedure? chaperone?)]{
Like @racket[proxy-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
values must be a procedure that accepts as many results as produced by
@scheme[proc]; it must return the same number of results, each of
which is the same or a chaperone of the corresponding original result.
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
not supplied). The arguments must be ordered according to the sorted
order of the supplied arguments' keywords.}
@defproc[(chaperone-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure?
struct-type-property-accessor-procedure?
(one-of/c struct-info))]
[redirect-proc procedure?] ... ...
[prop proxy-property?]
[prop-val any] ... ...)
any/c]{
Like @racket[proxy-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
corresponding field may be immutable.}
@item{A property accessor can be supplied as @racket[orig-proc]. The
corresponding @racket[redirect-proc] uses the same protocol as
for a structure-field selector.}
@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
@scheme[orig-proc] and @scheme[v].}
@item{With @scheme[struct-info] as @racket[orig-proc], the
corresponding @scheme[redirect-proc] must accept two values,
which are the results of @scheme[struct-info] on @scheme[v]; it
must return each values or a chaperone of each value. The
@scheme[redirect-proc] is not called if @scheme[struct-info] would
return @scheme[#f] as its first argument.}
] ]
@ -171,65 +363,33 @@ An @scheme[orig-proc] can be @scheme[struct-info] only if some other
@scheme[orig-proc] is supplied, and each @scheme[orig-proc] must @scheme[orig-proc] is supplied, and each @scheme[orig-proc] must
indicate a distinct operation. If no @scheme[orig-proc]s are supplied, indicate a distinct operation. If no @scheme[orig-proc]s are supplied,
then no @scheme[prop]s must be supplied, and @scheme[v] is returned then no @scheme[prop]s must be supplied, and @scheme[v] is returned
unchaperoned. unchaperoned.}
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-procedure] must be odd) add chaperone properties
or override chaperone-property values of @scheme[v].}
@defproc[(chaperone-vector [vec vector?] @defproc[(chaperone-vector [vec vector?]
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)] [ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)] [set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[prop chaperone-property?] [prop proxy-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c vector? chaperone?)]{ (and/c vector? chaperone?)]{
Returns a chaperoned value like @scheme[vec], but with Like @racket[proxy-vector], but with support for mutable vectors. The
@scheme[vector-ref] and @scheme[vector-set!] operations on the @scheme[ref-proc] procedure must produce the same value or a chaperone
chaperoned vector redirected. 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
The @scheme[ref-proc] must accept @scheme[vec], an index passed to not be used if @scheme[vec] is immutable.}
@scheme[vector-ref], and the value that @scheme[vector-ref] on
@scheme[vec] produces for the given index; it must produce the same
value or a chaperone of the value, which is the result of
@scheme[vector-ref] on the chaperone.
The @scheme[set-proc] must accept @scheme[vec], an index passed to
@scheme[vector-set!], and the value passed to @scheme[vector-set!]; it
must produce the same value or a chaperone of the value, which is used
with @scheme[vector-set!] on the original @scheme[vec] to install the
value. The @scheme[set-proc] will not be used if @scheme[vec] is
immutable.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-vector] must be odd) add chaperone properties
or override chaperone-property values of @scheme[vec].}
@defproc[(chaperone-box [bx box?] @defproc[(chaperone-box [bx box?]
[unbox-proc (box? any/c . -> . any/c)] [unbox-proc (box? any/c . -> . any/c)]
[set-proc (box? any/c . -> . any/c)] [set-proc (box? any/c . -> . any/c)]
[prop chaperone-property?] [prop proxy-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c box? chaperone?)]{ (and/c box? chaperone?)]{
Returns a chaperoned value like @scheme[bx], but with Like @racket[prox-box], but with support for immutable boxes. The
@scheme[unbox] and @scheme[set-box!] operations on the @scheme[unbox-proc] procedure must produce the same value or a
chaperoned box redirected. chaperone of the original value, and @scheme[set-proc] must produce
the same value or a chaperone of the value that it is given. The
The @scheme[unbox-proc] must accept @scheme[bx] and the value that @scheme[set-proc] will not be used if @scheme[bx] is immutable.}
@scheme[unbox] on @scheme[bx] produces index; it must produce the same
value or a chaperone of the value, which is the result of
@scheme[unbox] on the chaperone.
The @scheme[set-proc] must accept @scheme[bx] and the value passed to
@scheme[set-box!]; it must produce the same value or a chaperone of
the value, which is used with @scheme[set-box!] on the original
@scheme[bx] to install the value. The @scheme[set-proc] will not be
used if @scheme[bx] is immutable.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-box] must be odd) add chaperone properties
or override chaperone-property values of @scheme[bx].}
@defproc[(chaperone-hash [hash hash?] @defproc[(chaperone-hash [hash hash?]
@ -239,60 +399,23 @@ or override chaperone-property values of @scheme[bx].}
[set-proc (hash? any/c any/c . -> . (values any/c any/c))] [set-proc (hash? any/c any/c . -> . (values any/c any/c))]
[remove-proc (hash? any/c . -> . any/c)] [remove-proc (hash? any/c . -> . any/c)]
[key-proc (hash? any/c . -> . any/c)] [key-proc (hash? any/c . -> . any/c)]
[prop chaperone-property?] [prop proxy-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c hash? chaperone?)]{ (and/c hash? chaperone?)]{
Returns a chaperoned value like @scheme[hash], but with Like @racket[proxy-hash], but with constraints on the given functions
@scheme[hash-ref], @scheme[hash-set!] or @scheme[hash-set] (as and support for immutable hashes. The @scheme[ref-proc] procedure must
applicable) and @scheme[hash-remove] or @scheme[hash-remove!] (as return a found value or a chaperone of the value. The
application) operations on the chaperoned hash table redirected. When @scheme[set-proc] procedure must produce two values: the key that it
@scheme[hash-set] or @scheme[hash-remove] is used on a chaperoned hash is given or a chaperone of the key and the value that it is given or a
table, the resulting hash table is given all of the chaperones of the chaperone of the value. The @scheme[remove-proc] and @scheme[key-proc]
given hash table. In addition, operations like procedures must produce the given key or a chaperone of the key.}
@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
@scheme[hash-iterate-map] implicitly use @scheme[hash-ref] and
therefore redirect through @scheme[ref-proc].
The @scheme[ref-proc] must accept @scheme[hash] and a key passed
@scheme[hash-ref]. It must returned the key or a chaperone of the key
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 the found value or a chaperone of the 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
@scheme[hash-set!] or @scheme[hash-set]; it must produce two values:
the same key or a chaperone of the key and the same value or a
chaperone of the value. The returned key and value are used with
@scheme[hash-set!] or @scheme[hash-set] on the original @scheme[hash]
to install the value.
The @scheme[remove-proc] must accept @scheme[hash] and a key passed to
@scheme[hash-remove!] or @scheme[hash-remove]; it must produce the
same key or a chaperone of the key, which is used with
@scheme[hash-remove!] or @scheme[hash-remove] on the original
@scheme[hash] to remove any mapping using the (chaperoned) 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
other operations that use @scheme[hash-iterate-key] internally); it
must produce the same key or a chaperone of the key, which is then
reported as a key extracted from the table.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-hash] must be odd) add chaperone properties
or override chaperone-property values of @scheme[hash].}
@defproc[(chaperone-struct-type [struct-type struct-type?] @defproc[(chaperone-struct-type [struct-type struct-type?]
[struct-info-proc procedure?] [struct-info-proc procedure?]
[make-constructor-proc (procedure? . -> . procedure?)] [make-constructor-proc (procedure? . -> . procedure?)]
[guard-proc procedure?] [guard-proc procedure?]
[prop chaperone-property?] [prop proxy-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c struct-type? chaperone?)]{ (and/c struct-type? chaperone?)]{
@ -323,12 +446,12 @@ each the same or a chaperone of the corresponding argument. The
created of the chaperoned structure type. created of the chaperoned structure type.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-struct-type] must be even) add chaperone properties to @scheme[chaperone-struct-type] must be even) add proxy properties
or override chaperone-property values of @scheme[struct-type].} or override proxy-property values of @scheme[struct-type].}
@defproc[(chaperone-evt [evt evt?] @defproc[(chaperone-evt [evt evt?]
[proc (evt? . -> . (values evt? (any/c . -> . any/c)))] [proc (evt? . -> . (values evt? (any/c . -> . any/c)))]
[prop chaperone-property?] [prop proxy-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c evt? chaperone?)]{ (and/c evt? chaperone?)]{
@ -345,31 +468,31 @@ a selection. The latter procedure accepts the result of @racket[evt],
and it must return a chaperone of that value. and it must return a chaperone of that value.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-struct-type] must be even) add chaperone properties to @scheme[chaperone-struct-type] must be even) add proxy properties
or override chaperone-property values of @scheme[evt].} or override proxy-property values of @scheme[evt].}
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@section{Chaperone Properties} @section{Proxy Properties}
@defproc[(make-chaperone-property [name symbol?]) @defproc[(make-proxy-property [name symbol?])
(values chaperone-property? (values proxy-property?
(-> any/c boolean?) (-> any/c boolean?)
(-> chaperone? any))]{ (-> chaperone? any))]{
Creates a new structure type property and returns three values: Creates a new @tech{proxy property} and returns three values:
@itemize[ @itemize[
@item{a @deftech{chaperone property descriptor}, for use with @item{a @deftech{proxy property descriptor}, for use with
@scheme[chaperone-procedure], @scheme[chaperone-struct], and @scheme[chaperone-procedure], @scheme[chaperone-struct], and
other chaperone constructors;} other chaperone constructors;}
@item{a @deftech{chaperone property predicate} procedure, which takes @item{a @deftech{proxy property predicate} procedure, which takes
an arbitrary value and returns @scheme[#t] if the value is a an arbitrary value and returns @scheme[#t] if the value is a
chaperone with a value for the property, @scheme[#f] chaperone with a value for the property, @scheme[#f]
otherwise;} otherwise;}
@item{an @deftech{chaperone property accessor} procedure, which @item{an @deftech{proxy property accessor} procedure, which
returns the value associated with a chaperone for the property; returns the value associated with a chaperone for the property;
if a value given to the accessor is not a chaperone or does not if a value given to the accessor is not a chaperone or does not
have a value for the property (ie if the corresponding chaperone have a value for the property (ie if the corresponding chaperone
@ -378,12 +501,12 @@ Creates a new structure type property and returns three values:
]} ]}
@defproc[(chaperone-property? [v any/c]) boolean?]{ @defproc[(proxy-property? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @tech{chaperone property Returns @scheme[#t] if @scheme[v] is a @tech{proxy property
descriptor} value, @scheme[#f] otherwise.} descriptor} value, @scheme[#f] otherwise.}
@defproc[(chaperone-property-accessor-procedure? [v any/c]) boolean?]{ @defproc[(proxy-property-accessor-procedure? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is an accessor procedure produced Returns @scheme[#t] if @scheme[v] is an accessor procedure produced
by @scheme[make-chaperone-property], @scheme[#f] otherwise.} by @scheme[make-proxy-property], @scheme[#f] otherwise.}

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

File diff suppressed because it is too large Load Diff

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

@ -1,3 +1,8 @@
Version 5.0.1.5
Added proxies to go with chaperones, and renamed chaperone property
as proxy property
Version 5.0.1.3
Added ->i to the contract library, improved ->*, adding #:pre and Added ->i to the contract library, improved ->*, adding #:pre and
#:post, as well as making the optional arguments clause optional. #:post, as well as making the optional arguments clause optional.

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

@ -530,6 +530,7 @@ EXPORTS
scheme_eqv scheme_eqv
scheme_equal scheme_equal
scheme_chaperone_of scheme_chaperone_of
scheme_proxy_of
scheme_equal_hash_key scheme_equal_hash_key
scheme_equal_hash_key2 scheme_equal_hash_key2
scheme_recur_equal_hash_key scheme_recur_equal_hash_key

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

@ -545,6 +545,7 @@ EXPORTS
scheme_eqv scheme_eqv
scheme_equal scheme_equal
scheme_chaperone_of scheme_chaperone_of
scheme_proxy_of
scheme_hash_key scheme_hash_key
scheme_equal_hash_key scheme_equal_hash_key
scheme_equal_hash_key2 scheme_equal_hash_key2

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

@ -547,6 +547,7 @@ scheme_eq
scheme_eqv scheme_eqv
scheme_equal scheme_equal
scheme_chaperone_of scheme_chaperone_of
scheme_proxy_of
scheme_equal_hash_key scheme_equal_hash_key
scheme_equal_hash_key2 scheme_equal_hash_key2
scheme_recur_equal_hash_key scheme_recur_equal_hash_key

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

@ -553,6 +553,7 @@ scheme_eq
scheme_eqv scheme_eqv
scheme_equal scheme_equal
scheme_chaperone_of scheme_chaperone_of
scheme_proxy_of
scheme_hash_key scheme_hash_key
scheme_equal_hash_key scheme_equal_hash_key
scheme_equal_hash_key2 scheme_equal_hash_key2

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

@ -47,7 +47,9 @@ static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_p (int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *proxy_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_of (int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_of (int argc, Scheme_Object *argv[]);
static Scheme_Object *proxy_of (int argc, Scheme_Object *argv[]);
typedef struct Equal_Info { typedef struct Equal_Info {
long depth; /* always odd, so it looks like a fixnum */ long depth; /* always odd, so it looks like a fixnum */
@ -55,7 +57,7 @@ typedef struct Equal_Info {
Scheme_Hash_Table *ht; Scheme_Hash_Table *ht;
Scheme_Object *recur; Scheme_Object *recur;
Scheme_Object *next, *next_next; Scheme_Object *next, *next_next;
int for_chaperone; int for_chaperone; /* 2 => for proxy */
} Equal_Info; } Equal_Info;
static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql); static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
@ -106,9 +108,16 @@ void scheme_init_bool (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("chaperone?", p, env); scheme_add_global_constant("chaperone?", p, env);
p = scheme_make_immed_prim(proxy_p, "proxy?", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("proxy?", p, env);
scheme_add_global_constant("chaperone-of?", scheme_add_global_constant("chaperone-of?",
scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2), scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2),
env); env);
scheme_add_global_constant("proxy-of?",
scheme_make_prim_w_arity(proxy_of, "proxy-of?", 2, 2),
env);
} }
static Scheme_Object * static Scheme_Object *
@ -370,7 +379,10 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
if (scheme_eqv(obj1, obj2)) if (scheme_eqv(obj1, obj2))
return 1; return 1;
else if (eql->for_chaperone && SCHEME_CHAPERONEP(obj1)) { else if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_PROXY)
|| (eql->for_chaperone > 1))) {
obj1 = ((Scheme_Chaperone *)obj1)->prev; obj1 = ((Scheme_Chaperone *)obj1)->prev;
goto top; goto top;
} else if (NOT_SAME_TYPE(SCHEME_TYPE(obj1), SCHEME_TYPE(obj2))) { } else if (NOT_SAME_TYPE(SCHEME_TYPE(obj1), SCHEME_TYPE(obj2))) {
@ -401,7 +413,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
return 0; return 0;
} else if (SCHEME_MUTABLE_PAIRP(obj1)) { } else if (SCHEME_MUTABLE_PAIRP(obj1)) {
# include "mzeqchk.inc" # include "mzeqchk.inc"
if (eql->for_chaperone) if (eql->for_chaperone == 1)
return 0; return 0;
if (union_check(obj1, obj2, eql)) if (union_check(obj1, obj2, eql))
return 1; return 1;
@ -413,8 +425,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
return 0; return 0;
} else if (SCHEME_VECTORP(obj1)) { } else if (SCHEME_VECTORP(obj1)) {
# include "mzeqchk.inc" # include "mzeqchk.inc"
if (eql->for_chaperone && (!SCHEME_IMMUTABLEP(obj1) if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2))) || !SCHEME_IMMUTABLEP(obj2)))
return 0; return 0;
if (union_check(obj1, obj2, eql)) if (union_check(obj1, obj2, eql))
return 1; return 1;
@ -435,8 +447,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
} else if (SCHEME_BYTE_STRINGP(obj1) } else if (SCHEME_BYTE_STRINGP(obj1)
|| SCHEME_GENERAL_PATHP(obj1)) { || SCHEME_GENERAL_PATHP(obj1)) {
int l1, l2; int l1, l2;
if (eql->for_chaperone && (!SCHEME_IMMUTABLEP(obj1) if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2))) || !SCHEME_IMMUTABLEP(obj2)))
return 0; return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1); l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2); l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
@ -444,8 +456,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1)); && !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
} else if (SCHEME_CHAR_STRINGP(obj1)) { } else if (SCHEME_CHAR_STRINGP(obj1)) {
int l1, l2; int l1, l2;
if (eql->for_chaperone && (!SCHEME_IMMUTABLEP(obj1) if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2))) || !SCHEME_IMMUTABLEP(obj2)))
return 0; return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1); l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2); l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
@ -507,7 +519,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
return SCHEME_TRUEP(recur); return SCHEME_TRUEP(recur);
} else if (st1 != st2) { } else if (st1 != st2) {
return 0; return 0;
} else if (eql->for_chaperone } else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) { && !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0; return 0;
} else { } else {
@ -526,8 +538,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
} }
} else if (SCHEME_BOXP(obj1)) { } else if (SCHEME_BOXP(obj1)) {
SCHEME_USE_FUEL(1); SCHEME_USE_FUEL(1);
if (eql->for_chaperone && (!SCHEME_IMMUTABLEP(obj1) if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2))) || !SCHEME_IMMUTABLEP(obj2)))
return 0; return 0;
if (union_check(obj1, obj2, eql)) if (union_check(obj1, obj2, eql))
return 1; return 1;
@ -536,7 +548,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
goto top; goto top;
} else if (SCHEME_HASHTP(obj1)) { } else if (SCHEME_HASHTP(obj1)) {
# include "mzeqchk.inc" # include "mzeqchk.inc"
if (eql->for_chaperone) if (eql->for_chaperone == 1)
return 0; return 0;
if (union_check(obj1, obj2, eql)) if (union_check(obj1, obj2, eql))
return 1; return 1;
@ -548,7 +560,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, (Scheme_Hash_Tree *)obj2, eql); return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, (Scheme_Hash_Tree *)obj2, eql);
} else if (SCHEME_BUCKTP(obj1)) { } else if (SCHEME_BUCKTP(obj1)) {
# include "mzeqchk.inc" # include "mzeqchk.inc"
if (eql->for_chaperone) if (eql->for_chaperone == 1)
return 0; return 0;
if (union_check(obj1, obj2, eql)) if (union_check(obj1, obj2, eql))
return 1; return 1;
@ -626,6 +638,14 @@ Scheme_Object * scheme_make_false (void)
} }
static Scheme_Object *chaperone_p(int argc, Scheme_Object *argv[]) static Scheme_Object *chaperone_p(int argc, Scheme_Object *argv[])
{
return ((SCHEME_CHAPERONEP(argv[0])
&& !(SCHEME_CHAPERONE_FLAGS(((Scheme_Chaperone *)argv[0])) & SCHEME_CHAPERONE_IS_PROXY))
? scheme_true
: scheme_false);
}
static Scheme_Object *proxy_p(int argc, Scheme_Object *argv[])
{ {
return (SCHEME_CHAPERONEP(argv[0]) ? scheme_true : scheme_false); return (SCHEME_CHAPERONEP(argv[0]) ? scheme_true : scheme_false);
} }
@ -635,6 +655,11 @@ static Scheme_Object *chaperone_of(int argc, Scheme_Object *argv[])
return (scheme_chaperone_of(argv[0], argv[1]) ? scheme_true : scheme_false); return (scheme_chaperone_of(argv[0], argv[1]) ? scheme_true : scheme_false);
} }
static Scheme_Object *proxy_of(int argc, Scheme_Object *argv[])
{
return (scheme_proxy_of(argv[0], argv[1]) ? scheme_true : scheme_false);
}
int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2) int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
{ {
Equal_Info eql; Equal_Info eql;
@ -649,3 +674,18 @@ int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
return is_equal(obj1, obj2, &eql); return is_equal(obj1, obj2, &eql);
} }
int scheme_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2)
{
Equal_Info eql;
eql.depth = 1;
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next = NULL;
eql.next_next = NULL;
eql.for_chaperone = 2;
return is_equal(obj1, obj2, &eql);
}

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

File diff suppressed because it is too large Load Diff

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

@ -174,6 +174,7 @@ static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *proxy_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]); static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]);
@ -529,6 +530,11 @@ scheme_init_fun (Scheme_Env *env)
"chaperone-procedure", "chaperone-procedure",
2, -1), 2, -1),
env); env);
scheme_add_global_constant("proxy-procedure",
scheme_make_prim_w_arity(proxy_procedure,
"proxy-procedure",
2, -1),
env);
scheme_add_global_constant("primitive?", scheme_add_global_constant("primitive?",
scheme_make_folding_prim(primitive_p, scheme_make_folding_prim(primitive_p,
@ -4061,7 +4067,8 @@ static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])
return scheme_false; return scheme_false;
} }
static Scheme_Object *chaperone_procedure(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[])
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0], *orig, *naya; Scheme_Object *val = argv[0], *orig, *naya;
@ -4071,32 +4078,46 @@ static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[])
val = SCHEME_CHAPERONE_VAL(val); val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_PROCP(val)) if (!SCHEME_PROCP(val))
scheme_wrong_type("chaperone-procedure", "procedure", 0, argc, argv); scheme_wrong_type(name, "procedure", 0, argc, argv);
if (!SCHEME_PROCP(argv[1])) if (!SCHEME_PROCP(argv[1]))
scheme_wrong_type("chaperone-procedure", "procedure", 1, argc, argv); scheme_wrong_type(name, "procedure", 1, argc, argv);
orig = get_or_check_arity(val, -1, NULL); orig = get_or_check_arity(val, -1, NULL);
naya = get_or_check_arity(argv[1], -1, NULL); naya = get_or_check_arity(argv[1], -1, NULL);
if (!is_subarity(orig, naya)) if (!is_subarity(orig, naya))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-procedure: arity of chaperoning procedure: %V" "%s: arity of %s procedure: %V"
" does not cover arity of original procedure: %V", " does not cover arity of original procedure: %V",
name, whating,
argv[1], argv[1],
argv[0]); argv[0]);
props = scheme_parse_chaperone_props("chaperone-procedure", 2, argc, argv); props = scheme_parse_chaperone_props(name, 2, argc, argv);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone); px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_proc_chaperone_type; px->iso.so.type = scheme_proc_chaperone_type;
px->val = val; px->val = val;
px->prev = argv[0]; px->prev = argv[0];
px->props = props; px->props = props;
px->redirects = argv[1]; px->redirects = argv[1];
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
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[])
{
return do_chaperone_procedure("proxy-procedure", "proxying", 1, argc, argv);
}
static Scheme_Object *apply_chaperone_k(void) static Scheme_Object *apply_chaperone_k(void)
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
@ -4135,6 +4156,7 @@ static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Obje
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val) Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val)
{ {
const char *what;
Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v; Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v;
int c, i, need_restore = 0; int c, i, need_restore = 0;
@ -4154,6 +4176,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} }
} }
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
what = "chaperone";
else
what = "proxy";
/* Ensure that the original procedure accepts `argc' arguments: */ /* Ensure that the original procedure accepts `argc' arguments: */
a[0] = px->prev; a[0] = px->prev;
if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) { if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) {
@ -4162,7 +4189,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
in case the methodness of the original procedure is different in case the methodness of the original procedure is different
from the chaperone, or in case the procedures have different names. */ from the chaperone, or in case the procedures have different names. */
(void)_scheme_apply_multi(px->prev, argc, argv); (void)_scheme_apply_multi(px->prev, argc, argv);
scheme_signal_error("internal error: unexpected success applying chaperoned procedure"); scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure");
return NULL; return NULL;
} }
@ -4185,24 +4212,27 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
memmove(argv2, argv2 + 1, sizeof(Scheme_Object*)*argc); memmove(argv2, argv2 + 1, sizeof(Scheme_Object*)*argc);
} else } else
post = NULL; post = NULL;
for (i = 0; i < argc; i++) { if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) {
if (!scheme_chaperone_of(argv2[i], argv[i])) { for (i = 0; i < argc; i++) {
if (argc == 1) if (!scheme_chaperone_of(argv2[i], argv[i])) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, if (argc == 1)
"procedure chaperone: %V: result: %V is not a chaperone of argument: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
px->redirects, "procedure chaperone: %V: result: %V is not a chaperone of argument: %V",
argv2[i], argv[i]); px->redirects,
else argv2[i], argv[i]);
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, else
"procedure chaperone: %V: %d%s result: %V is not a chaperone of argument: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
px->redirects, "procedure chaperone: %V: %d%s result: %V is not a chaperone of argument: %V",
i, scheme_number_suffix(i), px->redirects,
argv2[i], argv[i]); i, scheme_number_suffix(i),
argv2[i], argv[i]);
}
} }
} }
} else { } else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"procedure chaperone: %V: returned %d values, expected %d or %d", "procedure %s: %V: returned %d values, expected %d or %d",
what,
px->redirects, px->redirects,
c, argc, argc + 1); c, argc, argc + 1);
return NULL; return NULL;
@ -4232,7 +4262,8 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
/* First element is a filter for the result(s) */ /* First element is a filter for the result(s) */
if (!SCHEME_PROCP(post)) if (!SCHEME_PROCP(post))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure chaperone: %V: expected <procedure> as first result, produced: %V", "procedure %s: %V: expected <procedure> as first result, produced: %V",
what,
px->redirects, px->redirects,
post); post);
if (auto_val) { if (auto_val) {
@ -4277,24 +4308,27 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
} }
if (c == argc) { if (c == argc) {
for (i = 0; i < argc; i++) { if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) {
if (!scheme_chaperone_of(argv2[i], argv[i])) { for (i = 0; i < argc; i++) {
if (argc == 1) if (!scheme_chaperone_of(argv2[i], argv[i])) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, if (argc == 1)
"procedure-result chaperone: %V: result: %V is not a chaperone of original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
post, "procedure-result chaperone: %V: result: %V is not a chaperone of original result: %V",
argv2[i], argv[i]); post,
else argv2[i], argv[i]);
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, else
"procedure-result chaperone: %V: %d%s result: %V is not a chaperone of original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
post, "procedure-result chaperone: %V: %d%s result: %V is not a chaperone of original result: %V",
i, scheme_number_suffix(i), post,
argv2[i], argv[i]); i, scheme_number_suffix(i),
argv2[i], argv[i]);
}
} }
} }
} else { } else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"procedure-result chaperone: %V: returned %d values, expected %d", "procedure-result %s: %V: returned %d values, expected %d",
what,
post, post,
argc, c); argc, c);
return NULL; return NULL;

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

@ -6223,10 +6223,10 @@ static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec
} }
static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app, static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app,
Scheme_Type lo_ty, Scheme_Type hi_ty, int can_chaperone, Scheme_Type lo_ty, Scheme_Type hi_ty, int can_chaperone,
Branch_Info *for_branch, int branch_short, int need_sync) Branch_Info *for_branch, int branch_short, int need_sync)
{ {
GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *ref4; GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *ref4, *ref5;
int int_ok; int int_ok;
int_ok = ((lo_ty <= scheme_integer_type) && (scheme_integer_type <= hi_ty)); int_ok = ((lo_ty <= scheme_integer_type) && (scheme_integer_type <= hi_ty));
@ -6253,10 +6253,11 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
ref3 = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); ref3 = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
ref4 = NULL; ref4 = NULL;
ref = NULL; ref = NULL;
ref5 = NULL;
} else { } else {
ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type); jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
if (can_chaperone) { if (can_chaperone > 0) {
__START_INNER_TINY__(branch_short); __START_INNER_TINY__(branch_short);
ref3 = jit_bnei_i(jit_forward(), JIT_R1, scheme_chaperone_type); ref3 = jit_bnei_i(jit_forward(), JIT_R1, scheme_chaperone_type);
jit_ldxi_p(JIT_R1, JIT_R0, (long)&((Scheme_Chaperone *)0x0)->val); jit_ldxi_p(JIT_R1, JIT_R0, (long)&((Scheme_Chaperone *)0x0)->val);
@ -6272,6 +6273,12 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
ref3 = jit_blti_p(jit_forward(), JIT_R1, lo_ty); ref3 = jit_blti_p(jit_forward(), JIT_R1, lo_ty);
ref4 = jit_bgti_p(jit_forward(), JIT_R1, hi_ty); ref4 = jit_bgti_p(jit_forward(), JIT_R1, hi_ty);
} }
if (can_chaperone < 0) {
/* Make sure it's not a proxy */
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);
} else
ref5 = NULL;
if (int_ok) { if (int_ok) {
mz_patch_branch(ref); mz_patch_branch(ref);
} }
@ -6282,6 +6289,7 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
} }
add_branch_false(for_branch, ref3); add_branch_false(for_branch, ref3);
add_branch_false(for_branch, ref4); add_branch_false(for_branch, ref4);
add_branch_false(for_branch, ref5);
branch_for_true(jitter, for_branch); branch_for_true(jitter, for_branch);
CHECK_LIMIT(); CHECK_LIMIT();
} else { } else {
@ -6294,6 +6302,9 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
if (ref4) { if (ref4) {
mz_patch_branch(ref4); mz_patch_branch(ref4);
} }
if (ref5) {
mz_patch_branch(ref5);
}
(void)jit_movi_p(JIT_R0, scheme_false); (void)jit_movi_p(JIT_R0, scheme_false);
mz_patch_ucbranch(ref2); mz_patch_ucbranch(ref2);
} }
@ -6441,6 +6452,9 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
generate_inlined_type_test(jitter, app, scheme_prim_type, scheme_proc_chaperone_type, 1, for_branch, branch_short, need_sync); generate_inlined_type_test(jitter, app, scheme_prim_type, scheme_proc_chaperone_type, 1, for_branch, branch_short, need_sync);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "chaperone?")) { } else if (IS_NAMED_PRIM(rator, "chaperone?")) {
generate_inlined_type_test(jitter, app, scheme_proc_chaperone_type, scheme_chaperone_type, -1, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "proxy?")) {
generate_inlined_type_test(jitter, app, scheme_proc_chaperone_type, scheme_chaperone_type, 0, for_branch, branch_short, need_sync); generate_inlined_type_test(jitter, app, scheme_proc_chaperone_type, scheme_chaperone_type, 0, for_branch, branch_short, need_sync);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "vector?")) { } else if (IS_NAMED_PRIM(rator, "vector?")) {

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

@ -90,6 +90,7 @@ static Scheme_Object *box_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *unbox (int argc, Scheme_Object *argv[]); static Scheme_Object *unbox (int argc, Scheme_Object *argv[]);
static Scheme_Object *set_box (int argc, Scheme_Object *argv[]); static Scheme_Object *set_box (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_box(int argc, Scheme_Object **argv);
static Scheme_Object *make_hash(int argc, Scheme_Object *argv[]); static Scheme_Object *make_hash(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_hasheq(int argc, Scheme_Object *argv[]); static Scheme_Object *make_hasheq(int argc, Scheme_Object *argv[]);
@ -126,6 +127,7 @@ static Scheme_Object *equal_hash_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_hash2_code(int argc, Scheme_Object *argv[]); static Scheme_Object *equal_hash2_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *eqv_hash_code(int argc, Scheme_Object *argv[]); static Scheme_Object *eqv_hash_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_hash(int argc, Scheme_Object **argv);
static Scheme_Object *make_weak_box(int argc, Scheme_Object *argv[]); static Scheme_Object *make_weak_box(int argc, Scheme_Object *argv[]);
static Scheme_Object *weak_box_value(int argc, Scheme_Object *argv[]); static Scheme_Object *weak_box_value(int argc, Scheme_Object *argv[]);
@ -469,6 +471,11 @@ scheme_init_list (Scheme_Env *env)
"chaperone-box", "chaperone-box",
3, -1), 3, -1),
env); env);
scheme_add_global_constant("proxy-box",
scheme_make_prim_w_arity(proxy_box,
"proxy-box",
3, -1),
env);
scheme_add_global_constant("make-hash", scheme_add_global_constant("make-hash",
scheme_make_immed_prim(make_hash, scheme_make_immed_prim(make_hash,
@ -627,6 +634,11 @@ scheme_init_list (Scheme_Env *env)
"chaperone-hash", "chaperone-hash",
5, -1), 5, -1),
env); env);
scheme_add_global_constant("proxy-hash",
scheme_make_prim_w_arity(proxy_hash,
"proxy-hash",
5, -1),
env);
scheme_add_global_constant("eq-hash-code", scheme_add_global_constant("eq-hash-code",
scheme_make_immed_prim(eq_hash_code, scheme_make_immed_prim(eq_hash_code,
@ -1549,11 +1561,12 @@ static Scheme_Object *chaperone_unbox(Scheme_Object *obj)
a[1] = orig; a[1] = orig;
obj = _scheme_apply(SCHEME_CAR(px->redirects), 2, a); obj = _scheme_apply(SCHEME_CAR(px->redirects), 2, a);
if (!scheme_chaperone_of(obj, orig)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(obj, orig))
"unbox: chaperone produced a result: %V that is not a chaperone of the original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
obj, "unbox: chaperone produced a result: %V that is not a chaperone of the original result: %V",
orig); obj,
orig);
return obj; return obj;
} }
@ -1588,11 +1601,12 @@ static void chaperone_set_box(Scheme_Object *obj, Scheme_Object *v)
a[1] = v; a[1] = v;
v = _scheme_apply(SCHEME_CDR(px->redirects), 2, a); v = _scheme_apply(SCHEME_CDR(px->redirects), 2, a);
if (!scheme_chaperone_of(v, a[1])) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(v, a[1]))
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
v, "vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
a[1]); v,
a[1]);
} }
} }
} }
@ -1642,7 +1656,7 @@ static Scheme_Object *set_box(int c, Scheme_Object *p[])
return scheme_void; return scheme_void;
} }
static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_box(const char *name, int is_proxy, int argc, Scheme_Object **argv)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0]; Scheme_Object *val = argv[0];
@ -1652,25 +1666,38 @@ static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv)
if (SCHEME_CHAPERONEP(val)) if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val); val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_BOXP(val)) if (!SCHEME_BOXP(val) || (is_proxy && !SCHEME_MUTABLEP(val)))
scheme_wrong_type("chaperone-box", "box", 0, argc, argv); scheme_wrong_type(name, is_proxy ? "mutable box" : "box", 0, argc, argv);
scheme_check_proc_arity("chaperone-box", 2, 1, argc, argv); scheme_check_proc_arity(name, 2, 1, argc, argv);
scheme_check_proc_arity("chaperone-box", 2, 2, argc, argv); scheme_check_proc_arity(name, 2, 2, argc, argv);
redirects = scheme_make_pair(argv[1], argv[2]); redirects = scheme_make_pair(argv[1], argv[2]);
props = scheme_parse_chaperone_props("chaperone-box", 3, argc, argv); props = scheme_parse_chaperone_props(name, 3, argc, argv);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone); px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_chaperone_type; px->iso.so.type = scheme_chaperone_type;
px->val = val; px->val = val;
px->prev = argv[0]; px->prev = argv[0];
px->props = props; px->props = props;
px->redirects = redirects; px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
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)
{
return do_chaperone_box("proxy-box", 1, argc, argv);
}
static int compare_equal(void *v1, void *v2) static int compare_equal(void *v1, void *v2)
{ {
return !scheme_equal((Scheme_Object *)v1, (Scheme_Object *)v2); return !scheme_equal((Scheme_Object *)v1, (Scheme_Object *)v2);
@ -2600,7 +2627,7 @@ static Scheme_Object *hash_table_iterate_key(int argc, Scheme_Object *argv[])
return hash_table_index("hash-iterate-key", argc, argv, 0); return hash_table_index("hash-iterate-key", argc, argv, 0);
} }
static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_hash(const char *name, int is_proxy, int argc, Scheme_Object **argv)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0]; Scheme_Object *val = argv[0];
@ -2610,12 +2637,14 @@ static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv)
if (SCHEME_CHAPERONEP(val)) if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val); val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_HASHTP(val) && !SCHEME_HASHTRP(val) && !SCHEME_BUCKTP(val)) if (!SCHEME_HASHTP(val)
scheme_wrong_type("chaperone-hash", "hash", 0, argc, argv); && (is_proxy || !SCHEME_HASHTRP(val))
scheme_check_proc_arity("chaperone-hash", 2, 1, argc, argv); /* ref */ && !SCHEME_BUCKTP(val))
scheme_check_proc_arity("chaperone-hash", 3, 2, argc, argv); /* set! */ scheme_wrong_type(name, is_proxy ? "mutable hash" : "hash", 0, argc, argv);
scheme_check_proc_arity("chaperone-hash", 2, 3, argc, argv); /* remove */ scheme_check_proc_arity(name, 2, 1, argc, argv); /* ref */
scheme_check_proc_arity("chaperone-hash", 2, 4, argc, argv); /* key */ scheme_check_proc_arity(name, 3, 2, argc, argv); /* set! */
scheme_check_proc_arity(name, 2, 3, argc, argv); /* remove */
scheme_check_proc_arity(name, 2, 4, argc, argv); /* key */
redirects = scheme_make_vector(4, NULL); redirects = scheme_make_vector(4, NULL);
SCHEME_VEC_ELS(redirects)[0] = argv[1]; SCHEME_VEC_ELS(redirects)[0] = argv[1];
@ -2624,18 +2653,31 @@ static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv)
SCHEME_VEC_ELS(redirects)[3] = argv[4]; SCHEME_VEC_ELS(redirects)[3] = argv[4];
redirects = scheme_box(redirects); /* so it doesn't look like a struct chaperone */ redirects = scheme_box(redirects); /* so it doesn't look like a struct chaperone */
props = scheme_parse_chaperone_props("chaperone-hash", 5, argc, argv); props = scheme_parse_chaperone_props(name, 5, argc, argv);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone); px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_chaperone_type; px->iso.so.type = scheme_chaperone_type;
px->val = val; px->val = val;
px->prev = argv[0]; px->prev = argv[0];
px->props = props; px->props = props;
px->redirects = redirects; px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
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)
{
return do_chaperone_hash("proxy-hash", 1, argc, argv);
}
static Scheme_Object *transfer_chaperone(Scheme_Object *chaperone, Scheme_Object *v) static Scheme_Object *transfer_chaperone(Scheme_Object *chaperone, Scheme_Object *v)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
@ -2783,12 +2825,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
red, red,
cnt); cnt);
if (!scheme_chaperone_of(vals[0], k)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(vals[0], k))
"%s: chaperone produced a key: %V that is not a chaperone of the original key: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
who, "%s: chaperone produced a key: %V that is not a chaperone of the original key: %V",
vals[0], who,
k); vals[0],
k);
k = vals[0]; k = vals[0];
o = vals[1]; o = vals[1];
@ -2818,12 +2861,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
what = "key"; what = "key";
} }
if (!scheme_chaperone_of(o, orig)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(o, orig))
"%s: chaperone produced a %s: %V that is not a chaperone of the original %s: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
who, what, "%s: chaperone produced a %s: %V that is not a chaperone of the original %s: %V",
o, who, what,
what, orig); o,
what, orig);
} }
if ((mode == 0) || (mode == 3)) if ((mode == 0) || (mode == 3))

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

@ -2590,6 +2590,11 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_utf8_string(pp, ">", 0, 1); print_utf8_string(pp, ">", 0, 1);
} }
} }
else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_chaperone_type))
{
/* some kind of chaperone that doesn't normally print */
closed = print(SCHEME_CHAPERONE_VAL(obj), notdisplay, compact, ht, mt, pp);
}
else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_regexp_type)) else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_regexp_type))
{ {
if (compact) { if (compact) {

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

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

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

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

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

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

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

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

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1002 #define EXPECTED_PRIM_COUNT 1010
#define EXPECTED_UNSAFE_COUNT 69 #define EXPECTED_UNSAFE_COUNT 69
#define EXPECTED_FLFXNUM_COUNT 60 #define EXPECTED_FLFXNUM_COUNT 60
#define EXPECTED_FUTURES_COUNT 5 #define EXPECTED_FUTURES_COUNT 5

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

@ -756,13 +756,16 @@ Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv);
Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym); Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym);
typedef struct Scheme_Chaperone { typedef struct Scheme_Chaperone {
Scheme_Object so; Scheme_Inclhash_Object iso; /* 0x1 => proxy, rather than a checking chaperone */
Scheme_Object *val; /* root object */ Scheme_Object *val; /* root object */
Scheme_Object *prev; /* immediately chaperoned object */ Scheme_Object *prev; /* immediately chaperoned object */
Scheme_Hash_Tree *props; Scheme_Hash_Tree *props;
Scheme_Object *redirects; /* specific to the type of chaperone and root object */ Scheme_Object *redirects; /* specific to the type of chaperone and root object */
} Scheme_Chaperone; } Scheme_Chaperone;
#define SCHEME_CHAPERONE_FLAGS(c) MZ_OPT_HASH_KEY(&(c)->iso)
#define SCHEME_CHAPERONE_IS_PROXY 0x1
#define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val) #define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val)
#define SCHEME_P_CHAPERONEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_chaperone_type)) #define SCHEME_P_CHAPERONEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_chaperone_type))

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

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

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

@ -164,6 +164,7 @@ static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv);
static Scheme_Struct_Type *hash_prefab(Scheme_Struct_Type *type); static Scheme_Struct_Type *hash_prefab(Scheme_Struct_Type *type);
static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_struct(int argc, Scheme_Object **argv);
static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv);
static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]); static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]);
@ -592,9 +593,9 @@ scheme_init_struct (Scheme_Env *env)
"struct-type-property-accessor-procedure?", "struct-type-property-accessor-procedure?",
1, 1), 1, 1),
env); env);
scheme_add_global_constant("chaperone-property-accessor-procedure?", scheme_add_global_constant("proxy-property-accessor-procedure?",
scheme_make_prim_w_arity(chaperone_prop_getter_p, scheme_make_prim_w_arity(chaperone_prop_getter_p,
"chaperone-property-accessor-procedure?", "proxy-property-accessor-procedure?",
1, 1), 1, 1),
env); env);
@ -687,22 +688,31 @@ scheme_init_struct (Scheme_Env *env)
"chaperone-struct", "chaperone-struct",
1, -1), 1, -1),
env); env);
scheme_add_global_constant("proxy-struct",
scheme_make_prim_w_arity(proxy_struct,
"proxy-struct",
1, -1),
env);
scheme_add_global_constant("chaperone-struct-type", scheme_add_global_constant("chaperone-struct-type",
scheme_make_prim_w_arity(chaperone_struct_type, scheme_make_prim_w_arity(chaperone_struct_type,
"chaperone-struct-type", "chaperone-struct-type",
1, -1), 1, -1),
env); env);
scheme_add_global_constant("make-chaperone-property", scheme_add_global_constant("make-proxy-property",
scheme_make_prim_w_arity2(make_chaperone_property, scheme_make_prim_w_arity2(make_chaperone_property,
"make-chaperone-property", "make-proxy-property",
1, 1, 1, 1,
3, 3), 3, 3),
env); env);
scheme_add_global_constant("chaperone-property?", scheme_add_global_constant("proxy-property?",
scheme_make_folding_prim(chaperone_property_p, scheme_make_folding_prim(chaperone_property_p,
"chaperone-property?", "proxy-property?",
1, 1, 1), 1, 1, 1),
env); env);
scheme_add_global_constant("proxy-prop:application-mark",
scheme_false,
env);
} }
/*========================================================================*/ /*========================================================================*/
@ -952,12 +962,13 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object
a[1] = orig; a[1] = orig;
v = _scheme_apply(red, 2, a); v = _scheme_apply(red, 2, a);
if (!scheme_chaperone_of(v, orig)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(v, orig))
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
who, "%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
v , who,
orig); v ,
orig);
return v; return v;
} }
@ -1000,7 +1011,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
if (type == scheme_struct_property_type) if (type == scheme_struct_property_type)
who = "make-struct-type-property"; who = "make-struct-type-property";
else else
who = "make-chaperone-property"; who = "make-proxy-property";
if (!SCHEME_SYMBOLP(argv[0])) if (!SCHEME_SYMBOLP(argv[0]))
scheme_wrong_type(who, "symbol", 0, argc, argv); scheme_wrong_type(who, "symbol", 0, argc, argv);
@ -1100,7 +1111,7 @@ Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name)
Scheme_Object *scheme_chaperone_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s) Scheme_Object *scheme_chaperone_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s)
{ {
if (SCHEME_CHAPERONEP(s)) if (SCHEME_CHAPERONEP(s))
return do_chaperone_prop_accessor("struct-property-ref", prop, s); return do_chaperone_prop_accessor("proxy-property-ref", prop, s);
else else
return do_prop_accessor(prop, s); return do_prop_accessor(prop, s);
} }
@ -1803,12 +1814,13 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in
red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i]; red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i];
o = _scheme_apply(red, 2, a); o = _scheme_apply(red, 2, a);
if (!scheme_chaperone_of(o, orig)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(o, orig))
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
who, "%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
o, who,
orig); o,
orig);
return o; return o;
} }
@ -1847,12 +1859,13 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem
a[1] = v; a[1] = v;
v = _scheme_apply(red, 2, a); v = _scheme_apply(red, 2, a);
if (!scheme_chaperone_of(v, a[1])) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(v, a[1]))
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
who, "%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
v, who,
a[1]); v,
a[1]);
} }
} }
} }
@ -2318,11 +2331,18 @@ static Scheme_Object *proc_struct_type_p(int argc, Scheme_Object *argv[])
static Scheme_Object *apply_chaperones(const char *who, Scheme_Object *procs, int argc, Scheme_Object **a) static Scheme_Object *apply_chaperones(const char *who, Scheme_Object *procs, int argc, Scheme_Object **a)
{ {
Scheme_Object *v, **vals, *v1[1]; Scheme_Object *v, **vals, *v1[1];
int cnt, i; int cnt, i, is_proxy;
Scheme_Thread *p; Scheme_Thread *p;
while (SCHEME_PAIRP(procs)) { while (SCHEME_PAIRP(procs)) {
v = _scheme_apply_multi(SCHEME_CAR(procs), argc, a); v = SCHEME_CAR(procs);
if (SCHEME_BOXP(v)) {
is_proxy = 1;
v = SCHEME_BOX_VAL(v);
} else
is_proxy = 0;
v = _scheme_apply_multi(v, argc, a);
if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) { if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
p = scheme_current_thread; p = scheme_current_thread;
@ -2346,13 +2366,15 @@ static Scheme_Object *apply_chaperones(const char *who, Scheme_Object *procs, in
cnt, argc); cnt, argc);
} }
for (i = 0; i < argc; i++) { if (!is_proxy) {
if (!scheme_chaperone_of(vals[i], a[i])) for (i = 0; i < argc; i++) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(vals[i], a[i]))
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
who, "%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
vals[i], who,
a[i]); vals[i],
a[i]);
}
} }
a = vals; a = vals;
@ -2364,14 +2386,18 @@ static Scheme_Object *apply_chaperones(const char *who, Scheme_Object *procs, in
static Scheme_Object *struct_info_chaperone(Scheme_Object *o, Scheme_Object *si, Scheme_Object *b) static Scheme_Object *struct_info_chaperone(Scheme_Object *o, Scheme_Object *si, Scheme_Object *b)
{ {
Scheme_Object *procs = scheme_null, *a[2]; Scheme_Object *procs = scheme_null, *proc, *a[2];
Scheme_Chaperone *px; Scheme_Chaperone *px;
while (SCHEME_CHAPERONEP(o)) { while (SCHEME_CHAPERONEP(o)) {
px = (Scheme_Chaperone *)o; px = (Scheme_Chaperone *)o;
if (SCHEME_VECTORP(px->redirects)) { if (SCHEME_VECTORP(px->redirects)) {
if (SCHEME_VEC_ELS(px->redirects)[1]) if (SCHEME_VEC_ELS(px->redirects)[1]) {
procs = scheme_make_pair(SCHEME_VEC_ELS(px->redirects)[1], procs); proc = SCHEME_VEC_ELS(px->redirects)[1];
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)
proc = scheme_box(proc);
procs = scheme_make_pair(proc, procs);
}
} }
o = px->prev; o = px->prev;
} }
@ -2507,13 +2533,16 @@ static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object
static Scheme_Object *struct_type_info_chaperone(Scheme_Object *o, Scheme_Object **a) static Scheme_Object *struct_type_info_chaperone(Scheme_Object *o, Scheme_Object **a)
{ {
Scheme_Object *procs = scheme_null; Scheme_Object *procs = scheme_null, *proc;
Scheme_Chaperone *px; Scheme_Chaperone *px;
while (SCHEME_NP_CHAPERONEP(o)) { while (SCHEME_NP_CHAPERONEP(o)) {
px = (Scheme_Chaperone *)o; px = (Scheme_Chaperone *)o;
if (SCHEME_PAIRP(px->redirects)) { if (SCHEME_PAIRP(px->redirects)) {
procs = scheme_make_pair(SCHEME_CAR(px->redirects), procs); proc = SCHEME_CAR(px->redirects);
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)
proc = scheme_box(proc);
procs = scheme_make_pair(proc, procs);
} }
o = px->prev; o = px->prev;
} }
@ -2553,13 +2582,16 @@ static Scheme_Object *struct_type_pred(int argc, Scheme_Object *argv[])
static Scheme_Object *type_constr_chaperone(Scheme_Object *o, Scheme_Object *v) static Scheme_Object *type_constr_chaperone(Scheme_Object *o, Scheme_Object *v)
{ {
Scheme_Object *procs = scheme_null, *a[1]; Scheme_Object *procs = scheme_null, *proc, *a[1];
Scheme_Chaperone *px; Scheme_Chaperone *px;
while (SCHEME_NP_CHAPERONEP(o)) { while (SCHEME_NP_CHAPERONEP(o)) {
px = (Scheme_Chaperone *)o; px = (Scheme_Chaperone *)o;
if (SCHEME_PAIRP(px->redirects)) { if (SCHEME_PAIRP(px->redirects)) {
procs = scheme_make_pair(SCHEME_CADR(px->redirects), procs); proc = SCHEME_CADR(px->redirects);
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)
proc = scheme_box(proc);
procs = scheme_make_pair(proc, procs);
} }
o = px->prev; o = px->prev;
} }
@ -3042,23 +3074,34 @@ Scheme_Object *handle_evt_p(int argc, Scheme_Object *argv[])
return NULL; return NULL;
} }
static Scheme_Object *chaperone_result_guard_proc(void *data, int argc, Scheme_Object *argv[]) static Scheme_Object *do_chaperone_result_guard_proc(int is_proxy, void *data, int argc, Scheme_Object *argv[])
{ {
Scheme_Object *proc = (Scheme_Object *)data, *o, *a[1]; Scheme_Object *proc = (Scheme_Object *)data, *o, *a[1];
a[0] = argv[0]; a[0] = argv[0];
o = _scheme_apply(proc, 1, a); o = _scheme_apply(proc, 1, a);
if (!scheme_chaperone_of(o, a[0])) if (!is_proxy)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(o, a[0]))
"evt result chaperone: chaperone produced a value: %V that is not a chaperone of the original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
o, "evt result chaperone: chaperone produced a value: %V that is not a chaperone of the original result: %V",
a[0]); o,
a[0]);
return o; return o;
} }
static Scheme_Object *chaperone_guard_proc(void *data, int argc, Scheme_Object *argv[]) static Scheme_Object *chaperone_result_guard_proc(void *data, int argc, Scheme_Object *argv[])
{
return do_chaperone_result_guard_proc(0, data, argc, argv);
}
static Scheme_Object *proxy_result_guard_proc(void *data, int argc, Scheme_Object *argv[])
{
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[])
{ {
Scheme_Object *evt = SCHEME_CAR((Scheme_Object *)data); Scheme_Object *evt = SCHEME_CAR((Scheme_Object *)data);
Scheme_Object *proc = SCHEME_CDR((Scheme_Object *)data); Scheme_Object *proc = SCHEME_CDR((Scheme_Object *)data);
@ -3085,22 +3128,28 @@ static Scheme_Object *chaperone_guard_proc(void *data, int argc, Scheme_Object *
if (cnt != 2) if (cnt != 2)
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"evt chaperone: %V: returned %d values, expected 2", "evt %s: %V: returned %d values, expected 2",
(is_proxy ? "proxy" : "chaperone"),
proc, proc,
cnt); cnt);
if (!scheme_chaperone_of(vals[0], evt)) if (!is_proxy)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(vals[0], evt))
"evt chaperone: chaperone produced a value: %V that is not a chaperone of the original event: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
vals[0], "evt chaperone: chaperone produced a value: %V that is not a chaperone of the original event: %V",
evt); vals[0],
evt);
if (!scheme_check_proc_arity(NULL, 1, 1, 1, vals)) if (!scheme_check_proc_arity(NULL, 1, 1, 1, vals))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"evt chaperone: expected a value of type <procedure (arity 2)> as second chaprone result, received: %V", "evt %s: expected a value of type <procedure (arity 2)> as second %s result, received: %V",
(is_proxy ? "proxy" : "chaperone"),
(is_proxy ? "proxy" : "chaperone"),
vals[1]); vals[1]);
a[0] = vals[0]; a[0] = vals[0];
o = scheme_make_closed_prim_w_arity(chaperone_result_guard_proc, o = scheme_make_closed_prim_w_arity((is_proxy
? proxy_result_guard_proc
: chaperone_result_guard_proc),
(void *)vals[1], (void *)vals[1],
"evt-result-chaperone", "evt-result-chaperone",
1, 1); 1, 1);
@ -3109,7 +3158,17 @@ static Scheme_Object *chaperone_guard_proc(void *data, int argc, Scheme_Object *
return scheme_wrap_evt(1, a); return scheme_wrap_evt(1, a);
} }
static Scheme_Object *chaperone_evt(int argc, Scheme_Object *argv[]) static Scheme_Object *chaperone_guard_proc(void *data, int argc, Scheme_Object *argv[])
{
return do_chaperone_guard_proc(0, data, argc, argv);
}
static Scheme_Object *proxy_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[])
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *o, *val, *a[1]; Scheme_Object *o, *val, *a[1];
@ -3120,32 +3179,44 @@ static Scheme_Object *chaperone_evt(int argc, Scheme_Object *argv[])
val = SCHEME_CHAPERONE_VAL(val); val = SCHEME_CHAPERONE_VAL(val);
if (!scheme_is_evt(val)) if (!scheme_is_evt(val))
scheme_wrong_type("chaperone-evt", "evt", 0, argc, argv); scheme_wrong_type(name, "evt", 0, argc, argv);
scheme_check_proc_arity("chaperone-evt", 1, 1, argc, argv); scheme_check_proc_arity(name, 1, 1, argc, argv);
props = scheme_parse_chaperone_props("chaperone-evt", 2, argc, argv); props = scheme_parse_chaperone_props(name, 2, argc, argv);
o = scheme_make_pair(argv[0], argv[1]); o = scheme_make_pair(argv[0], argv[1]);
o = scheme_make_closed_prim_w_arity(chaperone_guard_proc, o = scheme_make_closed_prim_w_arity((is_proxy
? proxy_guard_proc
: chaperone_guard_proc),
(void *)o, (void *)o,
"evt-chaperone", (is_proxy
? "evt-chaperone"
: "evt-proxy"),
1, 1); 1, 1);
a[0] = o; a[0] = o;
o = nack_evt(1, a); o = nack_evt(1, a);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone); px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
if (SCHEME_PROCP(val)) if (SCHEME_PROCP(val))
px->so.type = scheme_proc_chaperone_type; px->iso.so.type = scheme_proc_chaperone_type;
else else
px->so.type = scheme_chaperone_type; px->iso.so.type = scheme_chaperone_type;
px->val = val; px->val = val;
px->prev = argv[0]; px->prev = argv[0];
px->props = props; px->props = props;
px->redirects = o; px->redirects = o;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
static Scheme_Object *chaperone_evt(int argc, Scheme_Object *argv[])
{
return do_chaperone_evt("chaperone-evt", 0, argc, argv);
}
static int chaperone_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo) static int chaperone_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
@ -4995,7 +5066,7 @@ static Scheme_Object *check_exn_source_property_value_ok(int argc, Scheme_Object
/**********************************************************************/ /**********************************************************************/
static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_struct(const char *name, int is_proxy, int argc, Scheme_Object **argv)
/* (chaperone-struct v mutator/selector replacement ...) */ /* (chaperone-struct v mutator/selector replacement ...) */
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
@ -5027,7 +5098,7 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
proc = argv[i]; proc = argv[i];
if ((i > 1) && SAME_TYPE(SCHEME_TYPE(proc), scheme_chaperone_property_type)) { if ((i > 1) && SAME_TYPE(SCHEME_TYPE(proc), scheme_chaperone_property_type)) {
props = scheme_parse_chaperone_props("chaperone-box", i, argc, argv); props = scheme_parse_chaperone_props(name, i, argc, argv);
break; break;
} }
@ -5040,15 +5111,17 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
} else if (SCHEME_TRUEP(struct_getter_p(1, a))) { } else if (SCHEME_TRUEP(struct_getter_p(1, a))) {
kind = "accessor"; kind = "accessor";
offset = 0; offset = 0;
} else if (SCHEME_TRUEP(struct_prop_getter_p(1, a))) { } else if (!is_proxy && SCHEME_TRUEP(struct_prop_getter_p(1, a))) {
kind = "struct-type property accessor"; kind = "struct-type property accessor";
offset = -1; offset = -1;
} else if (SAME_OBJ(proc, struct_info_proc)) { } else if (!is_proxy && SAME_OBJ(proc, struct_info_proc)) {
kind = "struct-info"; kind = "struct-info";
offset = -2; offset = -2;
} else { } else {
scheme_wrong_type("chaperone-struct", scheme_wrong_type(name,
"structure accessor, structure mutator, struct-type property accessor, or `struct-info'", (is_proxy
? "structure accessor or structure mutator"
: "structure accessor, structure mutator, struct-type property accessor, or `struct-info'"),
i, argc, argv); i, argc, argv);
return NULL; return NULL;
} }
@ -5056,7 +5129,8 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
if (offset == -2) { if (offset == -2) {
if (si_chaperone) if (si_chaperone)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: struct-info procedure supplied a second time: %V", "%s: struct-info procedure supplied a second time: %V",
name,
a[0]); a[0]);
pi = NULL; pi = NULL;
prop = NULL; prop = NULL;
@ -5067,7 +5141,8 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
if (!scheme_chaperone_struct_type_property_ref(prop, argv[0])) if (!scheme_chaperone_struct_type_property_ref(prop, argv[0]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: %s %V does not apply to given object: %V", "%s: %s %V does not apply to given object: %V",
name,
kind, kind,
a[0], a[0],
argv[0]); argv[0]);
@ -5076,7 +5151,8 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
if (scheme_hash_tree_get(red_props, prop)) if (scheme_hash_tree_get(red_props, prop))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: given %s is for the same property as a previous %s argument: %V", "%s: given %s is for the same property as a previous %s argument: %V",
name,
kind, kind, kind, kind,
a[0]); a[0]);
arity = 2; arity = 2;
@ -5086,29 +5162,45 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
if (!SCHEME_STRUCTP(val) || !scheme_is_struct_instance((Scheme_Object *)pi->struct_type, val)) if (!SCHEME_STRUCTP(val) || !scheme_is_struct_instance((Scheme_Object *)pi->struct_type, val))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: %s %V does not apply to given object: %V", "%s: %s %V does not apply to given object: %V",
name,
kind, kind,
a[0], a[0],
argv[0]); argv[0]);
if (SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + pi->field]) if (SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + pi->field])
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: given %s is for the same field as a previous %s argument: %V", "%s: given %s is for the same field as a previous %s argument: %V",
name,
kind, kind, kind, kind,
a[0]); a[0]);
if (is_proxy) {
/* Must not be an immutable field. */
if (stype->immutables) {
if (stype->immutables[pi->field])
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: cannot replace %s for an immutable field: %V",
name,
kind,
a[0]);
}
}
arity = 2; arity = 2;
} }
i++; i++;
if (i >= argc) if (i >= argc)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: missing replacement for %s: %V", "%s: missing replacement for %s: %V",
name,
kind, kind,
proc); proc);
proc = argv[i]; proc = argv[i];
if (!scheme_check_proc_arity(NULL, arity, i, argc, argv)) if (!scheme_check_proc_arity(NULL, arity, i, argc, argv))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: expected #<procedure (arity %d)> as %s replacement, given: %V", "%s: expected #<procedure (arity %d)> as %s replacement, given: %V",
name,
arity, arity,
kind, kind,
proc); proc);
@ -5132,18 +5224,31 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
px = MALLOC_ONE_TAGGED(Scheme_Chaperone); px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
if (SCHEME_PROCP(val)) if (SCHEME_PROCP(val))
px->so.type = scheme_proc_chaperone_type; px->iso.so.type = scheme_proc_chaperone_type;
else else
px->so.type = scheme_chaperone_type; px->iso.so.type = scheme_chaperone_type;
px->val = val; px->val = val;
px->prev = argv[0]; px->prev = argv[0];
px->props = props; px->props = props;
px->redirects = redirects; px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv) 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)
{
return do_chaperone_struct("proxy-struct", 1, argc, argv);
}
static Scheme_Object *do_chaperone_struct_type(const char *name, int is_proxy, int argc, Scheme_Object **argv)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0]; Scheme_Object *val = argv[0];
@ -5155,35 +5260,44 @@ static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv)
val = SCHEME_CHAPERONE_VAL(val); val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_STRUCT_TYPEP(val)) if (!SCHEME_STRUCT_TYPEP(val))
scheme_wrong_type("chaperone-struct-type", "struct-type", 0, argc, argv); scheme_wrong_type(name, "struct-type", 0, argc, argv);
scheme_check_proc_arity("chaperone-struct-type", 8, 1, argc, argv); scheme_check_proc_arity(name, 8, 1, argc, argv);
scheme_check_proc_arity("chaperone-struct-type", 1, 2, argc, argv); scheme_check_proc_arity(name, 1, 2, argc, argv);
if (!SCHEME_PROCP(argv[3])) if (!SCHEME_PROCP(argv[3]))
scheme_wrong_type("chaperone-struct-type", "procedure", 3, argc, argv); scheme_wrong_type(name, "procedure", 3, argc, argv);
arity = ((Scheme_Struct_Type *)val)->num_islots + 1; arity = ((Scheme_Struct_Type *)val)->num_islots + 1;
if (!scheme_check_proc_arity(NULL, arity, 3, argc, argv)) if (!scheme_check_proc_arity(NULL, arity, 3, argc, argv))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct-type: guard procedure does not accept %d arguments " "%s: guard procedure does not accept %d arguments "
"(one more than the number of constructor arguments): %V", "(one more than the number of constructor arguments): %V",
name,
arity, argv[0]); arity, argv[0]);
props = scheme_parse_chaperone_props("chaperone-vector", 4, argc, argv); props = scheme_parse_chaperone_props(name, 4, argc, argv);
redirects = scheme_make_pair(argv[1], redirects = scheme_make_pair(argv[1],
scheme_make_pair(argv[2], scheme_make_pair(argv[2],
argv[3])); argv[3]));
px = MALLOC_ONE_TAGGED(Scheme_Chaperone); px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_chaperone_type; px->iso.so.type = scheme_chaperone_type;
px->props = props; px->props = props;
px->val = val; px->val = val;
px->prev = argv[0]; px->prev = argv[0];
px->redirects = redirects; px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv)
{
return do_chaperone_struct_type("chaperone-struct-type", 0, argc, argv);
}
Scheme_Hash_Tree *scheme_parse_chaperone_props(const char *who, int start_at, int argc, Scheme_Object **argv) Scheme_Hash_Tree *scheme_parse_chaperone_props(const char *who, int start_at, int argc, Scheme_Object **argv)
{ {
Scheme_Hash_Tree *ht; Scheme_Hash_Tree *ht;
@ -5197,7 +5311,7 @@ Scheme_Hash_Tree *scheme_parse_chaperone_props(const char *who, int start_at, in
while (start_at < argc) { while (start_at < argc) {
v = argv[start_at]; v = argv[start_at];
if (!SAME_TYPE(SCHEME_TYPE(v), scheme_chaperone_property_type)) if (!SAME_TYPE(SCHEME_TYPE(v), scheme_chaperone_property_type))
scheme_wrong_type(who, "chaperone-property", start_at, argc, argv); scheme_wrong_type(who, "proxy-property", start_at, argc, argv);
if (start_at + 1 >= argc) if (start_at + 1 >= argc)
scheme_arg_mismatch(who, scheme_arg_mismatch(who,

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

@ -45,6 +45,7 @@ static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv); static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_vector(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]);
@ -146,6 +147,11 @@ scheme_init_vector (Scheme_Env *env)
"chaperone-vector", "chaperone-vector",
3, -1), 3, -1),
env); env);
scheme_add_global_constant("proxy-vector",
scheme_make_prim_w_arity(proxy_vector,
"proxy-vector",
3, -1),
env);
} }
void void
@ -419,11 +425,12 @@ Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
red = SCHEME_CAR(px->redirects); red = SCHEME_CAR(px->redirects);
o = _scheme_apply(red, 3, a); o = _scheme_apply(red, 3, a);
if (!scheme_chaperone_of(o, orig)) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(o, orig))
"vector-ref: chaperone produced a result: %V that is not a chaperone of the original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
o, "vector-ref: chaperone produced a result: %V that is not a chaperone of the original result: %V",
orig); o,
orig);
return o; return o;
} }
@ -473,11 +480,12 @@ void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
red = SCHEME_CDR(px->redirects); red = SCHEME_CDR(px->redirects);
v = _scheme_apply(red, 3, a); v = _scheme_apply(red, 3, a);
if (!scheme_chaperone_of(v, a[2])) if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, if (!scheme_chaperone_of(v, a[2]))
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V", scheme_raise_exn(MZEXN_FAIL_CONTRACT,
v, "vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
a[2]); v,
a[2]);
} }
} }
} }
@ -792,7 +800,7 @@ static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
return SCHEME_MULTIPLE_VALUES; return SCHEME_MULTIPLE_VALUES;
} }
static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv) static Scheme_Object *do_chaperone_vector(const char *name, int is_proxy, int argc, Scheme_Object **argv)
{ {
Scheme_Chaperone *px; Scheme_Chaperone *px;
Scheme_Object *val = argv[0]; Scheme_Object *val = argv[0];
@ -802,25 +810,39 @@ static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv)
if (SCHEME_CHAPERONEP(val)) if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val); val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_VECTORP(val)) if (!SCHEME_VECTORP(val)
scheme_wrong_type("chaperone-vector", "vector", 0, argc, argv); || (is_proxy && !SCHEME_MUTABLEP(val)))
scheme_check_proc_arity("chaperone-vector", 3, 1, argc, argv); scheme_wrong_type(name, is_proxy ? "mutable vector" : "vector", 0, argc, argv);
scheme_check_proc_arity("chaperone-vector", 3, 2, argc, argv); scheme_check_proc_arity(name, 3, 1, argc, argv);
scheme_check_proc_arity(name, 3, 2, argc, argv);
props = scheme_parse_chaperone_props("chaperone-vector", 3, argc, argv); props = scheme_parse_chaperone_props(name, 3, argc, argv);
redirects = scheme_make_pair(argv[1], argv[2]); redirects = scheme_make_pair(argv[1], argv[2]);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone); px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_chaperone_type; px->iso.so.type = scheme_chaperone_type;
px->props = props; px->props = props;
px->val = val; px->val = val;
px->prev = argv[0]; px->prev = argv[0];
px->redirects = redirects; px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
return (Scheme_Object *)px; return (Scheme_Object *)px;
} }
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)
{
return do_chaperone_vector("proxy-vector", 1, argc, argv);
}
/************************************************************/ /************************************************************/
/* unsafe */ /* unsafe */
/************************************************************/ /************************************************************/