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:procedure->method
new:procedure-rename
new:chaperone-procedure)
new:chaperone-procedure
new:proxy-procedure)
;; ----------------------------------------
@ -1139,112 +1140,126 @@
(define new:chaperone-procedure
(let ([chaperone-procedure
(lambda (proc wrap-proc . props)
(if (or (not (keyword-procedure? proc))
(not (procedure? wrap-proc)))
(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)]))
(do-chaperone-procedure #t chaperone-procedure 'chaperone-procedure proc wrap-proc props))])
chaperone-procedure ))
(unless (includes? b a)
;; Let core report error:
(apply chaperone-procedure proc wrap-proc props))
(unless (subset? b-req a-req)
(raise-mismatch-error
'chaperone-procedure
"chaperoning procedure requires more keywords than original procedure: "
proc))
(unless (or (not b-allow)
(and a-allow
(subset? a-allow b-allow)))
(raise-mismatch-error
'chaperone-procedure
"chaperoning procedure does not accept all keywords of original procedure: "
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))
(define new:proxy-procedure
(let ([chaperone-procedure
(lambda (proc wrap-proc . props)
(do-chaperone-procedure #f proxy-procedure 'proxy-procedure proc wrap-proc props))])
chaperone-procedure ))
(define (do-chaperone-procedure is-proxy? chaperone-procedure name proc wrap-proc props)
(if (or (not (keyword-procedure? proc))
(not (procedure? wrap-proc)))
(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)
;; 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
'|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 (chaperone-of? new-arg arg)
(raise-mismatch-error
'|keyword procedure chaperone|
(format
"~a keyword result is not a chaperone of original argument from chaperoning procedure: "
kw)
wrap-proc)))
kws
new-args
args))
(if extra?
(apply values (car results) kws (cdr results))
(apply values kws results))))))))]
[new-proc
(cond
[(okp? proc)
(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)))
"~a keyword result is not a chaperone of original argument from chaperoning procedure: "
kw)
wrap-proc))))
kws
new-args
args))
(if extra?
(apply values (car results) kws (cdr results))
(apply values kws results))))))))]
[new-proc
(cond
[(okp? proc)
(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)))))))

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

@ -124,10 +124,11 @@
(rename new:procedure->method procedure->method)
(rename new:procedure-rename procedure-rename)
(rename new:chaperone-procedure chaperone-procedure)
(rename new:proxy-procedure proxy-procedure)
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure
procedure-arity procedure-reduce-arity raise-arity-error
procedure->method procedure-rename
chaperone-procedure)
chaperone-procedure proxy-procedure)
(all-from "reqprov.rkt")
(all-from "for.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.
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
is recursively defined; if both @scheme[v1] and @scheme[v2] contain
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 ...)
(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
implements primitive support for @tech{contract}-like checks on the
value's operations. Chaperones apply only to procedures,
A @deftech{proxy} is a wrapper for a value where the wrapper
redirects certain of the value's operations. Proxies apply only to procedures,
@tech{structures} for which an accessor or mutator is available,
@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.
A chaperone's refinement of a value's operation is restricted to side
effects (including, in particular, raising an exception) or
chaperoning values supplied to or produced by the operation. For
example, a vector chaperone can redirect @scheme[vector-ref] to raise
an exception if the accessed vector slot contains a string, or it can
cause the result of @scheme[vector-ref] to be a chaperoned variant of
the value that is in the accessed vector slot, but it cannot redirect
@scheme[vector-ref] to produce a value that is arbitrarily different
from the value in the vector slot.
A @deftech{chaperone} is a kind of proxy whose refinement of a value's
operation is restricted to side effects (including, in particular,
raising an exception) or chaperoning values supplied to or produced by
the operation. For example, a vector chaperone can redirect
@scheme[vector-ref] to raise an exception if the accessed vector slot
contains a string, or it can cause the result of @scheme[vector-ref]
to be a chaperoned variant of the value that is in the accessed vector
slot, but it cannot redirect @scheme[vector-ref] to produce a value
that is arbitrarily different from the value in the vector slot.
A non-@tech{chaperone} @tech{proxy}, in contrast, can refine an operation to swap one
value for any another. A proxy cannot be applied to an immutable value
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
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
the chaperone:
the proxy:
@operations[@t{a structure-field accesor}
@t{a structure-field mutator}
@ -42,26 +47,48 @@ the chaperone:
hash-ref hash-set hash-set! hash-remove hash-remove!]
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-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
chaperone can include @deftech{chaperone properties} for a chaperoned
value. A @tech{chaperone property} is similar to a @tech{structure
proxy can include @deftech{proxy properties} for a proxied
value. A @tech{proxy property} is similar to a @tech{structure
type property}, but it applies to chaperones instead of structure
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?]{
Returns @scheme[#t] if @scheme[v] is a chaperone, @scheme[#f] otherwise.
Programs and libraries generally should avoid @scheme[chaperone?] and
treat chaperones the same as unchaperoned values. In rare cases,
@scheme[chaperone?] may be needed to guard against redirection by a
chaperone of an operation to an arbitrary procedure.}
Programs and libraries generally should avoid @scheme[chaperone?] for
the same reason that they should avoid @racket[proxy?].}
@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?]{
@ -80,16 +107,16 @@ from @scheme[v1] through one of the chaperone constructors (e.g.,
@scheme[chaperone-procedure]).}
@; ------------------------------------------------------------
@section{Chaperone Constructors}
@section{Proxy Constructors}
@defproc[(chaperone-procedure [proc procedure?]
[wrapper-proc procedure?]
[prop chaperone-property?]
[prop-val any] ... ...)
(and/c procedure? chaperone?)]{
@defproc[(proxy-procedure [proc procedure?]
[wrapper-proc procedure?]
[prop proxy-property?]
[prop-val any] ... ...)
(and/c procedure? proxy?)]{
Returns a chaperoned procedure that has the same arity, name, and
other attributes as @scheme[proc]. When the chaperoned procedure is
Returns a proxied procedure that has the same arity, name, and
other attributes as @scheme[proc]. When the proxied procedure is
applied, the arguments are first passed to @scheme[wrapper-proc], and
then the results from @scheme[wrapper-proc] are passed to
@scheme[proc]. The @scheme[wrapper-proc] can also supply a procedure
@ -104,42 +131,35 @@ of the required keywords of @scheme[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
than the number of supplied values, where an extra result is supplied
before the others. For each supplied value, 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. 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.
before the others. The additional result, if any, must be a procedure
that accepts as many results as produced by @scheme[proc]; it must
return the same number of results. If @scheme[wrapper-proc] returns
the same number of values as it is given (i.e., it does not return a
procedure to proxy @scheme[proc]'s result), then @scheme[proc] is
called in @tech{tail position} with respect to the call to the proxy.
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
result-proxying procedure (if any). The additional value must be a
list of proxys of the keyword arguments that were supplied to the
proxied procedure (i.e., not counting optional arguments that were
not supplied). The arguments must be ordered according to the sorted
order of the supplied arguments' keywords.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[procedure-chaperone] must be even) add chaperone properties
or override chaperone-property values of @scheme[proc].}
to @scheme[procedure-proxy] must be even) add proxy properties
or override proxy-property values of @scheme[proc].}
@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 chaperone-property?]
[prop-val any] ... ...)
@defproc[(proxy-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure?)]
[redirect-proc procedure?] ... ...
[prop proxy-property?]
[prop-val any] ... ...)
any/c]{
Returns a chaperoned value like @scheme[v], but with certain
operations on the chaperoned redirected. The @scheme[orig-proc]s
Returns a proxied value like @scheme[v], but with certain
operations on the proxied redirected. The @scheme[orig-proc]s
indicate the operations to redirect, and the corresponding
@scheme[redirect-proc]s supply the redirections.
@ -148,22 +168,194 @@ The protocol for a @scheme[redirect-proc] depends on the corresponding
@itemlist[
@item{A structure-field or property accessor: @scheme[redirect-proc] must
accept two arguments, @scheme[v] and the value @scheme[_field-v]
that @scheme[orig-proc] produces for @scheme[v]; it must return
chaperone of @scheme[_field-v].}
@item{A structure-field: @scheme[redirect-proc]
must accept two arguments, @scheme[v] and the value
@scheme[_field-v] that @scheme[orig-proc] produces for
@scheme[v]; it must return a replacement for
@scheme[_field-v]. The corresponding field must not be
immutable.}
@item{A structure field mutator: @scheme[redirect-proc] must accept 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{A structure field mutator: @scheme[redirect-proc] must accept
two arguments, @scheme[v] and the value @scheme[_field-v]
supplied to the mutator; it must return a replacement for
@scheme[_field-v] to be propagated to @scheme[orig-proc] and
@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
its arguments. The @scheme[orig-proc] is not called if
@scheme[struct-info] would return @scheme[#f] as its first
argument.}
]
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[proxy-procedure] must be odd) add proxy properties
or override proxy-property values of @scheme[v].}
@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
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
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].}
unchaperoned.}
@defproc[(chaperone-vector [vec vector?]
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[prop chaperone-property?]
[prop proxy-property?]
[prop-val any] ... ...)
(and/c vector? chaperone?)]{
Returns a chaperoned value like @scheme[vec], but with
@scheme[vector-ref] and @scheme[vector-set!] operations on the
chaperoned 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 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].}
Like @racket[proxy-vector], but with support for mutable vectors. The
@scheme[ref-proc] procedure must produce the same value or a chaperone
of the original value, and @scheme[set-proc] must produce the value
that is given or a chaperone of the value. The @scheme[set-proc] will
not be used if @scheme[vec] is immutable.}
@defproc[(chaperone-box [bx box?]
[unbox-proc (box? any/c . -> . any/c)]
[set-proc (box? any/c . -> . any/c)]
[prop chaperone-property?]
[prop proxy-property?]
[prop-val any] ... ...)
(and/c box? chaperone?)]{
Returns a chaperoned value like @scheme[bx], but with
@scheme[unbox] and @scheme[set-box!] operations on the
chaperoned box redirected.
The @scheme[unbox-proc] must accept @scheme[bx] and the value that
@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].}
Like @racket[prox-box], but with support for immutable boxes. The
@scheme[unbox-proc] procedure must produce the same value or a
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
@scheme[set-proc] will not be used if @scheme[bx] is immutable.}
@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))]
[remove-proc (hash? any/c . -> . any/c)]
[key-proc (hash? any/c . -> . any/c)]
[prop chaperone-property?]
[prop proxy-property?]
[prop-val any] ... ...)
(and/c hash? chaperone?)]{
Returns a chaperoned 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 chaperoned hash table redirected. When
@scheme[hash-set] or @scheme[hash-remove] is used on a chaperoned hash
table, the resulting hash table is given all of the chaperones 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 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].}
Like @racket[proxy-hash], but with constraints on the given functions
and support for immutable hashes. The @scheme[ref-proc] procedure must
return a found value or a chaperone of the value. The
@scheme[set-proc] procedure must produce two values: the key that it
is given or a chaperone of the key and the value that it is given or a
chaperone of the value. The @scheme[remove-proc] and @scheme[key-proc]
procedures must produce the given key or a chaperone of the key.}
@defproc[(chaperone-struct-type [struct-type struct-type?]
[struct-info-proc procedure?]
[make-constructor-proc (procedure? . -> . procedure?)]
[guard-proc procedure?]
[prop chaperone-property?]
[prop proxy-property?]
[prop-val any] ... ...)
(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.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-struct-type] must be even) add chaperone properties
or override chaperone-property values of @scheme[struct-type].}
to @scheme[chaperone-struct-type] must be even) add proxy properties
or override proxy-property values of @scheme[struct-type].}
@defproc[(chaperone-evt [evt evt?]
[proc (evt? . -> . (values evt? (any/c . -> . any/c)))]
[prop chaperone-property?]
[prop proxy-property?]
[prop-val any] ... ...)
(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.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[chaperone-struct-type] must be even) add chaperone properties
or override chaperone-property values of @scheme[evt].}
to @scheme[chaperone-struct-type] must be even) add proxy properties
or override proxy-property values of @scheme[evt].}
@; ------------------------------------------------------------
@section{Chaperone Properties}
@section{Proxy Properties}
@defproc[(make-chaperone-property [name symbol?])
(values chaperone-property?
@defproc[(make-proxy-property [name symbol?])
(values proxy-property?
(-> any/c boolean?)
(-> chaperone? any))]{
Creates a new structure type property and returns three values:
Creates a new @tech{proxy property} and returns three values:
@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
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
chaperone with a value for the property, @scheme[#f]
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;
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
@ -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.}
@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
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
#: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_equal
scheme_chaperone_of
scheme_proxy_of
scheme_equal_hash_key
scheme_equal_hash_key2
scheme_recur_equal_hash_key

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

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

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

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

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

@ -553,6 +553,7 @@ scheme_eq
scheme_eqv
scheme_equal
scheme_chaperone_of
scheme_proxy_of
scheme_hash_key
scheme_equal_hash_key
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 *equalish_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *proxy_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_of (int argc, Scheme_Object *argv[]);
static Scheme_Object *proxy_of (int argc, Scheme_Object *argv[]);
typedef struct Equal_Info {
long depth; /* always odd, so it looks like a fixnum */
@ -55,7 +57,7 @@ typedef struct Equal_Info {
Scheme_Hash_Table *ht;
Scheme_Object *recur;
Scheme_Object *next, *next_next;
int for_chaperone;
int for_chaperone; /* 2 => for proxy */
} Equal_Info;
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_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_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2),
env);
scheme_add_global_constant("proxy-of?",
scheme_make_prim_w_arity(proxy_of, "proxy-of?", 2, 2),
env);
}
static Scheme_Object *
@ -370,7 +379,10 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
if (scheme_eqv(obj1, obj2))
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;
goto top;
} 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;
} else if (SCHEME_MUTABLE_PAIRP(obj1)) {
# include "mzeqchk.inc"
if (eql->for_chaperone)
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
@ -413,8 +425,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
return 0;
} else if (SCHEME_VECTORP(obj1)) {
# include "mzeqchk.inc"
if (eql->for_chaperone && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
@ -435,8 +447,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
} else if (SCHEME_BYTE_STRINGP(obj1)
|| SCHEME_GENERAL_PATHP(obj1)) {
int l1, l2;
if (eql->for_chaperone && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
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));
} else if (SCHEME_CHAR_STRINGP(obj1)) {
int l1, l2;
if (eql->for_chaperone && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
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);
} else if (st1 != st2) {
return 0;
} else if (eql->for_chaperone
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
@ -526,8 +538,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
}
} else if (SCHEME_BOXP(obj1)) {
SCHEME_USE_FUEL(1);
if (eql->for_chaperone && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
@ -536,7 +548,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
goto top;
} else if (SCHEME_HASHTP(obj1)) {
# include "mzeqchk.inc"
if (eql->for_chaperone)
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
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);
} else if (SCHEME_BUCKTP(obj1)) {
# include "mzeqchk.inc"
if (eql->for_chaperone)
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
@ -626,6 +638,14 @@ Scheme_Object * scheme_make_false (void)
}
static Scheme_Object *chaperone_p(int argc, Scheme_Object *argv[])
{
return ((SCHEME_CHAPERONEP(argv[0])
&& !(SCHEME_CHAPERONE_FLAGS(((Scheme_Chaperone *)argv[0])) & SCHEME_CHAPERONE_IS_PROXY))
? scheme_true
: scheme_false);
}
static Scheme_Object *proxy_p(int argc, Scheme_Object *argv[])
{
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);
}
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)
{
Equal_Info eql;
@ -649,3 +674,18 @@ int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
return is_equal(obj1, obj2, &eql);
}
int scheme_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2)
{
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_equal_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *proxy_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]);
@ -529,6 +530,11 @@ scheme_init_fun (Scheme_Env *env)
"chaperone-procedure",
2, -1),
env);
scheme_add_global_constant("proxy-procedure",
scheme_make_prim_w_arity(proxy_procedure,
"proxy-procedure",
2, -1),
env);
scheme_add_global_constant("primitive?",
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;
}
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_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);
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]))
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);
naya = get_or_check_arity(argv[1], -1, NULL);
if (!is_subarity(orig, naya))
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",
name, whating,
argv[1],
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->so.type = scheme_proc_chaperone_type;
px->iso.so.type = scheme_proc_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
px->redirects = argv[1];
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
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)
{
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)
{
const char *what;
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v;
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: */
a[0] = px->prev;
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
from the chaperone, or in case the procedures have different names. */
(void)_scheme_apply_multi(px->prev, argc, argv);
scheme_signal_error("internal error: unexpected success applying chaperoned procedure");
scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure");
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);
} else
post = NULL;
for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(argv2[i], argv[i])) {
if (argc == 1)
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"procedure chaperone: %V: result: %V is not a chaperone of argument: %V",
px->redirects,
argv2[i], argv[i]);
else
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"procedure chaperone: %V: %d%s result: %V is not a chaperone of argument: %V",
px->redirects,
i, scheme_number_suffix(i),
argv2[i], argv[i]);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) {
for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(argv2[i], argv[i])) {
if (argc == 1)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure chaperone: %V: result: %V is not a chaperone of argument: %V",
px->redirects,
argv2[i], argv[i]);
else
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure chaperone: %V: %d%s result: %V is not a chaperone of argument: %V",
px->redirects,
i, scheme_number_suffix(i),
argv2[i], argv[i]);
}
}
}
} else {
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,
c, argc, argc + 1);
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) */
if (!SCHEME_PROCP(post))
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,
post);
if (auto_val) {
@ -4277,24 +4308,27 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
}
if (c == argc) {
for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(argv2[i], argv[i])) {
if (argc == 1)
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"procedure-result chaperone: %V: result: %V is not a chaperone of original result: %V",
post,
argv2[i], argv[i]);
else
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"procedure-result chaperone: %V: %d%s result: %V is not a chaperone of original result: %V",
post,
i, scheme_number_suffix(i),
argv2[i], argv[i]);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY)) {
for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(argv2[i], argv[i])) {
if (argc == 1)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure-result chaperone: %V: result: %V is not a chaperone of original result: %V",
post,
argv2[i], argv[i]);
else
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure-result chaperone: %V: %d%s result: %V is not a chaperone of original result: %V",
post,
i, scheme_number_suffix(i),
argv2[i], argv[i]);
}
}
}
} else {
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,
argc, c);
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,
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)
{
GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *ref4;
GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *ref4, *ref5;
int int_ok;
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);
ref4 = NULL;
ref = NULL;
ref5 = NULL;
} else {
ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
if (can_chaperone) {
if (can_chaperone > 0) {
__START_INNER_TINY__(branch_short);
ref3 = jit_bnei_i(jit_forward(), JIT_R1, scheme_chaperone_type);
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);
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) {
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, ref4);
add_branch_false(for_branch, ref5);
branch_for_true(jitter, for_branch);
CHECK_LIMIT();
} else {
@ -6294,6 +6302,9 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
if (ref4) {
mz_patch_branch(ref4);
}
if (ref5) {
mz_patch_branch(ref5);
}
(void)jit_movi_p(JIT_R0, scheme_false);
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);
return 1;
} 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);
return 1;
} 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 *set_box (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_box(int argc, Scheme_Object **argv);
static Scheme_Object *make_hash(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 *eqv_hash_code(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_hash(int argc, Scheme_Object **argv);
static Scheme_Object *make_weak_box(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",
3, -1),
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_make_immed_prim(make_hash,
@ -627,6 +634,11 @@ scheme_init_list (Scheme_Env *env)
"chaperone-hash",
5, -1),
env);
scheme_add_global_constant("proxy-hash",
scheme_make_prim_w_arity(proxy_hash,
"proxy-hash",
5, -1),
env);
scheme_add_global_constant("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;
obj = _scheme_apply(SCHEME_CAR(px->redirects), 2, a);
if (!scheme_chaperone_of(obj, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"unbox: chaperone produced a result: %V that is not a chaperone of the original result: %V",
obj,
orig);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
if (!scheme_chaperone_of(obj, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"unbox: chaperone produced a result: %V that is not a chaperone of the original result: %V",
obj,
orig);
return obj;
}
@ -1588,11 +1601,12 @@ static void chaperone_set_box(Scheme_Object *obj, Scheme_Object *v)
a[1] = v;
v = _scheme_apply(SCHEME_CDR(px->redirects), 2, a);
if (!scheme_chaperone_of(v, a[1]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
v,
a[1]);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
if (!scheme_chaperone_of(v, a[1]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
v,
a[1]);
}
}
}
@ -1642,7 +1656,7 @@ static Scheme_Object *set_box(int c, Scheme_Object *p[])
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_Object *val = argv[0];
@ -1652,25 +1666,38 @@ static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv)
if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_BOXP(val))
scheme_wrong_type("chaperone-box", "box", 0, argc, argv);
scheme_check_proc_arity("chaperone-box", 2, 1, argc, argv);
scheme_check_proc_arity("chaperone-box", 2, 2, argc, argv);
if (!SCHEME_BOXP(val) || (is_proxy && !SCHEME_MUTABLEP(val)))
scheme_wrong_type(name, is_proxy ? "mutable box" : "box", 0, argc, argv);
scheme_check_proc_arity(name, 2, 1, argc, argv);
scheme_check_proc_arity(name, 2, 2, argc, argv);
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->so.type = scheme_chaperone_type;
px->iso.so.type = scheme_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
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)
{
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);
}
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_Object *val = argv[0];
@ -2610,12 +2637,14 @@ static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv)
if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_HASHTP(val) && !SCHEME_HASHTRP(val) && !SCHEME_BUCKTP(val))
scheme_wrong_type("chaperone-hash", "hash", 0, argc, argv);
scheme_check_proc_arity("chaperone-hash", 2, 1, argc, argv); /* ref */
scheme_check_proc_arity("chaperone-hash", 3, 2, argc, argv); /* set! */
scheme_check_proc_arity("chaperone-hash", 2, 3, argc, argv); /* remove */
scheme_check_proc_arity("chaperone-hash", 2, 4, argc, argv); /* key */
if (!SCHEME_HASHTP(val)
&& (is_proxy || !SCHEME_HASHTRP(val))
&& !SCHEME_BUCKTP(val))
scheme_wrong_type(name, is_proxy ? "mutable hash" : "hash", 0, argc, argv);
scheme_check_proc_arity(name, 2, 1, argc, argv); /* ref */
scheme_check_proc_arity(name, 3, 2, argc, argv); /* set! */
scheme_check_proc_arity(name, 2, 3, argc, argv); /* remove */
scheme_check_proc_arity(name, 2, 4, argc, argv); /* key */
redirects = scheme_make_vector(4, NULL);
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];
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->so.type = scheme_chaperone_type;
px->iso.so.type = scheme_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
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)
{
Scheme_Chaperone *px;
@ -2783,12 +2825,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
red,
cnt);
if (!scheme_chaperone_of(vals[0], k))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a key: %V that is not a chaperone of the original key: %V",
who,
vals[0],
k);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
if (!scheme_chaperone_of(vals[0], k))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a key: %V that is not a chaperone of the original key: %V",
who,
vals[0],
k);
k = vals[0];
o = vals[1];
@ -2818,12 +2861,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
what = "key";
}
if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a %s: %V that is not a chaperone of the original %s: %V",
who, what,
o,
what, orig);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a %s: %V that is not a chaperone of the original %s: %V",
who, what,
o,
what, orig);
}
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);
}
}
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))
{
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);
MZ_EXTERN int scheme_equal(Scheme_Object *obj1, Scheme_Object *obj2);
MZ_EXTERN int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2);
MZ_EXTERN int scheme_proxy_of(Scheme_Object *obj1, Scheme_Object *obj2);
#ifdef MZ_PRECISE_GC
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_equal)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_chaperone_of)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_proxy_of)(Scheme_Object *obj1, Scheme_Object *obj2);
#ifdef MZ_PRECISE_GC
long (*scheme_hash_key)(Scheme_Object *o);
#endif

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

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

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

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

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1002
#define EXPECTED_PRIM_COUNT 1010
#define EXPECTED_UNSAFE_COUNT 69
#define EXPECTED_FLFXNUM_COUNT 60
#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);
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 *prev; /* immediately chaperoned object */
Scheme_Hash_Tree *props;
Scheme_Object *redirects; /* specific to the type of chaperone and root object */
} 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_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.)
*/
#define MZSCHEME_VERSION "5.0.1.4"
#define MZSCHEME_VERSION "5.0.1.5"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 0
#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_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_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 *make_chaperone_property(int argc, Scheme_Object *argv[]);
@ -592,9 +593,9 @@ scheme_init_struct (Scheme_Env *env)
"struct-type-property-accessor-procedure?",
1, 1),
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,
"chaperone-property-accessor-procedure?",
"proxy-property-accessor-procedure?",
1, 1),
env);
@ -687,22 +688,31 @@ scheme_init_struct (Scheme_Env *env)
"chaperone-struct",
1, -1),
env);
scheme_add_global_constant("proxy-struct",
scheme_make_prim_w_arity(proxy_struct,
"proxy-struct",
1, -1),
env);
scheme_add_global_constant("chaperone-struct-type",
scheme_make_prim_w_arity(chaperone_struct_type,
"chaperone-struct-type",
1, -1),
env);
scheme_add_global_constant("make-chaperone-property",
scheme_add_global_constant("make-proxy-property",
scheme_make_prim_w_arity2(make_chaperone_property,
"make-chaperone-property",
"make-proxy-property",
1, 1,
3, 3),
env);
scheme_add_global_constant("chaperone-property?",
scheme_add_global_constant("proxy-property?",
scheme_make_folding_prim(chaperone_property_p,
"chaperone-property?",
"proxy-property?",
1, 1, 1),
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;
v = _scheme_apply(red, 2, a);
if (!scheme_chaperone_of(v, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
who,
v ,
orig);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
if (!scheme_chaperone_of(v, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
who,
v ,
orig);
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)
who = "make-struct-type-property";
else
who = "make-chaperone-property";
who = "make-proxy-property";
if (!SCHEME_SYMBOLP(argv[0]))
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)
{
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
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];
o = _scheme_apply(red, 2, a);
if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
who,
o,
orig);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
who,
o,
orig);
return o;
}
@ -1847,12 +1859,13 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem
a[1] = v;
v = _scheme_apply(red, 2, a);
if (!scheme_chaperone_of(v, a[1]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
who,
v,
a[1]);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
if (!scheme_chaperone_of(v, a[1]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
who,
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)
{
Scheme_Object *v, **vals, *v1[1];
int cnt, i;
int cnt, i, is_proxy;
Scheme_Thread *p;
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)) {
p = scheme_current_thread;
@ -2346,13 +2366,15 @@ static Scheme_Object *apply_chaperones(const char *who, Scheme_Object *procs, in
cnt, argc);
}
for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(vals[i], a[i]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
who,
vals[i],
a[i]);
if (!is_proxy) {
for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(vals[i], a[i]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a result: %V that is not a chaperone of the original result: %V",
who,
vals[i],
a[i]);
}
}
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)
{
Scheme_Object *procs = scheme_null, *a[2];
Scheme_Object *procs = scheme_null, *proc, *a[2];
Scheme_Chaperone *px;
while (SCHEME_CHAPERONEP(o)) {
px = (Scheme_Chaperone *)o;
if (SCHEME_VECTORP(px->redirects)) {
if (SCHEME_VEC_ELS(px->redirects)[1])
procs = scheme_make_pair(SCHEME_VEC_ELS(px->redirects)[1], procs);
if (SCHEME_VEC_ELS(px->redirects)[1]) {
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;
}
@ -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)
{
Scheme_Object *procs = scheme_null;
Scheme_Object *procs = scheme_null, *proc;
Scheme_Chaperone *px;
while (SCHEME_NP_CHAPERONEP(o)) {
px = (Scheme_Chaperone *)o;
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;
}
@ -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)
{
Scheme_Object *procs = scheme_null, *a[1];
Scheme_Object *procs = scheme_null, *proc, *a[1];
Scheme_Chaperone *px;
while (SCHEME_NP_CHAPERONEP(o)) {
px = (Scheme_Chaperone *)o;
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;
}
@ -3042,23 +3074,34 @@ Scheme_Object *handle_evt_p(int argc, Scheme_Object *argv[])
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];
a[0] = argv[0];
o = _scheme_apply(proc, 1, a);
if (!scheme_chaperone_of(o, a[0]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"evt result chaperone: chaperone produced a value: %V that is not a chaperone of the original result: %V",
o,
a[0]);
if (!is_proxy)
if (!scheme_chaperone_of(o, a[0]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"evt result chaperone: chaperone produced a value: %V that is not a chaperone of the original result: %V",
o,
a[0]);
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 *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)
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,
cnt);
if (!scheme_chaperone_of(vals[0], evt))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"evt chaperone: chaperone produced a value: %V that is not a chaperone of the original event: %V",
vals[0],
evt);
if (!is_proxy)
if (!scheme_chaperone_of(vals[0], evt))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"evt chaperone: chaperone produced a value: %V that is not a chaperone of the original event: %V",
vals[0],
evt);
if (!scheme_check_proc_arity(NULL, 1, 1, 1, vals))
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]);
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],
"evt-result-chaperone",
1, 1);
@ -3109,7 +3158,17 @@ static Scheme_Object *chaperone_guard_proc(void *data, int argc, Scheme_Object *
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_Object *o, *val, *a[1];
@ -3120,32 +3179,44 @@ static Scheme_Object *chaperone_evt(int argc, Scheme_Object *argv[])
val = SCHEME_CHAPERONE_VAL(val);
if (!scheme_is_evt(val))
scheme_wrong_type("chaperone-evt", "evt", 0, argc, argv);
scheme_check_proc_arity("chaperone-evt", 1, 1, argc, argv);
scheme_wrong_type(name, "evt", 0, 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_closed_prim_w_arity(chaperone_guard_proc,
o = scheme_make_closed_prim_w_arity((is_proxy
? proxy_guard_proc
: chaperone_guard_proc),
(void *)o,
"evt-chaperone",
(is_proxy
? "evt-chaperone"
: "evt-proxy"),
1, 1);
a[0] = o;
o = nack_evt(1, a);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
if (SCHEME_PROCP(val))
px->so.type = scheme_proc_chaperone_type;
px->iso.so.type = scheme_proc_chaperone_type;
else
px->so.type = scheme_chaperone_type;
px->iso.so.type = scheme_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
px->redirects = o;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
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)
{
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 ...) */
{
Scheme_Chaperone *px;
@ -5027,7 +5098,7 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
proc = argv[i];
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;
}
@ -5040,15 +5111,17 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
} else if (SCHEME_TRUEP(struct_getter_p(1, a))) {
kind = "accessor";
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";
offset = -1;
} else if (SAME_OBJ(proc, struct_info_proc)) {
} else if (!is_proxy && SAME_OBJ(proc, struct_info_proc)) {
kind = "struct-info";
offset = -2;
} else {
scheme_wrong_type("chaperone-struct",
"structure accessor, structure mutator, struct-type property accessor, or `struct-info'",
scheme_wrong_type(name,
(is_proxy
? "structure accessor or structure mutator"
: "structure accessor, structure mutator, struct-type property accessor, or `struct-info'"),
i, argc, argv);
return NULL;
}
@ -5056,7 +5129,8 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
if (offset == -2) {
if (si_chaperone)
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]);
pi = 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]))
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,
a[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))
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,
a[0]);
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))
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,
a[0],
argv[0]);
if (SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + pi->field])
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,
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;
}
i++;
if (i >= argc)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: missing replacement for %s: %V",
"%s: missing replacement for %s: %V",
name,
kind,
proc);
proc = argv[i];
if (!scheme_check_proc_arity(NULL, arity, i, argc, argv))
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,
kind,
proc);
@ -5132,18 +5224,31 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
if (SCHEME_PROCP(val))
px->so.type = scheme_proc_chaperone_type;
px->iso.so.type = scheme_proc_chaperone_type;
else
px->so.type = scheme_chaperone_type;
px->iso.so.type = scheme_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
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_Object *val = argv[0];
@ -5155,35 +5260,44 @@ static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv)
val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_STRUCT_TYPEP(val))
scheme_wrong_type("chaperone-struct-type", "struct-type", 0, argc, argv);
scheme_check_proc_arity("chaperone-struct-type", 8, 1, argc, argv);
scheme_check_proc_arity("chaperone-struct-type", 1, 2, argc, argv);
scheme_wrong_type(name, "struct-type", 0, argc, argv);
scheme_check_proc_arity(name, 8, 1, argc, argv);
scheme_check_proc_arity(name, 1, 2, argc, argv);
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;
if (!scheme_check_proc_arity(NULL, arity, 3, argc, argv))
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",
name,
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],
scheme_make_pair(argv[2],
argv[3]));
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_chaperone_type;
px->iso.so.type = scheme_chaperone_type;
px->props = props;
px->val = val;
px->prev = argv[0];
px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
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 *ht;
@ -5197,7 +5311,7 @@ Scheme_Hash_Tree *scheme_parse_chaperone_props(const char *who, int start_at, in
while (start_at < argc) {
v = argv[start_at];
if (!SAME_TYPE(SCHEME_TYPE(v), scheme_chaperone_property_type))
scheme_wrong_type(who, "chaperone-property", start_at, argc, argv);
scheme_wrong_type(who, "proxy-property", start_at, argc, argv);
if (start_at + 1 >= argc)
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_values (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv);
static Scheme_Object *proxy_vector(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_vector_len (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",
3, -1),
env);
scheme_add_global_constant("proxy-vector",
scheme_make_prim_w_arity(proxy_vector,
"proxy-vector",
3, -1),
env);
}
void
@ -419,11 +425,12 @@ Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
red = SCHEME_CAR(px->redirects);
o = _scheme_apply(red, 3, a);
if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-ref: chaperone produced a result: %V that is not a chaperone of the original result: %V",
o,
orig);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
if (!scheme_chaperone_of(o, orig))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-ref: chaperone produced a result: %V that is not a chaperone of the original result: %V",
o,
orig);
return o;
}
@ -473,11 +480,12 @@ void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
red = SCHEME_CDR(px->redirects);
v = _scheme_apply(red, 3, a);
if (!scheme_chaperone_of(v, a[2]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
v,
a[2]);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_PROXY))
if (!scheme_chaperone_of(v, a[2]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
v,
a[2]);
}
}
}
@ -792,7 +800,7 @@ static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
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_Object *val = argv[0];
@ -802,25 +810,39 @@ static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv)
if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_VECTORP(val))
scheme_wrong_type("chaperone-vector", "vector", 0, argc, argv);
scheme_check_proc_arity("chaperone-vector", 3, 1, argc, argv);
scheme_check_proc_arity("chaperone-vector", 3, 2, argc, argv);
if (!SCHEME_VECTORP(val)
|| (is_proxy && !SCHEME_MUTABLEP(val)))
scheme_wrong_type(name, is_proxy ? "mutable vector" : "vector", 0, 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]);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_chaperone_type;
px->iso.so.type = scheme_chaperone_type;
px->props = props;
px->val = val;
px->prev = argv[0];
px->redirects = redirects;
if (is_proxy)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_PROXY;
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 */
/************************************************************/