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

chaperones (v4.2.5.3)

Browse Source 
svn: r18650
This commit is contained in:
Matthew Flatt 2010-03-28 01:10:33 +00:00
parent 895b207916
commit 73807aef24
53 changed files with 4926 additions and 1423 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/decompile.ss
View File

@ -336,7 +336,7 @@
bitwise-bit-set? char=?
+ - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor
arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons
set-mcar! set-mcdr! cons mcons set-box!
list list* vector vector-immutable))]
[(4) (memq (car a) '(vector-set! string-set! bytes-set!
list list* vector vector-immutable

10
collects/compiler/zo-marshal.ss
View File

@ -247,11 +247,11 @@
(define wcm-type-num 14)
(define quote-syntax-type-num 15)
(define variable-type-num 24)
(define top-type-num 87)
(define case-lambda-sequence-type-num 96)
(define begin0-sequence-type-num 97)
(define module-type-num 100)
(define prefix-type-num 102)
(define top-type-num 89)
(define case-lambda-sequence-type-num 99)
(define begin0-sequence-type-num 100)
(define module-type-num 103)
(define prefix-type-num 105)
(define-syntax define-enum
(syntax-rules ()

8
collects/compiler/zo-parse.ss
View File

@ -314,10 +314,10 @@
[(15) 'quote-syntax-type]
[(24) 'variable-type]
[(25) 'module-variable-type]
[(96) 'case-lambda-sequence-type]
[(97) 'begin0-sequence-type]
[(100) 'module-type]
[(102) 'resolve-prefix-type]
[(99) 'case-lambda-sequence-type]
[(100) 'begin0-sequence-type]
[(103) 'module-type]
[(105) 'resolve-prefix-type]
[else (error 'int->type "unknown type: ~e" i)]))
(define type-readers

4
collects/scheme/private/for.ss
View File

@ -1143,9 +1143,9 @@
(define-sequence-syntax *in-vector
(lambda () #'in-vector)
(vector-like-gen #'vector?
#'unsafe-vector-length
#'unsafe-vector*-length
#'in-vector
#'unsafe-vector-ref))
#'unsafe-vector*-ref))
(define-sequence-syntax *in-string
(lambda () #'in-string)

339
collects/scribblings/reference/chaperones.scrbl Normal file
View File

@ -0,0 +1,339 @@
#lang scribble/doc
@(require "mz.ss")
@(define-syntax op
(syntax-rules ()
[(_ (x ...)) (x ...)]
[(_ id) @scheme[id]]))
@(define-syntax-rule (operations i ...)
(itemlist #:style 'compact @item{@op[i]} ...))
@title[#:tag "chaperones"]{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,
@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
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 and 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.
Beware that each of the following operations can be redirected to
arbitrary procedure through chaperones on the operation's
argument---assuming that the operation is available to the creator of
the chaperone:
@operations[@t{a structure-field accesor}
@t{a structure-field mutator}
@t{a structure type property accessor}
@t{application of a procedure}
unbox set-box!
vector-ref vector-set!
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
@scheme[equal?], @scheme[equal-hash-code], and
@scheme[equal-secondary-hash-code] operations, in contrast, may bypass
chaperones (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
type property}, but it applies to chaperones instead of structure
types and their instances.
@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.}
@defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{
Indicates whether @scheme[v1] can be considered equivalent modulo
chaperones to @scheme[v2].
For values that include no chaperones, @scheme[v1] and @scheme[v2] can
be considered chaperones of each other if they are @scheme[equal?],
except that the mutability of vectors and boxes with @scheme[v1] and
@scheme[v2] must be the same.
Otherwise, all chaperones 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 chaperone constructors (e.g.,
@scheme[chaperone-procedure]).}
@; ------------------------------------------------------------
@section{Chaperone Constructors}
@defproc[(chaperone-procedure [proc procedure?]
[wrapper-proc procedure?]
[prop chaperone-property?]
[prop-val any] ... ...)
(and/c procedure? chaperone?)]{
Returns a chaperoned procedure that has the same arity, name, and
other attributes as @scheme[proc]. The arity of @scheme[wrapper-proc]
must include the arity of @scheme[proc]; when the chaperoned procedure
is applied, the arguments are first passed to @scheme[wrapper-proc].
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. 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, 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.
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].}
@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?]
[val any] ... ...)
any/c]{
Returns a chaperoned value like @scheme[v], but with certain
operations on the chaperoned redirected. The @scheme[orig-proc]s
indicate the operations to redirect, and the corresponding
@scheme[redirect-proc]s supply the redirections.
The protocol for a @scheme[redirect-proc] depends on the corresponding
@scheme[orig-proc]:
@itemlist[
@item{A structure-field or property accessor: @scheme[orig-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 mutator: @scheme[orig-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{@scheme[struct-info]: @scheme[orig-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.}
]
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-val] and @scheme[val] (the number of arguments
to @scheme[chaperone-procedure] must be even) add chaperone properties
or override chaperone-property values of @scheme[v].}
@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?]
[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-val] and @scheme[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?]
[unbox-proc (box? any/c . -> . any/c)]
[set-proc (box? any/c . -> . any/c)]
[prop chaperone-property?]
[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-val] and @scheme[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?]
[ref-proc (hash? any/c any/c . -> . any/c)]
[set-proc (hash? any/c any/c . -> . any/c)]
[remove-proc (hash? any/c . -> . any/c)]
[key-proc (hash? any/c . -> . any/c)]
[prop chaperone-property?]
[val any] ... ...)
(and/c vector? 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-iterate-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], an key passed
@scheme[hash-ref], and the value that @scheme[hash-ref] on
@scheme[hash] produces for the given key; it must produce the same
value or a chaperone of the value, which is the result of
@scheme[hash-ref] on the chaperone.
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 the same
value or a chaperone of the value, which is 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-val] and @scheme[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?]
[struct-info-proc procedure?]
[make-constructor-proc (procedure? . -> . procedure?)]
[guard-proc procedure?]
[prop chaperone-property?]
[val any] ... ...)
(and/c struct-type? chaperone?)]{
Returns a chaperoned value like @scheme[struct-type], but with
@scheme[struct-type-info] and @scheme[struct-type-make-constructor]
operations on the chaperoned structure type redirected. In addition,
when a new structure type is created as a subtype of the chaperoned
structure type, @scheme[guard-proc] is interposed as an extra guard on
creation of instances of the subtype.
The @scheme[struct-info-proc] must accept 8 arguments---the result of
@scheme[struct-type-info] on @scheme[struct-type]. It must return 8
values, where each is the same or a chaperone of the corresponding
argument. The 8 values are used as the results of
@scheme[struct-type-info] for the chaperoned structure type.
The @scheme[make-constructor-proc] must accept a single procedure
argument, which is a constructor produced by
@scheme[struct-type-make-constructor] on @scheme[struct-type]. It must
return the same or a chaperone of the procedure, which is used as the
result of @scheme[struct-type-make-constructor] on the chaperoned
structure type.
The @scheme[guard-proc] must accept as many argument as a constructor
for @scheme[struct-type]; it must return the same number of arguments,
each the same or a chaperone of the corresponding argument. The
@scheme[guard-proc] is added as a constructor guard when a subtype is
created of the chaperoned structure type.
Pairs of @scheme[prop-val] and @scheme[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].}
@; ------------------------------------------------------------
@section{Chaperone Properties}
@defproc[(make-chaperone-property [name symbol?])
(values chaperone-property?
procedure?
procedure?)]{
Creates a new structure type property and returns three values:
@itemize[
@item{a @deftech{chaperone property descriptor}, for use with
@scheme[chaperone-procedure], @scheme[chaperone-struct], and
other chaperone constructors;}
@item{a @deftech{chaperone 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
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, the
@exnraise[exn:fail:contract].}
]}
@defproc[(chaperone-property? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @tech{chaperone property
descriptor} value, @scheme[#f] otherwise.}
@defproc[(chaperone-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.}

1
collects/scribblings/reference/security.scrbl
View File

@ -10,6 +10,7 @@
@include-section["eval.scrbl"]
@include-section["load-lang.scrbl"]
@include-section["module-reflect.scrbl"]
@include-section["chaperones.scrbl"]
@include-section["security-guards.scrbl"]
@include-section["custodians.scrbl"]
@include-section["thread-groups.scrbl"]

20
collects/scribblings/reference/struct-inspectors.scrbl
View File

@ -58,14 +58,14 @@ Returns two values:
@itemize[
@item{@scheme[struct-type]: a structure type descriptor or @scheme[#f];
@item{@scheme[_struct-type]: a structure type descriptor or @scheme[#f];
the result is a structure type descriptor of the most specific type
for which @scheme[v] is an instance, and for which the current
inspector has control, or the result is @scheme[#f] if the current
inspector does not control any structure type for which the
@scheme[struct] is an instance.}
@item{@scheme[skipped?]: @scheme[#f] if the first result corresponds to
@item{@scheme[_skipped?]: @scheme[#f] if the first result corresponds to
the most specific structure type of @scheme[v], @scheme[#t] otherwise.}
]}
@ -86,32 +86,32 @@ Returns eight values that provide information about the structure type
@itemize[
@item{@scheme[name]: the structure type's name as a symbol;}
@item{@scheme[_name]: the structure type's name as a symbol;}
@item{@scheme[init-field-cnt]: the number of fields defined by the
@item{@scheme[_init-field-cnt]: the number of fields defined by the
structure type provided to the constructor procedure (not counting
fields created by its ancestor types);}
@item{@scheme[auto-field-cnt]: the number of fields defined by the
@item{@scheme[_auto-field-cnt]: the number of fields defined by the
structure type without a counterpart in the constructor procedure
(not counting fields created by its ancestor types);}
@item{@scheme[accessor-proc]: an accessor procedure for the structure
@item{@scheme[_accessor-proc]: an accessor procedure for the structure
type, like the one returned by @scheme[make-struct-type];}
@item{@scheme[mutator-proc]: a mutator procedure for the structure
@item{@scheme[_mutator-proc]: a mutator procedure for the structure
type, like the one returned by @scheme[make-struct-type];}
@item{@scheme[immutable-k-list]: an immutable list of exact
@item{@scheme[_immutable-k-list]: an immutable list of exact
non-negative integers that correspond to immutable fields for the
structure type;}
@item{@scheme[super-type]: a structure type descriptor for the
@item{@scheme[_super-type]: a structure type descriptor for the
most specific ancestor of the type that is controlled by the
current inspector, or @scheme[#f] if no ancestor is controlled by
the current inspector;}
@item{@scheme[skipped?]: @scheme[#f] if the seventh result is the
@item{@scheme[_skipped?]: @scheme[#f] if the seventh result is the
most specific ancestor type or if the type has no supertype,
@scheme[#t] otherwise.}

7
collects/scribblings/reference/struct.scrbl
View File

@ -367,9 +367,12 @@ is then sent to that property's guard, of any).
@defproc[(struct-type-property? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @tech{structure type property
descriptor} value, @scheme[#f] otherwise.
descriptor} value, @scheme[#f] otherwise.}
}
@defproc[(struct-type-property-accessor-procedure? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is an accessor procedure produced
by @scheme[make-struct-type-property], @scheme[#f] otherwise.}
@;------------------------------------------------------------------------
@section[#:tag "struct-copy"]{Copying and Updating Structures}

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

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

4
collects/scribblings/scribble/decode.scrbl
View File

@ -70,13 +70,13 @@ by functions like @scheme[decode-flow].}
@defproc[(pre-part? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @deftech{pre-part} value: a
string or other non-list @scheme[content], a @scheme[block], a
string or other non-list @tech{content}, a @tech{block}, a
@scheme[part], a @scheme[title-decl], a @scheme[part-start], a
@scheme[part-index-decl], a @scheme[part-collect-decl], a
@scheme[part-tag-decl], @|void-const|, or a @scheme[splice] containing
a list of @tech{pre-part} values; otherwise returns @scheme[#f].
A pre-part sequences is decoded into a @scheme[part] by functions like
A pre-part sequence is decoded into a @scheme[part] by functions like
@scheme[decode] and @scheme[decode-part].}

556
collects/tests/mzscheme/chaperone.ss Normal file
View File

@ -0,0 +1,556 @@
(load-relative "loadtest.ss")
(Section 'chaperones)
;; ----------------------------------------
(test #t chaperone-of? 10 10)
(test #t chaperone-of? '(10) '(10))
(test #t chaperone-of? '#(1 2 3) '#(1 2 3))
(test #t chaperone-of? '#&(1 2 3) '#&(1 2 3))
(test #f chaperone-of? (make-string 1 #\x) (make-string 1 #\x))
(test #t chaperone-of?
(string->immutable-string (make-string 1 #\x))
(string->immutable-string (make-string 1 #\x)))
(define (either-chaperone-of? a b)
(or (chaperone-of? a b)
(chaperone-of? b a)))
(test #f either-chaperone-of?
(string->immutable-string "x")
(make-string 1 #\x))
(test #f either-chaperone-of?
'#(1 2 3)
(vector 1 2 3))
(test #f either-chaperone-of?
'#&17
(box 17))
(let ()
(define-struct o (a b))
(define-struct p (x y) #:transparent)
(define-struct (p2 p) (z) #:transparent)
(define-struct q (u [w #:mutable]) #:transparent)
(define-struct (q2 q) (v) #:transparent)
(test #f chaperone-of? (make-o 1 2) (make-o 1 2))
(test #t chaperone-of? (make-p 1 2) (make-p 1 2))
(test #f chaperone-of? (make-p 1 (box 2)) (make-p 1 (box 2)))
(test #t chaperone-of? (make-p2 1 2 3) (make-p2 1 2 3))
(test #f chaperone-of? (make-q 1 2) (make-q 1 2))
(test #f chaperone-of? (make-q2 1 2 3) (make-q2 1 2 3)))
;; ----------------------------------------
(test #t chaperone? (chaperone-box (box 10) (lambda (b v) v) (lambda (b v) v)))
(test #t box? (chaperone-box (box 10) (lambda (b v) v) (lambda (b v) v)))
(test #t (lambda (x) (box? x)) (chaperone-box (box 10) (lambda (b v) v) (lambda (b v) v)))
(test #t chaperone? (chaperone-box (box-immutable 10) (lambda (b v) v) (lambda (b v) v)))
(let* ([b (box 0)]
[b2 (chaperone-box b
(lambda (b v)
(when (equal? v 'bad) (error "bad get"))
v)
(lambda (b v)
(when (equal? v 'bad) (error "bad set"))
v))])
(test #t equal? b b2)
(test #f chaperone-of? b b2)
(test #t chaperone-of? b2 b)
(err/rt-test (set-box! b2 'bad) (lambda (exn)
(test "bad set" exn-message exn)))
(test (void) set-box! b 'bad)
(err/rt-test (unbox b2) (lambda (exn)
(test "bad get" exn-message exn)))
(test (void) set-box! b 'ok)
(test 'ok unbox b2)
(test (void) set-box! b2 'fine)
(test 'fine unbox b))
;; ----------------------------------------
(test #t chaperone? (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(test #t vector? (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(test #t (lambda (x) (vector? x)) (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(test #t chaperone? (chaperone-vector (vector-immutable 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
(let* ([b (vector 1 2 3)]
[b2 (chaperone-vector b
(lambda (b i v)
(when (and (equal? v 'bad) (= i 1))
(error "bad get"))
v)
(lambda (b i v)
(when (and (equal? v 'bad) (= i 2))
(error "bad set"))
v))])
(test #t equal? b b2)
(test #f chaperone-of? b b2)
(test #t chaperone-of? b2 b)
(err/rt-test (vector-set! b2 2 'bad) (lambda (exn)
(test "bad set" exn-message exn)))
(test 3 vector-ref b 2)
(test (void) vector-set! b2 1 'bad)
(test 'bad vector-ref b 1)
(err/rt-test (vector-ref b2 1) (lambda (exn)
(test "bad get" exn-message exn)))
(test (void) vector-set! b 1 'ok)
(test 'ok vector-ref b2 1)
(test (void) vector-set! b2 1 'fine)
(test 'fine vector-ref b 1))
;; ----------------------------------------
(test #t chaperone? (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t procedure? (chaperone-procedure (lambda (x) x) (lambda (y) y)))
(test #t (lambda (x) (procedure? x))(chaperone-procedure (lambda (x) x) (lambda (y) y)))
(err/rt-test (chaperone-procedure (lambda (x) x) (lambda (y z) y)))
(err/rt-test (chaperone-procedure (case-lambda [() 0] [(x) x]) (lambda (y) y)))
;; Single argument, no post filter:
(let* ([f (lambda (x) (list x x))]
[in #f]
[f2 (chaperone-procedure
f
(lambda (x)
(set! in x)
x))])
(test '(110 110) f 110)
(test #f values in)
(test '(111 111) f2 111)
(test 111 values in))
;; Multiple arguments, no post filter:
(let* ([f (lambda (x y) (list x y))]
[in #f]
[f2 (chaperone-procedure
f
(lambda (x y)
(set! in (vector x y))
(values x y)))])
(test '(1100 1101) f 1100 1101)
(test #f values in)
(test '(1110 1111) f2 1110 1111)
(test (vector 1110 1111) values in))
;; Single argument, post filter on single value:
(let* ([f (lambda (x) (list x x))]
[in #f]
[out #f]
[f2 (chaperone-procedure
f
(lambda (x)
(set! in x)
(values x (lambda (y)
(set! out y)
y))))])
(test '(10 10) f 10)
(test #f values in)
(test #f values out)
(test '(11 11) f2 11)
(test 11 values in)
(test '(11 11) values out))
;; Multiple arguments, post filter on multiple values:
(let* ([f (lambda (x y z) (values y (list x z)))]
[in #f]
[out #f]
[f2 (chaperone-procedure
f
(lambda (x y z)
(set! in (vector x y z))
(values x y z
(lambda (y z)
(set! out (vector y z))
(values y z)))))])
(test-values '(b (a c)) (lambda () (f 'a 'b 'c)))
(test #f values in)
(test #f values out)
(test-values '(b (a c)) (lambda () (f2 'a 'b 'c)))
(test (vector 'a 'b 'c) values in)
(test (vector 'b '(a c)) values out))
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y y))) 1))
(err/rt-test ((chaperone-procedure (lambda (x) (values x x)) (lambda (y) y))) 1)
;; ----------------------------------------
(let ()
(define-values (prop:blue blue? blue-ref) (make-chaperone-property 'blue))
(define-values (prop:green green? green-ref) (make-struct-type-property 'green))
(define-struct a ([x #:mutable] y))
(define-struct (b a) ([z #:mutable]))
(define-struct p (u) #:property prop:green 'green)
(define-struct (q p) (v w))
(test #t chaperone? (chaperone-struct (make-a 1 2) a-x (lambda (a v) v)))
(test #t chaperone? (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v)))
(test #t chaperone? (chaperone-struct (make-p 1) green-ref (lambda (a v) v)))
(test #t chaperone? (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue))
(test #t chaperone? (chaperone-struct
(chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue)
a-x (lambda (a v) v)
prop:blue 'blue))
(err/rt-test (chaperone-struct (make-a 1 2) b-z (lambda (a v) v)))
(err/rt-test (chaperone-struct (make-p 1) a-x (lambda (a v) v)))
(err/rt-test (chaperone-struct (make-q 1 2 3) a-x (lambda (a v) v)))
(err/rt-test (chaperone-struct (make-a 1 2) 5 (lambda (a v) v)))
(err/rt-test (chaperone-struct (make-a 1 2) a-x 5))
(err/rt-test (chaperone-struct (make-a 1 2) a-x (lambda (x) x)))
(err/rt-test (chaperone-struct (make-a 1 2) blue-ref (lambda (a v) v)))
(err/rt-test (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:green 'green))
(err/rt-test (chaperone-struct
(chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue)
blue-ref (lambda (a v) v)))
(let* ([a1 (make-a 1 2)]
[get #f]
[set #f]
[a2 (chaperone-struct a1 a-y (lambda (an-a v) (set! get v) v)
set-a-x! (lambda (an-a v) (set! set v) v))]
[p1 (make-p 100)]
[p-get #f]
[p2 (chaperone-struct p1 green-ref (lambda (p v) (set! p-get v) v))]
[a3 (chaperone-struct a1 a-x (lambda (a y) y) prop:blue 8)])
(test 2 a-y a1)
(test #f values get)
(test #f values set)
(test 2 a-y a2)
(test 2 values get)
(test #f values set)
(test (void) set-a-x! a1 0)
(test 0 a-x a1)
(test 0 a-x a2)
(test 2 values get)
(test #f values set)
(test (void) set-a-x! a2 10)
(test 2 values get)
(test 10 values set)
(test 10 a-x a1)
(test 10 a-x a2)
(test 2 a-y a1)
(test 2 a-y a2)
(test #t green? p1)
(test #t green? p2)
(test 'green green-ref p1)
(test #f values p-get)
(test 'green green-ref p2)
(test 'green values p-get)
(test #f blue? a1)
(test #f blue? a2)
(test #t blue? a3)
(test 8 blue-ref a3))
(let* ([a1 (make-b 1 2 3)]
[get #f]
[set #f]
[a2 (chaperone-struct a1 b-z (lambda (an-a v) (set! get v) v)
set-b-z! (lambda (an-a v) (set! set v) v))])
(test 1 a-x a2)
(test 2 a-y a2)
(test 3 b-z a1)
(test #f values get)
(test #f values set)
(test 3 b-z a2)
(test 3 values get)
(test #f values set)
(test (void) set-b-z! a1 0)
(test 0 b-z a1)
(test 3 values get)
(test #f values set)
(test 0 b-z a2)
(test 0 values get)
(test #f values set)
(test (void) set-b-z! a2 10)
(test 0 values get)
(test 10 values set)
(test 10 b-z a1)
(test 10 b-z a2)
(test 2 a-y a1)
(test 2 a-y a2)
(test 10 values get)
(test 10 values set))
(let* ([a1 (make-a 0 2)]
[a2 (chaperone-struct a1 a-x (lambda (a v) (if (= v 1) 'bad v))
set-a-x! (lambda (a v) (if (= v 3) 'bad v)))])
(test 0 a-x a1)
(test 0 a-x a2)
(test (void) set-a-x! a1 1)
(test 1 a-x a1)
(err/rt-test (a-x a2))
(test (void) set-a-x! a1 3)
(test 3 a-x a1)
(test 3 a-x a2)
(test (void) set-a-x! a1 4)
(err/rt-test (set-a-x! a2 3))
(test 4 a-x a1)
(test 4 a-x a2)
(let* ([a3 (chaperone-struct a2 a-x (lambda (a v) (if (= v 10) 'bad v))
set-a-x! (lambda (a v) (if (= v 30) 'bad v)))])
(set-a-x! a2 30)
(err/rt-test (set-a-x! a3 30))
(err/rt-test (set-a-x! a3 3))
(set-a-x! a3 1)
(test 1 a-x a1)
(err/rt-test (a-x a2))
(err/rt-test (a-x a3)))))
;; ----------------------------------------
(let ()
(define (test-sub linear? rev?)
(define-struct a (x [y #:mutable]) #:property prop:procedure 0)
(let* ([a1 (make-a (lambda (x) (list x x)) 10)]
[get #f]
[a2 (chaperone-struct a1 a-y (lambda (a v) (set! get v) v))]
[pre #f]
[post #f]
[a3 (chaperone-procedure (if linear? a2 a1)
(lambda (z)
(set! pre z)
(values z (lambda (r)
(set! post r)
r))))]
[a2 (if rev?
(chaperone-struct a3 a-y (lambda (a v) (set! get v) v))
a2)])
(test '(12 12) a1 12)
(test #f values get)
(test #f values pre)
(test #f values post)
(test '(12 12) a2 12)
(test #f values get)
(test (if rev? 12 #f) values pre)
(test (if rev? '(12 12) #f) values post)
(test '(12 12) a3 12)
(test #f values get)
(test 12 values pre)
(test '(12 12) values post)
(test 10 a-y a1)
(test #f values get)
(test 10 a-y a2)
(test 10 values get)
(test 10 a-y a3)
(test (void) set-a-y! a1 9)
(test 9 a-y a3)
(test (if linear? 9 10) values get)
(test 9 a-y a2)
(test 9 values get)))
(test-sub #f #f)
(test-sub #t #f)
(test-sub #f #t))
;; ----------------------------------------
(let ()
(define-values (prop:blue blue? blue-ref) (make-chaperone-property 'blue))
(let* ([v1 (vector 1 2 3)]
[v2 (chaperone-vector v1 (lambda (vec i v) v) (lambda (vec i v) v)
prop:blue 89)]
[v3 (chaperone-vector v1 (lambda (vec i v) v) (lambda (vec i v) v))]
[b1 (box 0)]
[b2 (chaperone-box b1 (lambda (b v) v) (lambda (b v) v)
prop:blue 99)]
[b3 (chaperone-box b1 (lambda (b v) v) (lambda (b v) v))]
[p1 (lambda (z) z)]
[p2 (chaperone-procedure p1 (lambda (v) v) prop:blue 109)]
[p3 (chaperone-procedure p1 (lambda (v) v))])
(define (check v1 v2 v3 val check)
(test #f blue? v1)
(test #t blue? v2)
(test #f blue? v3)
(test val blue-ref v2)
(err/rt-test (blue-ref v1))
(err/rt-test (blue-ref v3))
(test #t check v1)
(test #t check v2)
(test #t check v3))
(check v1 v2 v3 89 (lambda (v) (= (vector-ref v 1) 2)))
(check b1 b2 b3 99 (lambda (b) (= (unbox b) 0)))
(check p1 p2 p3 109 (lambda (p) (= (p 77) 77)))))
;; ----------------------------------------
(for-each
(lambda (make-hash)
(let ([h (chaperone-hash (make-hash)
(lambda (h k v) v) (lambda (h k v) (values k v))
(lambda (h k) k) (lambda (h k) k))])
(test #t chaperone? h)
(test #t hash? h)
(test #t (lambda (x) (hash? x)) h)))
(list
make-hash make-hasheq make-hasheqv
(lambda () #hash()) (lambda () #hasheq()) (lambda () #hasheqv())
make-weak-hash make-weak-hasheq make-weak-hasheqv))
(for-each
(lambda (make-hash)
(let* ([h1 (make-hash)]
[get-k #f]
[get-v #f]
[set-k #f]
[set-v #f]
[remove-k #f]
[access-k #f]
[h2 (chaperone-hash h1
(lambda (h k v)
(set! get-k k)
(set! get-v v)
v)
(lambda (h k v)
(set! set-k k)
(set! set-v v)
(values k v))
(lambda (h k)
(set! remove-k k)
k)
(lambda (h k)
(set! access-k k)
k))]
[test (lambda (val proc . args)
;; Avoid printign hash-table argument, which implicitly uses `ref':
(let ([got (apply proc args)])
(test #t (format "~s ~s ~s" proc val got) (equal? val got))))])
(test #f hash-ref h1 'key #f)
(test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
(test #f hash-ref h2 'key #f)
(test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
(test (void) hash-set! h1 'key 'val)
(test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val hash-ref h1 'key #f)
(test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val hash-ref h2 'key #f)
(test '(key val #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
(test (void) hash-set! h2 'key2 'val2)
(test '(key val key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val2 hash-ref h1 'key2 #f)
(test '(key val key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val2 hash-ref h2 'key2 #f)
(test '(key2 val2 key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(test (void) hash-remove! h2 'key3)
(test '(key2 val2 key2 val2 key3 #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val2 hash-ref h2 'key2)
(test '(key2 val2 key2 val2 key3 #f) list get-k get-v set-k set-v remove-k access-k)
(test (void) hash-remove! h2 'key2)
(test '(key2 val2 key2 val2 key2 #f) list get-k get-v set-k set-v remove-k access-k)
(test #f hash-ref h2 'key2 #f)
(test '(key2 val2 key2 val2 key2 #f) list get-k get-v set-k set-v remove-k access-k)
(hash-for-each h2 void)
(test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
(void)))
(list
make-hash make-hasheq make-hasheqv
make-weak-hash make-weak-hasheq make-weak-hasheqv))
(for-each
(lambda (h1)
(let* ([get-k #f]
[get-v #f]
[set-k #f]
[set-v #f]
[remove-k #f]
[access-k #f]
[h2 (chaperone-hash h1
(lambda (h k v)
(set! get-k k)
(set! get-v v)
v)
(lambda (h k v)
(set! set-k k)
(set! set-v v)
(values k v))
(lambda (h k)
(set! remove-k k)
k)
(lambda (h k)
(set! access-k k)
k))]
[test (lambda (val proc . args)
;; Avoid printign hash-table argument, which implicitly uses `ref':
(let ([got (apply proc args)])
(test #t (format "~s ~s ~s" proc val got) (equal? val got))))])
(test #f hash-ref h1 'key #f)
(test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
(test #f hash-ref h2 'key #f)
(test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k)
(let ([h2 (hash-set h2 'key 'val)])
(test '(#f #f key val #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val hash-ref h2 'key #f)
(test '(key val key val #f #f) list get-k get-v set-k set-v remove-k access-k)
(let ([h2 (hash-set h2 'key2 'val2)])
(test '(key val key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val2 hash-ref h2 'key2 #f)
(test '(key2 val2 key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(let ([h2 (hash-remove h2 'key3)])
(test '(key2 val2 key2 val2 key3 #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val2 hash-ref h2 'key2)
(test '(key2 val2 key2 val2 key3 #f) list get-k get-v set-k set-v remove-k access-k)
(let ([h2 (hash-remove h2 'key2)])
(test '(key2 val2 key2 val2 key2 #f) list get-k get-v set-k set-v remove-k access-k)
(test #f hash-ref h2 'key2 #f)
(test '(key2 val2 key2 val2 key2 #f) list get-k get-v set-k set-v remove-k access-k)
(hash-for-each h2 void)
(test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
(void)))))))
(list #hash() #hasheq() #hasheqv()))
;; ----------------------------------------
(let ()
(define-struct a (x y) #:transparent)
(let* ([a1 (make-a 1 2)]
[got? #f]
[a2 (chaperone-struct a1 a-x (lambda (a v) v)
struct-info (lambda (s ?)
(set! got? #t)
(values s ?)))]
[got2? #f]
[a3 (chaperone-struct a2 a-x (lambda (a v) v)
struct-info (lambda (s ?)
(set! got2? #t)
(values s ?)))])
(test-values (list struct:a #f) (lambda () (struct-info a1)))
(test #f values got?)
(test-values (list struct:a #f) (lambda () (struct-info a2)))
(test #t values got?)
(set! got? #f)
(test-values (list struct:a #f) (lambda () (struct-info a3)))
(test #t values got?)
(test #t values got2?)))
;; ----------------------------------------
(let ()
(define-struct a (x y) #:transparent)
(let* ([got? #f]
[constr? #f]
[guarded? #f]
[struct:a2 (chaperone-struct-type
struct:a
(lambda (name init-cnt auto-cnt acc mut imms super skipped?)
(set! got? #t)
(values name init-cnt auto-cnt acc mut imms super skipped?))
(lambda (c)
(set! constr? #t)
c)
(lambda (x y name)
(set! guarded? #t)
(values x y)))])
(test #t struct-type? struct:a2)
(let-values ([(name init-cnt auto-cnt acc mut imms super skipped?)
(struct-type-info struct:a2)])
(test #t values got?)
(test '(a 2 0 #f #f) values (list name init-cnt auto-cnt super skipped?)))
(test #f values constr?)
(test #t procedure? (struct-type-make-constructor struct:a2))
(test #t values constr?)
(let ()
(define-struct b (z) #:super struct:a2)
(test #f values guarded?)
(make-b 1 2 3)
(test #t values guarded?))))
;; ----------------------------------------
(report-errs)

1
collects/tests/mzscheme/mz-tests.ss
View File

@ -25,6 +25,7 @@
(load-relative "will.ss")
(load-relative "namespac.ss")
(load-relative "modprot.ss")
(load-relative "chaperone.ss")
(unless (or building-flat-tests? in-drscheme?)
(load-relative "param.ss"))
(load-relative "port.ss")

6
collects/tests/mzscheme/optimize.ss
View File

@ -558,6 +558,12 @@
(test-setter make-string #\a #\7 'string-set! string-set! string-ref #f)
(test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref #f))
(let ([v (box 1)])
(check-error-message 'set-box! (eval `(lambda (x) (set-box! x 10))))
(tri0 (void) '(lambda (b i v) (set-box! b v))
(lambda () v) 0 "other"
(lambda () (test "other" unbox v))))
))
(define (comp=? c1 c2)

52
collects/tests/mzscheme/unsafe.ss
View File

@ -8,6 +8,8 @@
scheme/foreign)
(let ()
(define ((add-star str) sym)
(string->symbol (regexp-replace str (symbol->string sym) (string-append str "*"))))
(define (test-tri result proc x y z
#:pre [pre void]
#:post [post (lambda (x) x)]
@ -49,24 +51,42 @@
(test-bin 3 'unsafe-fx+ 1 2)
(test-bin -1 'unsafe-fx+ 1 -2)
(test-bin 12 'unsafe-fx+ 12 0)
(test-bin -12 'unsafe-fx+ 0 -12)
(test-bin 8 'unsafe-fx- 10 2)
(test-bin 3 'unsafe-fx- 1 -2)
(test-bin 13 'unsafe-fx- 13 0)
(test-bin 20 'unsafe-fx* 10 2)
(test-bin -20 'unsafe-fx* 10 -2)
(test-bin -2 'unsafe-fx* 1 -2)
(test-bin -21 'unsafe-fx* -21 1)
(test-bin 0 'unsafe-fx* 0 -2)
(test-bin 0 'unsafe-fx* -21 0)
(test-bin 3 'unsafe-fxquotient 17 5)
(test-bin -3 'unsafe-fxquotient 17 -5)
(test-bin 0 'unsafe-fxquotient 0 -5)
(test-bin 18 'unsafe-fxquotient 18 1)
(test-bin 2 'unsafe-fxremainder 17 5)
(test-bin 2 'unsafe-fxremainder 17 -5)
(test-bin 0 'unsafe-fxremainder 0 -5)
(test-bin 0 'unsafe-fxremainder 10 1)
(test-bin 2 'unsafe-fxmodulo 17 5)
(test-bin -3 'unsafe-fxmodulo 17 -5)
(test-bin 0 'unsafe-fxmodulo 0 -5)
(test-bin 0 'unsafe-fxmodulo 10 1)
(test-bin 3.4 'unsafe-fl+ 1.4 2.0)
(test-bin -1.1 'unsafe-fl+ 1.0 -2.1)
(test-bin +inf.0 'unsafe-fl+ 1.0 +inf.0)
(test-bin -inf.0 'unsafe-fl+ 1.0 -inf.0)
(test-bin +nan.0 'unsafe-fl+ +nan.0 -inf.0)
(test-bin 1.5 'unsafe-fl+ 1.5 0.0)
(test-bin 1.7 'unsafe-fl+ 0.0 1.7)
(test-bin #f unsafe-fx= 1 2)
(test-bin #t unsafe-fx= 2 2)
@ -96,13 +116,18 @@
(test-bin 7.9 'unsafe-fl- 10.0 2.1)
(test-bin 3.7 'unsafe-fl- 1.0 -2.7)
(test-bin 1.5 'unsafe-fl- 1.5 0.0)
(test-bin 20.02 'unsafe-fl* 10.01 2.0)
(test-bin -20.02 'unsafe-fl* 10.01 -2.0)
(test-bin +nan.0 'unsafe-fl* +inf.0 0.0)
(test-bin 1.8 'unsafe-fl* 1.0 1.8)
(test-bin 1.81 'unsafe-fl* 1.81 1.0)
(test-bin (exact->inexact 17/5) 'unsafe-fl/ 17.0 5.0)
(test-bin +inf.0 'unsafe-fl/ 17.0 0.0)
(test-bin -inf.0 'unsafe-fl/ -17.0 0.0)
(test-bin 1.5 'unsafe-fl/ 1.5 1.0)
(test-bin 3 'unsafe-fxand 7 3)
(test-bin 2 'unsafe-fxand 6 3)
@ -183,13 +208,24 @@
#:post (lambda (x) (mcdr v))
#:literal-ok? #f))
(test-bin 5 'unsafe-vector-ref #(1 5 7) 1)
(test-un 3 'unsafe-vector-length #(1 5 7))
(let ([v (vector 0 3 7)])
(test-tri (list (void) 5) 'unsafe-vector-set! v 2 5
#:pre (lambda () (vector-set! v 2 0))
#:post (lambda (x) (list x (vector-ref v 2)))
#:literal-ok? #f))
(for ([star (list values (add-star "vector"))])
(test-un 3 (star 'unsafe-unbox) #&3)
(let ([b (box 12)])
(test-tri (list (void) 8)
`(lambda (b i val) (,(star 'unsafe-set-box!) b val))
b 0 8
#:pre (lambda () (set-box! b 12))
#:post (lambda (x) (list x (unbox b)))
#:literal-ok? #f)))
(for ([star (list values (add-star "vector"))])
(test-bin 5 (star 'unsafe-vector-ref) #(1 5 7) 1)
(test-un 3 (star 'unsafe-vector-length) #(1 5 7))
(let ([v (vector 0 3 7)])
(test-tri (list (void) 5) (star 'unsafe-vector-set!) v 2 5
#:pre (lambda () (vector-set! v 2 0))
#:post (lambda (x) (list x (vector-ref v 2)))
#:literal-ok? #f)))
(test-bin 53 'unsafe-bytes-ref #"157" 1)
(test-un 3 'unsafe-bytes-length #"157")
@ -222,7 +258,7 @@
#:post (lambda (x) (list x (f64vector-ref v 2)))
#:literal-ok? #f))
(let ()
(for ([star (list values (add-star "star"))])
(define-struct posn (x [y #:mutable] z))
(test-bin 'a unsafe-struct-ref (make-posn 'a 'b 'c) 0 #:literal-ok? #f)
(test-bin 'b unsafe-struct-ref (make-posn 'a 'b 'c) 1 #:literal-ok? #f)

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

@ -529,6 +529,7 @@ scheme_struct_set
scheme_make_struct_type_property
scheme_make_struct_type_property_w_guard
scheme_struct_type_property_ref
scheme_chaperone_struct_type_property_ref
scheme_make_location
scheme_is_location
scheme_make_inspector
@ -536,6 +537,7 @@ scheme_is_subinspector
scheme_eq
scheme_eqv
scheme_equal
scheme_chaperone_of
scheme_equal_hash_key
scheme_equal_hash_key2
scheme_recur_equal_hash_key

2
src/mzscheme/include/mzscheme3m.exp
View File

@ -535,6 +535,7 @@ scheme_struct_set
scheme_make_struct_type_property
scheme_make_struct_type_property_w_guard
scheme_struct_type_property_ref
scheme_chaperone_struct_type_property_ref
scheme_make_location
scheme_is_location
scheme_make_inspector
@ -542,6 +543,7 @@ scheme_is_subinspector
scheme_eq
scheme_eqv
scheme_equal
scheme_chaperone_of
scheme_hash_key
scheme_equal_hash_key
scheme_equal_hash_key2

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

@ -512,6 +512,7 @@ EXPORTS
scheme_make_struct_type_property
scheme_make_struct_type_property_w_guard
scheme_struct_type_property_ref
scheme_chaperone_struct_type_property_ref
scheme_make_location
scheme_is_location
scheme_make_inspector
@ -519,6 +520,7 @@ EXPORTS
scheme_eq
scheme_eqv
scheme_equal
scheme_chaperone_of
scheme_equal_hash_key
scheme_equal_hash_key2
scheme_recur_equal_hash_key

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

@ -527,6 +527,7 @@ EXPORTS
scheme_make_struct_type_property
scheme_make_struct_type_property_w_guard
scheme_struct_type_property_ref
scheme_chaperone_struct_type_property_ref
scheme_make_location
scheme_is_location
scheme_make_inspector
@ -534,6 +535,7 @@ EXPORTS
scheme_eq
scheme_eqv
scheme_equal
scheme_chaperone_of
scheme_hash_key
scheme_equal_hash_key
scheme_equal_hash_key2

15
src/mzscheme/include/scheme.h
View File

@ -445,6 +445,9 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data)
#define SCHEME_STXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_stx_type)
#define SCHEME_CHAPERONEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_chaperone_type) \
|| SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_chaperone_type))
#define SCHEME_UDPP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_type)
#define SCHEME_UDP_EVTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_evt_type)
@ -615,9 +618,8 @@ typedef struct Scheme_Offset_Cptr
#define SCHEME_PRIM_IS_PRIMITIVE 4
#define SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER 8
#define SCHEME_PRIM_IS_STRUCT_PRED 16
#define SCHEME_PRIM_IS_PARAMETER 32
#define SCHEME_PRIM_IS_STRUCT_OTHER 64
#define SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK (128 | 256)
#define SCHEME_PRIM_IS_STRUCT_OTHER 32
#define SCHEME_PRIM_OTHER_TYPE_MASK (64 | 128 | 256)
#define SCHEME_PRIM_IS_MULTI_RESULT 512
#define SCHEME_PRIM_IS_BINARY_INLINED 1024
#define SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL 2048
@ -631,11 +633,14 @@ typedef struct Scheme_Offset_Cptr
#define SCHEME_PRIM_OPT_IMMEDIATE 2
#define SCHEME_PRIM_OPT_NONCM 1
/* Values with SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK */
/* Values with SCHEME_PRIM_OTHER_TYPE_MASK */
#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER 0
#define SCHEME_PRIM_STRUCT_TYPE_CONSTR 128
#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER 256
#define SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER (128 | 256)
#define SCHEME_PRIM_TYPE_PARAMETER 64
#define SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER (64 | 128)
/* combinations still available: 64|256, 64|128|256 */
#define SCHEME_PRIM_IS_STRUCT_PROC (SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER | SCHEME_PRIM_IS_STRUCT_PRED | SCHEME_PRIM_IS_STRUCT_OTHER)
@ -752,7 +757,7 @@ typedef struct {
/* ------------------------------------------------- */
#define SCHEME_PROCP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_prim_type) && (_SCHEME_TYPE(obj) <= scheme_native_closure_type)))
#define SCHEME_PROCP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_prim_type) && (_SCHEME_TYPE(obj) <= scheme_proc_chaperone_type)))
#define SCHEME_SYNTAXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_syntax_compiler_type)
#define SCHEME_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prim_type)
#define SCHEME_CLSD_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_closed_prim_type)

96
src/mzscheme/src/bool.c
View File

@ -46,6 +46,8 @@ static Scheme_Object *eq_prim (int argc, Scheme_Object *argv[]);
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 *chaperone_of (int argc, Scheme_Object *argv[]);
typedef struct Equal_Info {
long depth; /* always odd, so it looks like a fixnum */
@ -53,6 +55,7 @@ typedef struct Equal_Info {
Scheme_Hash_Table *ht;
Scheme_Object *recur;
Scheme_Object *next, *next_next;
int for_chaperone;
} Equal_Info;
static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
@ -98,6 +101,14 @@ void scheme_init_bool (Scheme_Env *env)
scheme_add_global_constant("equal?/recur",
scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3),
env);
p = scheme_make_immed_prim(chaperone_p, "chaperone?", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("chaperone?", p, env);
scheme_add_global_constant("chaperone-of?",
scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2),
env);
}
static Scheme_Object *
@ -135,6 +146,7 @@ equal_prim (int argc, Scheme_Object *argv[])
eql.recur = NULL;
eql.next = NULL;
eql.next_next = NULL;
eql.for_chaperone = 0;
return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}
@ -152,6 +164,7 @@ equalish_prim (int argc, Scheme_Object *argv[])
eql.recur = NULL;
eql.next = NULL;
eql.next_next = argv[2];
eql.for_chaperone = 0;
return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}
@ -246,6 +259,7 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
eql.recur = NULL;
eql.next_next = NULL;
eql.next = NULL;
eql.for_chaperone = 0;
return is_equal(obj1, obj2, &eql);
}
@ -342,7 +356,6 @@ static int is_equal_overflow(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Inf
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
top:
if (eql->next_next) {
if (eql->next) {
@ -357,7 +370,20 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
if (scheme_eqv(obj1, obj2))
return 1;
else if (NOT_SAME_TYPE(SCHEME_TYPE(obj1), SCHEME_TYPE(obj2))) {
else if (eql->for_chaperone && SCHEME_CHAPERONEP(obj1)) {
obj1 = ((Scheme_Chaperone *)obj1)->prev;
goto top;
} else if (NOT_SAME_TYPE(SCHEME_TYPE(obj1), SCHEME_TYPE(obj2))) {
if (!eql->for_chaperone) {
if (SCHEME_CHAPERONEP(obj1)) {
obj1 = ((Scheme_Chaperone *)obj1)->val;
goto top;
}
if (SCHEME_CHAPERONEP(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top;
}
}
return 0;
} else if (SCHEME_PAIRP(obj1)) {
# include "mzeqchk.inc"
@ -375,6 +401,8 @@ 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)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
@ -385,6 +413,9 @@ 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)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return vector_equal(obj1, obj2, eql);
@ -404,12 +435,18 @@ 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)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !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)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
@ -421,12 +458,16 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
if (eql->for_chaperone) {
procs1 = NULL;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
}
if (procs1) {
@ -466,9 +507,12 @@ 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
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property,
so check transparency: */
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
if (scheme_inspector_sees_part(obj1, insp, -2)
@ -482,6 +526,9 @@ 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)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
obj1 = SCHEME_BOX_VAL(obj1);
@ -489,6 +536,8 @@ 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)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2, eql);
@ -499,6 +548,8 @@ 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)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2, eql);
@ -568,3 +619,28 @@ Scheme_Object * scheme_make_false (void)
{
return scheme_false;
}
static Scheme_Object *chaperone_p(int argc, Scheme_Object *argv[])
{
return (SCHEME_CHAPERONEP(argv[0]) ? scheme_true : scheme_false);
}
static Scheme_Object *chaperone_of(int argc, Scheme_Object *argv[])
{
return (scheme_chaperone_of(argv[0], argv[1]) ? scheme_true : scheme_false);
}
int scheme_chaperone_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 = 1;
return is_equal(obj1, obj2, &eql);
}

1038
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

35
src/mzscheme/src/error.c
View File

@ -671,7 +671,7 @@ call_error(char *buffer, int len, Scheme_Object *exn)
"optimizer constant-fold attempt failed%s: %s",
scheme_optimize_context_to_string(scheme_current_thread->constant_folding),
buffer);
if (SCHEME_STRUCTP(exn)
if (SCHEME_CHAPERONE_STRUCTP(exn)
&& scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, exn)) {
/* remember to re-raise exception */
scheme_current_thread->reading_delayed = exn;
@ -965,7 +965,7 @@ static char *make_arity_expect_string(const char *name, int namelen,
xminc = minc - (is_method ? 1 : 0);
xmaxc = maxc - (is_method ? 1 : 0);
if ((minc == -1) && SCHEME_PROC_STRUCTP((Scheme_Object *)name)) {
if ((minc == -1) && SCHEME_CHAPERONE_PROC_STRUCTP((Scheme_Object *)name)) {
Scheme_Object *arity_maker;
while (1) {
@ -992,7 +992,7 @@ static char *make_arity_expect_string(const char *name, int namelen,
Scheme_Object *v;
int is_method;
v = scheme_extract_struct_procedure((Scheme_Object *)name, -1, NULL, &is_method);
if (!v || is_method || !SCHEME_PROC_STRUCTP(v))
if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v))
break;
name = (const char *)v;
}
@ -1138,7 +1138,7 @@ void scheme_wrong_count_m(const char *name, int minc, int maxc,
name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
} else if (SCHEME_STRUCTP(pa)) {
/* This happens when a non-case-lambda is not yet JITted.
It's an arity-at-least record. */
It's an arity-at-least record. */
pa = ((Scheme_Structure *)pa)->slots[0];
minc = SCHEME_INT_VAL(pa);
maxc = -1;
@ -1241,7 +1241,7 @@ char *scheme_make_arity_expect_string(Scheme_Object *proc,
}
name = scheme_get_proc_name((Scheme_Object *)proc, &namelen, 1);
#endif
} else if (SCHEME_STRUCTP(proc)) {
} else if (SCHEME_CHAPERONE_STRUCTP(proc)) {
name = (const char *)proc;
mina = -1;
maxa = 0;
@ -2159,7 +2159,7 @@ static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[])
static int is_arity_at_least(Scheme_Object *v)
{
return (SCHEME_STRUCTP(v)
return (SCHEME_CHAPERONE_STRUCTP(v)
&& scheme_is_struct_instance(scheme_arity_at_least, v)
&& scheme_nonneg_exact_p(((Scheme_Structure *)v)->slots[0]));
}
@ -2209,7 +2209,7 @@ static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
minc = maxc = SCHEME_INT_VAL(argv[1]);
} else if (is_arity_at_least(argv[1])) {
Scheme_Object *v;
v = ((Scheme_Structure *)argv[1])->slots[0];
v = scheme_struct_ref(argv[1], 0);
if (SCHEME_INTP(v)) {
minc = SCHEME_INT_VAL(v);
maxc = -1;
@ -2328,7 +2328,7 @@ def_error_display_proc(int argc, Scheme_Object *argv[])
scheme_write_byte_string("\n", 1, port);
/* Print context, if available */
if (SCHEME_STRUCTP(argv[1])
if (SCHEME_CHAPERONE_STRUCTP(argv[1])
&& scheme_is_struct_instance(exn_table[MZEXN].type, argv[1])
&& !scheme_is_struct_instance(exn_table[MZEXN_FAIL_USER].type, argv[1])) {
Scheme_Object *l, *w;
@ -2347,7 +2347,7 @@ def_error_display_proc(int argc, Scheme_Object *argv[])
print_width = SCHEME_INT_VAL(w);
else
print_width = 0x7FFFFFFF;
l = scheme_get_stack_trace(((Scheme_Structure *)argv[1])->slots[1]);
l = scheme_get_stack_trace(scheme_struct_ref(argv[1], 1));
while (!SCHEME_NULLP(l)) {
if (!max_cnt) {
scheme_write_byte_string("...\n", 4, port);
@ -3107,9 +3107,10 @@ def_exn_handler(int argc, Scheme_Object *argv[])
char *s;
int len = -1;
if (SCHEME_STRUCTP(argv[0])
if (SCHEME_CHAPERONE_STRUCTP(argv[0])
&& scheme_is_struct_instance(exn_table[MZEXN].type, argv[0])) {
Scheme_Object *str = ((Scheme_Structure *)argv[0])->slots[0];
Scheme_Object *str;
str = scheme_struct_ref(argv[0], 0);
if (SCHEME_CHAR_STRINGP(str)) {
str = scheme_char_string_to_byte_string(str);
s = SCHEME_BYTE_STR_VAL(str);
@ -3158,9 +3159,10 @@ nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[])
who = SCHEME_BYTE_STR_VAL(SCHEME_CAR((Scheme_Object *)old_exn));
sep = " by ";
if (SCHEME_STRUCTP(arg)
if (SCHEME_CHAPERONE_STRUCTP(arg)
&& scheme_is_struct_instance(exn_table[MZEXN].type, arg)) {
Scheme_Object *str = ((Scheme_Structure *)arg)->slots[0];
Scheme_Object *str;
str = scheme_struct_ref(arg, 0);
raisetype = "exception raised";
str = scheme_char_string_to_byte_string(str);
msg = SCHEME_BYTE_STR_VAL(str);
@ -3171,9 +3173,10 @@ nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[])
}
}
if (SCHEME_STRUCTP(orig_arg)
if (SCHEME_CHAPERONE_STRUCTP(orig_arg)
&& scheme_is_struct_instance(exn_table[MZEXN].type, orig_arg)) {
Scheme_Object *str = ((Scheme_Structure *)orig_arg)->slots[0];
Scheme_Object *str;
str = scheme_struct_ref(orig_arg, 0);
orig_raisetype = "exception raised";
str = scheme_char_string_to_byte_string(str);
orig_msg = SCHEME_BYTE_STR_VAL(str);
@ -3289,7 +3292,7 @@ do_raise(Scheme_Object *arg, int need_debug, int eb)
scheme_optimize_context_to_string(p->constant_folding),
msg);
}
if (SCHEME_STRUCTP(arg)
if (SCHEME_CHAPERONE_STRUCTP(arg)
&& scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, arg)) {
/* remember to re-raise exception */
scheme_current_thread->reading_delayed = arg;

74
src/mzscheme/src/eval.c
View File

@ -3673,6 +3673,69 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
info->single_result = -info->single_result;
}
/* Ad hoc optimization of (unsafe-fx+ <x> 0), etc. */
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)) {
int z1, z2;
z1 = SAME_OBJ(app->rand1, scheme_make_integer(0));
z2 = SAME_OBJ(app->rand2, scheme_make_integer(0));
if (IS_NAMED_PRIM(app->rator, "unsafe-fx+")) {
if (z1)
return app->rand2;
else if (z2)
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-fx-")) {
if (z2)
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-fx*")) {
if (z1 || z2)
return scheme_make_integer(0);
if (SAME_OBJ(app->rand1, scheme_make_integer(1)))
return app->rand2;
if (SAME_OBJ(app->rand2, scheme_make_integer(1)))
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-fx/")
|| IS_NAMED_PRIM(app->rator, "unsafe-fxquotient")) {
if (z1)
return scheme_make_integer(0);
if (SAME_OBJ(app->rand2, scheme_make_integer(1)))
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-fxremainder")
|| IS_NAMED_PRIM(app->rator, "unsafe-fxmodulo")) {
if (z1)
return scheme_make_integer(0);
if (SAME_OBJ(app->rand2, scheme_make_integer(1)))
return scheme_make_integer(0);
}
z1 = (SCHEME_FLOATP(app->rand1) && (SCHEME_FLOAT_VAL(app->rand1) == 0.0));
z2 = (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 0.0));
if (IS_NAMED_PRIM(app->rator, "unsafe-fl+")) {
if (z1)
return app->rand2;
else if (z2)
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-fl-")) {
if (z2)
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-fl*")) {
if (SCHEME_FLOATP(app->rand1) && (SCHEME_FLOAT_VAL(app->rand1) == 1.0))
return app->rand2;
if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0))
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-fl/")
|| IS_NAMED_PRIM(app->rator, "unsafe-flquotient")) {
if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0))
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-flremainder")
|| IS_NAMED_PRIM(app->rator, "unsafe-flmodulo")) {
if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0))
return scheme_make_double(0.0);
}
}
register_flonum_argument_types(NULL, NULL, app, info);
return check_unbox_rotation((Scheme_Object *)app, app->rator, 2, info);
@ -9124,6 +9187,17 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
} while (SAME_TYPE(scheme_proc_struct_type, SCHEME_TYPE(obj)));
goto apply_top;
} else if (type == scheme_proc_chaperone_type) {
if (SCHEME_VECTORP(((Scheme_Chaperone *)obj)->redirects)) {
/* Chaperone is for struct fields, not function arguments */
obj = ((Scheme_Chaperone *)obj)->prev;
goto apply_top;
} else {
/* Chaperone is for function arguments */
VACATE_TAIL_BUFFER_USE_RUNSTACK();
UPDATE_THREAD_RSPTR();
v = scheme_apply_chaperone(obj, num_rands, rands);
}
} else if (type == scheme_closed_prim_type) {
GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim;

264
src/mzscheme/src/fun.c
View File

@ -169,6 +169,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]);
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 *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[]);
@ -511,6 +512,11 @@ scheme_init_fun (Scheme_Env *env)
"procedure-closure-contents-eq?",
2, 2, 1),
env);
scheme_add_global_constant("chaperone-procedure",
scheme_make_prim_w_arity(chaperone_procedure,
"chaperone-procedure",
2, -1),
env);
scheme_add_global_constant("primitive?",
scheme_make_folding_prim(primitive_p,
@ -2535,7 +2541,6 @@ extern int g_print_prims;
Scheme_Object *
scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
/* NOTE: apply_values_execute (in syntax.c) and
tail_call_with_values_from_multiple_result (in jit.c)
assume that this function won't allocate when
@ -2543,25 +2548,16 @@ scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
int i;
Scheme_Thread *p = scheme_current_thread;
#ifdef INSTRUMENT_PRIMITIVES
if (g_print_prims)
{
printf("scheme_tail_apply\n");
}
#endif
p->ku.apply.tail_rator = rator;
p->ku.apply.tail_num_rands = num_rands;
if (num_rands) {
Scheme_Object **a;
if (num_rands > p->tail_buffer_size) {
{
Scheme_Object **tb;
tb = MALLOC_N(Scheme_Object *, num_rands);
p->tail_buffer = tb;
p->tail_buffer_size = num_rands;
}
Scheme_Object **tb;
tb = MALLOC_N(Scheme_Object *, num_rands);
p->tail_buffer = tb;
p->tail_buffer_size = num_rands;
}
a = p->tail_buffer;
p->ku.apply.tail_rands = a;
@ -2911,9 +2907,9 @@ static Scheme_Object *clone_arity(Scheme_Object *a)
SCHEME_CAR(l) = a;
}
return m;
} else if (SCHEME_STRUCTP(a)) {
} else if (SCHEME_CHAPERONE_STRUCTP(a)) {
Scheme_Object *p[1];
p[0] = ((Scheme_Structure *)a)->slots[0];
p[0] = scheme_struct_ref(a, 0);
return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
} else
return a;
@ -3145,6 +3141,10 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, long a, Scheme_Object
return scheme_false;
}
#endif
} else if (type == scheme_proc_chaperone_type) {
p = SCHEME_CHAPERONE_VAL(p);
SCHEME_USE_FUEL(1);
goto top;
} else {
Scheme_Closure_Data *data;
@ -3332,7 +3332,7 @@ Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a)
{
Scheme_Object *b;
while (SCHEME_PROC_STRUCTP(a)) {
while (SCHEME_CHAPERONE_PROC_STRUCTP(a)) {
if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, a)
&& SCHEME_TRUEP(((Scheme_Structure *)a)->slots[2])) {
@ -3432,6 +3432,10 @@ const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error)
p = other;
goto top;
}
} else if (type == scheme_proc_chaperone_type) {
p = SCHEME_CHAPERONE_VAL(p);
SCHEME_USE_FUEL(1);
goto top;
} else {
Scheme_Object *name;
@ -3507,8 +3511,13 @@ static Scheme_Object *object_name(int argc, Scheme_Object **argv)
{
Scheme_Object *a = argv[0];
if (SCHEME_CHAPERONEP(a))
a = SCHEME_CHAPERONE_VAL(a);
if (SCHEME_PROC_STRUCTP(a)) {
a = scheme_proc_struct_name_source(a);
if (SCHEME_CHAPERONEP(a))
a = SCHEME_CHAPERONE_VAL(a);
if (SCHEME_STRUCTP(a)
&& scheme_reduced_procedure_struct
@ -3590,14 +3599,14 @@ static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[])
} else if (SCHEME_BIGNUMP(v)) {
if (!SCHEME_BIGPOS(v))
return scheme_false;
} else if (!SCHEME_STRUCTP(v)
} else if (!SCHEME_CHAPERONE_STRUCTP(v)
|| !scheme_is_struct_instance(scheme_arity_at_least, v)) {
return scheme_false;
}
a = SCHEME_CDR(a);
}
return SCHEME_NULLP(a) ? scheme_true : scheme_false;
} else if (SCHEME_STRUCTP(a)
} else if (SCHEME_CHAPERONE_STRUCTP(a)
&& scheme_is_struct_instance(scheme_arity_at_least, a)) {
return scheme_true;
} else
@ -3624,9 +3633,9 @@ static int is_arity(Scheme_Object *a, int at_least_ok, int list_ok)
} else if (SCHEME_BIGNUMP(a)) {
return SCHEME_BIGPOS(a);
} else if (at_least_ok
&& SCHEME_STRUCTP(a)
&& SCHEME_CHAPERONE_STRUCTP(a)
&& scheme_is_struct_instance(scheme_arity_at_least, a)) {
a = ((Scheme_Structure *)a)->slots[0];
a = scheme_struct_ref(a, 0);
return is_arity(a, 0, 0);
}
@ -3686,24 +3695,9 @@ static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty,
return scheme_make_struct_instance(scheme_reduced_procedure_struct, 4, a);
}
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
static int is_subarity(Scheme_Object *req, Scheme_Object *orig)
{
Scheme_Object *orig, *req, *aty, *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp;
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_type("procedure-reduce-arity", "procedure", 0, argc, argv);
if (!is_arity(argv[1], 1, 1)) {
scheme_wrong_type("procedure-reduce-arity", "arity", 1, argc, argv);
}
/* Check whether current arity covers the requested arity. This is
a bit complicated, because both the source and target can be
lists that include arity-at-least records. */
orig = get_or_check_arity(argv[0], -1, NULL);
aty = clone_arity(argv[1]);
req = aty;
Scheme_Object *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp;
if (!SCHEME_PAIRP(orig) && !SCHEME_NULLP(orig))
orig = scheme_make_pair(orig, scheme_null);
@ -3712,13 +3706,13 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
while (!SCHEME_NULLP(req)) {
ra = SCHEME_CAR(req);
if (SCHEME_STRUCTP(ra)
if (SCHEME_CHAPERONE_STRUCTP(ra)
&& scheme_is_struct_instance(scheme_arity_at_least, ra)) {
/* Convert to a sequence of range pairs, where the
last one can be (min, #f); we'll iterate through the
original arity to knock out ranges until (if it matches)
we end up with an empty list of ranges. */
ra = scheme_make_pair(scheme_make_pair(((Scheme_Structure *)ra)->slots[0],
ra = scheme_make_pair(scheme_make_pair(scheme_struct_ref(ra, 0),
scheme_false),
scheme_null);
}
@ -3816,17 +3810,42 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
}
if (SCHEME_NULLP(ol)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"procedure-reduce-arity: arity of procedure: %V"
" does not include requested arity: %V",
argv[0],
argv[1]);
return NULL;
return 0;
}
req = SCHEME_CDR(req);
}
return 1;
}
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
{
Scheme_Object *orig, *aty;
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_type("procedure-reduce-arity", "procedure", 0, argc, argv);
if (!is_arity(argv[1], 1, 1)) {
scheme_wrong_type("procedure-reduce-arity", "arity", 1, argc, argv);
}
/* Check whether current arity covers the requested arity. This is
a bit complicated, because both the source and target can be
lists that include arity-at-least records. */
orig = get_or_check_arity(argv[0], -1, NULL);
aty = clone_arity(argv[1]);
if (!is_subarity(aty, orig)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure-reduce-arity: arity of procedure: %V"
" does not include requested arity: %V",
argv[0],
argv[1]);
return NULL;
}
/* Construct a procedure that has the given arity. */
return make_reduced_proc(argv[0], aty, NULL, NULL);
}
@ -3969,6 +3988,159 @@ 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[])
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0], *orig, *naya;
Scheme_Hash_Tree *props;
if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_PROCP(val))
scheme_wrong_type("chaperone-procedure", "procedure", 0, argc, argv);
if (!SCHEME_PROCP(argv[1]))
scheme_wrong_type("chaperone-procedure", "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 chaperoneing procedure: %V"
" does not cover arity of original procedure: %V",
argv[1],
argv[0]);
props = scheme_parse_chaperone_props("chaperone-procedure", 2, argc, argv);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_proc_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
px->redirects = argv[1];
return (Scheme_Object *)px;
}
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *v, *a[1], *a2[1], **argv2, *post;
int c, i;
v = _scheme_apply_multi(px->redirects, argc, argv);
if (v == SCHEME_MULTIPLE_VALUES) {
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
p->values_buffer = NULL;
c = p->ku.multiple.count;
argv2 = p->ku.multiple.array;
} else {
c = 1;
a2[0] = v;
argv2 = a2;
}
if ((c == argc) || (c == (argc + 1))) {
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]);
}
}
} else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"procedure chaperone: %V: returned %d values, expected %d or %d",
px->redirects,
c, argc, argc + 1);
return NULL;
}
if (c == argc) {
/* No filter for the result, so tail call: */
return scheme_tail_apply(px->prev, c, argv2);
} else {
/* Last element is a filter for the result(s) */
post = argv2[argc];
if (!SCHEME_PROCP(post))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure chaperone: %V: expected <procedure> as last result, produced: %V",
px->redirects,
post);
v = _scheme_apply_multi(px->prev, argc, argv2);
if (v == SCHEME_MULTIPLE_VALUES) {
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
p->values_buffer = NULL;
c = p->ku.multiple.count;
argv = p->ku.multiple.array;
} else {
c = 1;
a[0] = v;
argv = a;
}
if (!scheme_check_proc_arity(NULL, c, 0, -1, &post))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"procedure-result chaperone: %V: does not accept %d values produced by chaperoned procedure",
post,
c);
v = _scheme_apply_multi(post, c, argv);
if (v == SCHEME_MULTIPLE_VALUES) {
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
p->values_buffer = NULL;
argc = p->ku.multiple.count;
argv2 = p->ku.multiple.array;
} else {
argc = 1;
a2[0] = v;
argv2 = a2;
}
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]);
}
}
} else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"procedure-result chaperone: %V: returned %d values, expected %d",
post,
argc, c);
return NULL;
}
if (c == 1)
return argv2[0];
else
return scheme_values(c, argv2);
}
}
static Scheme_Object *
apply(int argc, Scheme_Object *argv[])
{

4
src/mzscheme/src/gen-jit-ts.ss
View File

@ -155,7 +155,9 @@
s_v
iSi_s
siS_v
z_p))
z_p
si_s
sis_v))
(with-output-to-file "jit_ts_def.c"
#:exists 'replace

6
src/mzscheme/src/hash.c
View File

@ -999,6 +999,9 @@ static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi)
Scheme_Type t;
top:
if (SCHEME_CHAPERONEP(o))
o = ((Scheme_Chaperone *)o)->val;
t = SCHEME_TYPE(o);
k += t;
@ -1421,6 +1424,9 @@ static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
Scheme_Type t;
top:
if (SCHEME_CHAPERONEP(o))
o = ((Scheme_Chaperone *)o)->val;
t = SCHEME_TYPE(o);
if (hi->depth > (MAX_HASH_DEPTH << 1))

423
src/mzscheme/src/jit.c
View File

@ -146,13 +146,14 @@ SHARED_OK static void *bad_car_code, *bad_cdr_code;
SHARED_OK static void *bad_caar_code, *bad_cdar_code, *bad_cadr_code, *bad_cddr_code;
SHARED_OK static void *bad_mcar_code, *bad_mcdr_code;
SHARED_OK static void *bad_set_mcar_code, *bad_set_mcdr_code;
SHARED_OK static void *bad_unbox_code;
SHARED_OK static void *unbox_code, *set_box_code;
SHARED_OK static void *bad_vector_length_code;
SHARED_OK static void *bad_flvector_length_code;
SHARED_OK static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code;
SHARED_OK static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
SHARED_OK static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code;
SHARED_OK static void *flvector_ref_check_index_code, *flvector_set_check_index_code, *flvector_set_flonum_check_index_code;
SHARED_OK static void *struct_ref_code, *struct_set_code;
SHARED_OK static void *syntax_e_code;
SHARED_OK void *scheme_on_demand_jit_code;
SHARED_OK static void *on_demand_jit_arity_code;
@ -2028,7 +2029,7 @@ static int check_val_struct_prim(Scheme_Object *p, int arity)
return 2;
} else if (arity == 2) {
if ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_OTHER)
&& ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK)
&& ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK)
== SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER))
return 3;
}
@ -6157,7 +6158,7 @@ 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,
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;
@ -6183,17 +6184,31 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
CHECK_LIMIT();
}
ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type);
if (lo_ty == hi_ty) {
ref3 = jit_bnei_p(jit_forward(), JIT_R0, lo_ty);
if ((lo_ty == scheme_integer_type) && (scheme_integer_type == hi_ty)) {
ref3 = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
ref4 = NULL;
ref = NULL;
} else {
ref3 = jit_blti_p(jit_forward(), JIT_R0, lo_ty);
ref4 = jit_bgti_p(jit_forward(), JIT_R0, hi_ty);
}
if (int_ok) {
mz_patch_branch(ref);
ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
if (can_chaperone) {
__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);
jit_ldxi_s(JIT_R1, JIT_R1, &((Scheme_Object *)0x0)->type);
mz_patch_branch(ref3);
__END_INNER_TINY__(branch_short);
}
if (lo_ty == hi_ty) {
ref3 = jit_bnei_p(jit_forward(), JIT_R1, lo_ty);
ref4 = NULL;
} else {
ref3 = jit_blti_p(jit_forward(), JIT_R1, lo_ty);
ref4 = jit_bgti_p(jit_forward(), JIT_R1, hi_ty);
}
if (int_ok) {
mz_patch_branch(ref);
}
}
if (for_branch) {
if (!int_ok) {
@ -6204,9 +6219,6 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
branch_for_true(jitter, for_branch);
CHECK_LIMIT();
} else {
if ((lo_ty <= scheme_integer_type) && (scheme_integer_type <= hi_ty)) {
mz_patch_branch(ref);
}
(void)jit_movi_p(JIT_R0, scheme_true);
ref2 = jit_jmpi(jit_forward());
if (!int_ok) {
@ -6327,52 +6339,55 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
generate_inlined_constant_test(jitter, app, scheme_null, NULL, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "pair?")) {
generate_inlined_type_test(jitter, app, scheme_pair_type, scheme_pair_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_pair_type, scheme_pair_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "mpair?")) {
generate_inlined_type_test(jitter, app, scheme_mutable_pair_type, scheme_mutable_pair_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_mutable_pair_type, scheme_mutable_pair_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "symbol?")) {
generate_inlined_type_test(jitter, app, scheme_symbol_type, scheme_symbol_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_symbol_type, scheme_symbol_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "syntax?")) {
generate_inlined_type_test(jitter, app, scheme_stx_type, scheme_stx_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_stx_type, scheme_stx_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "char?")) {
generate_inlined_type_test(jitter, app, scheme_char_type, scheme_char_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_char_type, scheme_char_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "boolean?")) {
generate_inlined_constant_test(jitter, app, scheme_false, scheme_true, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "number?")) {
generate_inlined_type_test(jitter, app, scheme_integer_type, scheme_complex_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_integer_type, scheme_complex_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "real?")) {
generate_inlined_type_test(jitter, app, scheme_integer_type, scheme_double_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_integer_type, scheme_double_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "exact-integer?")) {
generate_inlined_type_test(jitter, app, scheme_integer_type, scheme_bignum_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_integer_type, scheme_bignum_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "fixnum?")) {
generate_inlined_type_test(jitter, app, scheme_integer_type, scheme_integer_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_integer_type, scheme_integer_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "inexact-real?")) {
generate_inlined_type_test(jitter, app, SCHEME_FLOAT_TYPE, scheme_double_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, SCHEME_FLOAT_TYPE, scheme_double_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "procedure?")) {
generate_inlined_type_test(jitter, app, scheme_prim_type, scheme_native_closure_type, 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;
} else if (IS_NAMED_PRIM(rator, "chaperone?")) {
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?")) {
generate_inlined_type_test(jitter, app, scheme_vector_type, scheme_vector_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_vector_type, scheme_vector_type, 1, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "box?")) {
generate_inlined_type_test(jitter, app, scheme_box_type, scheme_box_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_box_type, scheme_box_type, 1, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "string?")) {
generate_inlined_type_test(jitter, app, scheme_char_string_type, scheme_char_string_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_char_string_type, scheme_char_string_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "bytes?")) {
generate_inlined_type_test(jitter, app, scheme_byte_string_type, scheme_byte_string_type, for_branch, branch_short, need_sync);
generate_inlined_type_test(jitter, app, scheme_byte_string_type, scheme_byte_string_type, 0, for_branch, branch_short, need_sync);
return 1;
} else if (IS_NAMED_PRIM(rator, "eof-object?")) {
generate_inlined_constant_test(jitter, app, scheme_eof, NULL, for_branch, branch_short, need_sync);
@ -6599,20 +6614,25 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
return 1;
} else if (IS_NAMED_PRIM(rator, "vector-length")
|| IS_NAMED_PRIM(rator, "unsafe-vector-length")
|| IS_NAMED_PRIM(rator, "unsafe-vector*-length")
|| IS_NAMED_PRIM(rator, "flvector-length")
|| IS_NAMED_PRIM(rator, "unsafe-flvector-length")) {
GC_CAN_IGNORE jit_insn *reffail, *ref;
int unsafe = 0, for_fl = 0;
int unsafe = 0, for_fl = 0, can_chaperone = 0;
if (IS_NAMED_PRIM(rator, "unsafe-vector-length")) {
unsafe = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-vector*-length")) {
unsafe = 1;
can_chaperone = 1;
} else if (IS_NAMED_PRIM(rator, "flvector-length")) {
for_fl = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-flvector-length")) {
unsafe = 1;
for_fl = 1;
} else {
can_chaperone = 1;
}
LOG_IT(("inlined vector-length\n"));
@ -6635,6 +6655,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
(void)jit_calli(bad_vector_length_code);
else
(void)jit_calli(bad_flvector_length_code);
/* bad_vector_length_code may unpack a proxied object */
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
@ -6644,6 +6665,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
else
(void)jit_bnei_i(reffail, JIT_R1, scheme_flvector_type);
__END_TINY_JUMPS__(1);
} else if (can_chaperone) {
__START_TINY_JUMPS__(1);
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
ref = jit_bnei_i(jit_forward(), JIT_R1, scheme_chaperone_type);
jit_ldxi_p(JIT_R0, JIT_R0, (long)&((Scheme_Chaperone *)0x0)->val);
mz_patch_branch(ref);
__END_TINY_JUMPS__(1);
}
if (!for_fl)
@ -6674,7 +6702,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
return 1;
} else if (IS_NAMED_PRIM(rator, "unbox")) {
GC_CAN_IGNORE jit_insn *reffail, *ref;
GC_CAN_IGNORE jit_insn *reffail, *ref, *refdone;
LOG_IT(("inlined unbox\n"));
@ -6692,9 +6720,10 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
__END_TINY_JUMPS__(1);
reffail = _jit.x.pc;
(void)jit_calli(bad_unbox_code);
(void)jit_calli(unbox_code);
__START_TINY_JUMPS__(1);
refdone = jit_jmpi(jit_forward());
mz_patch_branch(ref);
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(reffail, JIT_R1, scheme_box_type);
@ -6702,6 +6731,10 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
(void)jit_ldxi_p(JIT_R0, JIT_R0, &SCHEME_BOX_VAL(0x0));
__START_TINY_JUMPS__(1);
mz_patch_ucbranch(refdone);
__END_TINY_JUMPS__(1);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-unbox")) {
LOG_IT(("inlined unbox\n"));
@ -6715,6 +6748,34 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
(void)jit_ldxi_p(JIT_R0, JIT_R0, &SCHEME_BOX_VAL(0x0));
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-unbox*")) {
GC_CAN_IGNORE jit_insn *ref, *ref2;
LOG_IT(("inlined unbox\n"));
mz_runstack_skipped(jitter, 1);
generate_non_tail(app->rand, jitter, 0, 1, 0);
CHECK_LIMIT();
mz_runstack_unskipped(jitter, 1);
/* check for chaperone: */
__START_TINY_JUMPS__(1);
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
ref = jit_bnei_i(jit_forward(), JIT_R1, scheme_chaperone_type);
(void)jit_calli(unbox_code);
ref2 = jit_jmpi(jit_forward());
mz_patch_branch(ref);
__END_TINY_JUMPS__(1);
(void)jit_ldxi_p(JIT_R0, JIT_R0, &SCHEME_BOX_VAL(0x0));
__START_TINY_JUMPS__(1);
mz_patch_ucbranch(ref2);
__END_TINY_JUMPS__(1);
return 1;
} else if (IS_NAMED_PRIM(rator, "syntax-e")) {
LOG_IT(("inlined syntax-e\n"));
@ -7021,17 +7082,28 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app,
}
static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int base_offset,
int for_fl, int unsafe, int unbox_flonum, int result_ignored)
/* if int_ready, JIT_R1 has num index (for safe mode) and JIT_V1 has pre-computed offset,
otherwise JIT_R1 has fixnum index */
int for_fl, int unsafe,
int unbox_flonum, int result_ignored, int can_chaperone, int for_struct)
/* R0 has vector. In set mode, R2 has value; if not unboxed, not unsafe, or can chaperone,
RUNSTACK has space for a temporary (intended for R2).
If int_ready, R1 has num index (for safe mode) and V1 has pre-computed offset,
otherwise R1 has fixnum index */
{
GC_CAN_IGNORE jit_insn *ref, *reffail;
GC_CAN_IGNORE jit_insn *ref, *reffail, *pref;
if (!skip_checks && !unsafe) {
if (!skip_checks && (!unsafe || can_chaperone)) {
if (set && !unbox_flonum)
mz_rs_str(JIT_R2);
if (set && !unbox_flonum)
mz_rs_str(JIT_R2);
__START_TINY_JUMPS__(1);
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
if (!unsafe) {
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
} else {
/* assert: can_chaperone */
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
ref = jit_bnei_i(jit_forward(), JIT_R2, scheme_chaperone_type);
}
__END_TINY_JUMPS__(1);
reffail = _jit.x.pc;
@ -7040,53 +7112,67 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
jit_ori_l(JIT_R1, JIT_R1, 0x1);
}
if (set) {
if (!for_fl)
if (for_struct)
(void)jit_calli(struct_set_code);
else if (!for_fl)
(void)jit_calli(vector_set_check_index_code);
else if (unbox_flonum)
(void)jit_calli(flvector_set_flonum_check_index_code);
else
(void)jit_calli(flvector_set_check_index_code);
} else {
if (!for_fl)
if (for_struct)
(void)jit_calli(struct_ref_code);
else if (!for_fl)
(void)jit_calli(vector_ref_check_index_code);
else
(void)jit_calli(flvector_ref_check_index_code);
}
/* doesn't return */
CHECK_LIMIT();
if (can_chaperone) {
pref = jit_jmpi(jit_forward());
} else {
/* doesn't return */
pref = NULL;
}
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
if (!int_ready)
(void)jit_bmci_ul(reffail, JIT_R1, 0x1);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
if (!for_fl) {
(void)jit_bnei_i(reffail, JIT_R2, scheme_vector_type);
jit_ldxi_i(JIT_R2, JIT_R0, (int)&SCHEME_VEC_SIZE(0x0));
} else {
(void)jit_bnei_i(reffail, JIT_R2, scheme_flvector_type);
jit_ldxi_l(JIT_R2, JIT_R0, (int)&SCHEME_FLVEC_SIZE(0x0));
}
if (!int_ready) {
jit_rshi_ul(JIT_V1, JIT_R1, 1);
(void)jit_bler_ul(reffail, JIT_R2, JIT_V1);
} else {
(void)jit_bler_ul(reffail, JIT_R2, JIT_R1);
}
CHECK_LIMIT();
if (for_fl && set && !unbox_flonum) {
jit_ldr_p(JIT_R2, JIT_RUNSTACK);
(void)jit_bmsi_ul(reffail, JIT_R2, 0x1);
jit_ldxi_s(JIT_R2, JIT_R2, &((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(reffail, JIT_R2, scheme_double_type);
if (!unsafe) {
if (!int_ready)
(void)jit_bmci_ul(reffail, JIT_R1, 0x1);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
if (!for_fl) {
(void)jit_bnei_i(reffail, JIT_R2, scheme_vector_type);
jit_ldxi_i(JIT_R2, JIT_R0, (int)&SCHEME_VEC_SIZE(0x0));
} else {
(void)jit_bnei_i(reffail, JIT_R2, scheme_flvector_type);
jit_ldxi_l(JIT_R2, JIT_R0, (int)&SCHEME_FLVEC_SIZE(0x0));
}
if (!int_ready) {
jit_rshi_ul(JIT_V1, JIT_R1, 1);
(void)jit_bler_ul(reffail, JIT_R2, JIT_V1);
} else {
(void)jit_bler_ul(reffail, JIT_R2, JIT_R1);
}
CHECK_LIMIT();
if (for_fl && set && !unbox_flonum) {
jit_ldr_p(JIT_R2, JIT_RUNSTACK);
(void)jit_bmsi_ul(reffail, JIT_R2, 0x1);
jit_ldxi_s(JIT_R2, JIT_R2, &((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(reffail, JIT_R2, scheme_double_type);
CHECK_LIMIT();
}
} else if (!int_ready) {
jit_rshi_ul(JIT_V1, JIT_R1, 1);
}
__END_TINY_JUMPS__(1);
} else {
if (!int_ready)
jit_rshi_ul(JIT_V1, JIT_R1, 1);
pref = NULL;
}
if (!int_ready) {
@ -7123,6 +7209,8 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
else
generate_alloc_double(jitter, 0);
}
if (can_chaperone)
mz_patch_ucbranch(pref);
}
return 1;
@ -7480,7 +7568,9 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
return 1;
} else if (IS_NAMED_PRIM(rator, "vector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-vector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-vector*-ref")
|| IS_NAMED_PRIM(rator, "unsafe-struct-ref")
|| IS_NAMED_PRIM(rator, "unsafe-struct*-ref")
|| IS_NAMED_PRIM(rator, "string-ref")
|| IS_NAMED_PRIM(rator, "unsafe-string-ref")
|| IS_NAMED_PRIM(rator, "bytes-ref")
@ -7489,12 +7579,17 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
int simple;
int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0));
int unbox = jitter->unbox;
int can_chaperone = 1, for_struct = 0;
if (IS_NAMED_PRIM(rator, "vector-ref"))
which = 0;
else if (IS_NAMED_PRIM(rator, "unsafe-vector-ref")) {
which = 0;
unsafe = 1;
can_chaperone = 0;
} else if (IS_NAMED_PRIM(rator, "unsafe-vector*-ref")) {
which = 0;
unsafe = 1;
} else if (IS_NAMED_PRIM(rator, "flvector-ref")) {
which = 3;
base_offset = ((int)&SCHEME_FLVEC_ELS(0x0));
@ -7507,6 +7602,13 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
which = 0;
unsafe = 1;
base_offset = ((int)&((Scheme_Structure *)0x0)->slots);
can_chaperone = 0;
for_struct = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-struct*-ref")) {
which = 0;
unsafe = 1;
base_offset = ((int)&((Scheme_Structure *)0x0)->slots);
for_struct = 1;
} else if (IS_NAMED_PRIM(rator, "string-ref"))
which = 1;
else if (IS_NAMED_PRIM(rator, "unsafe-string-ref")) {
@ -7532,11 +7634,13 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
if (!which) {
/* vector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 0, base_offset, 0, unsafe, 0, 0);
generate_vector_op(jitter, 0, 0, base_offset, 0, unsafe,
0, 0, can_chaperone, for_struct);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 0, base_offset, 1, unsafe, unbox, 0);
generate_vector_op(jitter, 0, 0, base_offset, 1, unsafe,
unbox, 0, can_chaperone, for_struct);
CHECK_LIMIT();
} else if (which == 1) {
if (unsafe) {
@ -7586,11 +7690,13 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
jit_movi_l(JIT_V1, offset);
if (!which) {
/* vector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 1, base_offset, 0, unsafe, 0, 0);
generate_vector_op(jitter, 0, 1, base_offset, 0, unsafe,
0, 0, can_chaperone, for_struct);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 1, base_offset, 1, unsafe, unbox, 0);
generate_vector_op(jitter, 0, 1, base_offset, 1, unsafe,
unbox, 0, can_chaperone, for_struct);
CHECK_LIMIT();
} else if (which == 1) {
if (unsafe) {
@ -7711,6 +7817,40 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
else
(void)jit_stxi_p(&((Scheme_Simple_Object *)0x0)->u.pair_val.cdr, JIT_R0, JIT_R1);
if (!result_ignored)
(void)jit_movi_p(JIT_R0, scheme_void);
return 1;
} else if (IS_NAMED_PRIM(rator, "set-box!")
|| IS_NAMED_PRIM(rator, "unsafe-set-box*!")) {
GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3;
int unsafe;
LOG_IT(("inlined set-box!\n"));
unsafe = IS_NAMED_PRIM(rator, "unsafe-set-box*!");
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
CHECK_LIMIT();
__START_TINY_JUMPS__(1);
if (!unsafe)
ref3 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
else
ref3 = NULL;
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
ref = jit_beqi_i(jit_forward(), JIT_R2, scheme_box_type);
mz_patch_branch(ref3);
(void)jit_calli(set_box_code);
ref2 = jit_jmpi(jit_forward());
mz_patch_branch(ref);
__END_TINY_JUMPS__(1);
(void)jit_stxi_p(&SCHEME_BOX_VAL(0x0), JIT_R0, JIT_R1);
__START_TINY_JUMPS__(1);
mz_patch_ucbranch(ref2);
__END_TINY_JUMPS__(1);
if (!result_ignored)
(void)jit_movi_p(JIT_R0, scheme_void);
@ -7837,8 +7977,10 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
} else if (!for_branch) {
if (IS_NAMED_PRIM(rator, "vector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-vector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-vector*-set!")
|| IS_NAMED_PRIM(rator, "flvector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-struct-set!")
|| IS_NAMED_PRIM(rator, "unsafe-struct*-set!")
|| IS_NAMED_PRIM(rator, "string-set!")
|| IS_NAMED_PRIM(rator, "unsafe-string-set!")
|| IS_NAMED_PRIM(rator, "bytes-set!")
@ -7846,12 +7988,17 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
int simple, constval, can_delay_vec, can_delay_index;
int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0));
int pushed, flonum_arg;
int can_chaperone, for_struct = 0;
if (IS_NAMED_PRIM(rator, "vector-set!"))
which = 0;
else if (IS_NAMED_PRIM(rator, "unsafe-vector-set!")) {
which = 0;
unsafe = 1;
can_chaperone = 0;
} else if (IS_NAMED_PRIM(rator, "unsafe-vector*-set!")) {
which = 0;
unsafe = 1;
} else if (IS_NAMED_PRIM(rator, "flvector-set!")) {
which = 3;
base_offset = ((int)&SCHEME_FLVEC_ELS(0x0));
@ -7859,6 +8006,13 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
which = 0;
unsafe = 1;
base_offset = ((int)&((Scheme_Structure *)0x0)->slots);
can_chaperone = 0;
for_struct = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-struct*-set!")) {
which = 0;
unsafe = 1;
base_offset = ((int)&((Scheme_Structure *)0x0)->slots);
for_struct = 1;
} else if (IS_NAMED_PRIM(rator, "string-set!"))
which = 1;
else if (IS_NAMED_PRIM(rator, "unsafe-string-set!")) {
@ -7996,12 +8150,12 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!which) {
/* vector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 0, base_offset, 0, unsafe,
flonum_arg, result_ignored);
flonum_arg, result_ignored, can_chaperone, for_struct);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 0, base_offset, 1, unsafe,
flonum_arg, result_ignored);
flonum_arg, result_ignored, can_chaperone, for_struct);
CHECK_LIMIT();
} else if (which == 1) {
if (unsafe) {
@ -8043,12 +8197,12 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!which) {
/* vector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 1, base_offset, 0, unsafe,
flonum_arg, result_ignored);
flonum_arg, result_ignored, can_chaperone, for_struct);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 1, base_offset, 1, unsafe,
flonum_arg, result_ignored);
flonum_arg, result_ignored, can_chaperone, for_struct);
CHECK_LIMIT();
} else if (which == 1) {
if (unsafe) {
@ -10482,20 +10636,44 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
register_sub_func(jitter, code, scheme_false);
}
/* *** bad_unbox_code *** */
/* *** unbox_code *** */
/* R0 is argument */
bad_unbox_code = jit_get_ip().ptr;
unbox_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
jit_prepare(1);
jit_pusharg_p(JIT_R0);
(void)mz_finish(ts_scheme_unbox);
CHECK_LIMIT();
register_sub_func(jitter, bad_unbox_code, scheme_false);
jit_retval(JIT_R0); /* returns if proxied */
mz_epilog(JIT_R1);
register_sub_func(jitter, unbox_code, scheme_false);
/* *** set_box_code *** */
/* R0 is box, R1 is value */
set_box_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
jit_prepare(2);
jit_pusharg_p(JIT_R1);
jit_pusharg_p(JIT_R0);
(void)mz_finish(ts_scheme_set_box);
CHECK_LIMIT();
/* returns if proxied */
mz_epilog(JIT_R1);
register_sub_func(jitter, set_box_code, scheme_false);
/* *** bad_vector_length_code *** */
/* R0 is argument */
bad_vector_length_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
/* Check for chaperone: */
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
ref = jit_bnei_i(jit_forward(), JIT_R1, scheme_chaperone_type);
jit_ldxi_p(JIT_R0, JIT_R0, (long)&((Scheme_Chaperone *)0x0)->val);
mz_epilog(JIT_R1); /* return after unwrapping */
CHECK_LIMIT();
mz_patch_branch(ref);
jit_prepare(1);
jit_pusharg_i(JIT_R0);
(void)mz_finish(ts_scheme_vector_length);
@ -10807,6 +10985,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
jit_insn *ref, *reffail;
Scheme_Type ty;
int offset, count_offset, log_elem_size;
void *code;
code = jit_get_ip().ptr;
switch (ii) {
case 0:
@ -10816,15 +10997,15 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
log_elem_size = JIT_LOG_WORD_SIZE;
if (!iii) {
if (!i) {
vector_ref_code = jit_get_ip().ptr;
vector_ref_code = code;
} else {
vector_ref_check_index_code = jit_get_ip().ptr;
vector_ref_check_index_code = code;
}
} else {
if (!i) {
vector_set_code = jit_get_ip().ptr;
vector_set_code = code;
} else {
vector_set_check_index_code = jit_get_ip().ptr;
vector_set_check_index_code = code;
}
}
break;
@ -10835,15 +11016,15 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
log_elem_size = LOG_MZCHAR_SIZE;
if (!iii) {
if (!i) {
string_ref_code = jit_get_ip().ptr;
string_ref_code = code;
} else {
string_ref_check_index_code = jit_get_ip().ptr;
string_ref_check_index_code = code;
}
} else {
if (!i) {
string_set_code = jit_get_ip().ptr;
string_set_code = code;
} else {
string_set_check_index_code = jit_get_ip().ptr;
string_set_check_index_code = code;
}
}
break;
@ -10855,15 +11036,15 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
log_elem_size = 0;
if (!iii) {
if (!i) {
bytes_ref_code = jit_get_ip().ptr;
bytes_ref_code = code;
} else {
bytes_ref_check_index_code = jit_get_ip().ptr;
bytes_ref_check_index_code = code;
}
} else {
if (!i) {
bytes_set_code = jit_get_ip().ptr;
bytes_set_code = code;
} else {
bytes_set_check_index_code = jit_get_ip().ptr;
bytes_set_check_index_code = code;
}
}
break;
@ -10900,13 +11081,24 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
case 0:
if (!iii) {
(void)mz_finish(ts_scheme_checked_vector_ref);
CHECK_LIMIT();
/* Might return, if arg was chaperone */
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
jit_retval(JIT_R0);
mz_epilog(JIT_R2);
} else {
(void)mz_finish(ts_scheme_checked_vector_set);
/* Might return, if arg was chaperone */
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(3));
JIT_UPDATE_THREAD_RSPTR();
mz_epilog(JIT_R2);
}
break;
case 1:
if (!iii) {
(void)mz_finish(ts_scheme_checked_string_ref);
CHECK_LIMIT();
/* might return, if char was outside Latin-1 */
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
@ -11009,6 +11201,8 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
CHECK_LIMIT();
__END_TINY_JUMPS__(1);
register_sub_func(jitter, code, scheme_false);
}
}
}
@ -11016,12 +11210,16 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* *** {flvector}_{ref,set}_check_index_code *** */
/* Same calling convention as for vector ops. */
for (i = 0; i < 3; i++) {
void *code;
code = jit_get_ip().ptr;
if (!i) {
flvector_ref_check_index_code = jit_get_ip().ptr;
flvector_ref_check_index_code = code;
} else if (i == 1) {
flvector_set_check_index_code = jit_get_ip().ptr;
flvector_set_check_index_code = code;
} else {
flvector_set_flonum_check_index_code = jit_get_ip().ptr;
flvector_set_flonum_check_index_code = code;
}
mz_prolog(JIT_R2);
@ -11054,8 +11252,47 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
}
/* does not return */
CHECK_LIMIT();
register_sub_func(jitter, code, scheme_false);
}
/* *** struct_{ref,set}_code *** */
/* R0 is struct, R1 is index (Scheme number).
In set mode, value is on run stack. */
for (iii = 0; iii < 2; iii++) { /* ref, set */
void *code;
code = jit_get_ip().ptr;
if (!iii) {
struct_ref_code = code;
} else {
struct_set_code = code;
}
mz_prolog(JIT_R2);
jit_rshi_ul(JIT_R1, JIT_R1, 1);
JIT_UPDATE_THREAD_RSPTR();
if (!iii)
jit_prepare(2);
else {
jit_ldr_p(JIT_R2, JIT_RUNSTACK);
jit_prepare(3);
jit_pusharg_p(JIT_R2);
}
jit_pusharg_p(JIT_R1);
jit_pusharg_i(JIT_R0);
if (!iii) {
(void)mz_finish(ts_scheme_struct_ref);
jit_retval(JIT_R0);
} else
(void)mz_finish(ts_scheme_struct_set);
CHECK_LIMIT();
jit_retval(JIT_R0);
mz_epilog(JIT_R2);
register_sub_func(jitter, code, scheme_false);
}
/* *** syntax_ecode *** */
/* R0 is (potential) syntax object */
@ -11200,7 +11437,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
(void)jit_bnei_i(refslow, JIT_R2, scheme_prim_type);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags);
if (kind == 3) {
jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK);
jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK);
(void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER);
} else {
(void)jit_bmci_i(refslow, JIT_R2, ((kind == 1)

3
src/mzscheme/src/jit_ts.c
View File

@ -22,6 +22,7 @@ define_ts_s_s(scheme_force_one_value_same_mark, FSRC_OTHER)
define_ts__s(malloc_double, FSRC_OTHER)
#endif
define_ts_s_s(scheme_box, FSRC_OTHER)
define_ts_ss_v(scheme_set_box, FSRC_OTHER)
#ifndef CAN_INLINE_ALLOC
define_ts_ss_s(scheme_make_mutable_pair, FSRC_OTHER)
define_ts_Sl_s(make_list_star, FSRC_OTHER)
@ -61,6 +62,8 @@ define_ts_iS_s(scheme_checked_set_mcdr, FSRC_OTHER)
define_ts_s_s(scheme_unbox, FSRC_OTHER)
define_ts_s_s(scheme_vector_length, FSRC_OTHER)
define_ts_s_s(scheme_flvector_length, FSRC_OTHER)
define_ts_si_s(scheme_struct_ref, FSRC_OTHER)
define_ts_sis_v(scheme_struct_set, FSRC_OTHER)
define_ts_s_s(tail_call_with_values_from_multiple_result, FSRC_OTHER)
define_ts_s_v(raise_bad_call_with_values, FSRC_OTHER)
define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_OTHER)

18
src/mzscheme/src/jit_ts_def.c
View File

@ -178,3 +178,21 @@ static void* ts_ ## id(size_t g43) \
else \
return id(g43); \
}
#define define_ts_si_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object* g44, int g45) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_si_s("[" #id "]", src_type, id, g44, g45); \
else \
return id(g44, g45); \
}
#define define_ts_sis_v(id, src_type) \
static void ts_ ## id(Scheme_Object* g46, int g47, Scheme_Object* g48) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_sis_v("[" #id "]", src_type, id, g46, g47, g48); \
else \
id(g46, g47, g48); \
}

167
src/mzscheme/src/jit_ts_future_glue.c
View File

@ -1,4 +1,4 @@
Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g44, int g45, Scheme_Object** g46)
Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g49, int g50, Scheme_Object** g51)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -13,9 +13,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g44;
future->arg_i1 = g45;
future->arg_S2 = g46;
future->arg_s0 = g49;
future->arg_i1 = g50;
future->arg_S2 = g51;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -24,7 +24,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g47, Scheme_Object** g48, Scheme_Object* g49)
Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g52, Scheme_Object** g53, Scheme_Object* g54)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -39,9 +39,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g47;
future->arg_S1 = g48;
future->arg_s2 = g49;
future->arg_i0 = g52;
future->arg_S1 = g53;
future->arg_s2 = g54;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -50,7 +50,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g50)
Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g55)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -65,8 +65,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g50;
send_special_result(future, g50);
future->arg_s0 = g55;
send_special_result(future, g55);
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
retval = future->retval_s;
@ -74,7 +74,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g51)
Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g56)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -89,7 +89,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_n0 = g51;
future->arg_n0 = g56;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -122,7 +122,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g52, Scheme_Object* g53)
Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g57, Scheme_Object* g58)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -137,8 +137,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g52;
future->arg_s1 = g53;
future->arg_s0 = g57;
future->arg_s1 = g58;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -147,7 +147,7 @@
receive_special_result(future, retval, 1);
return retval;
}
MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g54, Scheme_Object* g55)
MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g59, Scheme_Object* g60)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -162,8 +162,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g54;
future->arg_s1 = g55;
future->arg_s0 = g59;
future->arg_s1 = g60;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -172,7 +172,7 @@
return retval;
}
Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g56, long g57)
Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g61, long g62)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -187,8 +187,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_S0 = g56;
future->arg_l1 = g57;
future->arg_S0 = g61;
future->arg_l1 = g62;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -197,7 +197,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g58)
Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g63)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -212,7 +212,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_l0 = g58;
future->arg_l0 = g63;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -221,7 +221,7 @@
receive_special_result(future, retval, 1);
return retval;
}
void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g59, Scheme_Object* g60, int g61)
void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g64, Scheme_Object* g65, int g66)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -236,9 +236,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_b0 = g59;
future->arg_s1 = g60;
future->arg_i2 = g61;
future->arg_b0 = g64;
future->arg_s1 = g65;
future->arg_i2 = g66;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -247,7 +247,7 @@
}
void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g62, int g63, Scheme_Object** g64)
void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g67, int g68, Scheme_Object** g69)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -262,9 +262,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g62;
future->arg_i1 = g63;
future->arg_S2 = g64;
future->arg_i0 = g67;
future->arg_i1 = g68;
future->arg_S2 = g69;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -273,7 +273,7 @@
}
void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g65, Scheme_Object* g66)
void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g70, Scheme_Object* g71)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -288,8 +288,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g65;
future->arg_s1 = g66;
future->arg_s0 = g70;
future->arg_s1 = g71;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -298,7 +298,7 @@
}
void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g67)
void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g72)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -313,7 +313,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_b0 = g67;
future->arg_b0 = g72;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -322,7 +322,7 @@
}
Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g68, long g69)
Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g73, long g74)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -337,8 +337,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g68;
future->arg_l1 = g69;
future->arg_s0 = g73;
future->arg_l1 = g74;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -347,7 +347,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g70, Scheme_Object** g71)
Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g75, Scheme_Object** g76)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -362,8 +362,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g70;
future->arg_S1 = g71;
future->arg_i0 = g75;
future->arg_S1 = g76;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -372,7 +372,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g72)
Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g77)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -387,7 +387,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_S0 = g72;
future->arg_S0 = g77;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -396,7 +396,7 @@
receive_special_result(future, retval, 1);
return retval;
}
void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g73)
void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g78)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -411,8 +411,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g73;
send_special_result(future, g73);
future->arg_s0 = g78;
send_special_result(future, g78);
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -420,7 +420,7 @@
}
Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g74, Scheme_Object** g75, int g76)
Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g79, Scheme_Object** g80, int g81)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -435,9 +435,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g74;
future->arg_S1 = g75;
future->arg_i2 = g76;
future->arg_i0 = g79;
future->arg_S1 = g80;
future->arg_i2 = g81;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -446,7 +446,7 @@
receive_special_result(future, retval, 1);
return retval;
}
void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g77, int g78, Scheme_Object** g79)
void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g82, int g83, Scheme_Object** g84)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -461,9 +461,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g77;
future->arg_i1 = g78;
future->arg_S2 = g79;
future->arg_s0 = g82;
future->arg_i1 = g83;
future->arg_S2 = g84;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -472,7 +472,7 @@
}
void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g80)
void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g85)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -487,7 +487,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_z0 = g80;
future->arg_z0 = g85;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
@ -495,4 +495,55 @@
future->retval_p = 0;
return retval;
}
Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g86, int g87)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
future_t *future;
double tm;
Scheme_Object* retval;
future = fts->current_ft;
future->prim_protocol = SIG_si_s;
future->prim_func = f;
tm = scheme_get_inexact_milliseconds();
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g86;
future->arg_i1 = g87;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
retval = future->retval_s;
future->retval_s = 0;
receive_special_result(future, retval, 1);
return retval;
}
void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g88, int g89, Scheme_Object* g90)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
future_t *future;
double tm;
future = fts->current_ft;
future->prim_protocol = SIG_sis_v;
future->prim_func = f;
tm = scheme_get_inexact_milliseconds();
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g88;
future->arg_i1 = g89;
future->arg_s2 = g90;
future_do_runtimecall(fts, (void*)f, 0);
future = fts->current_ft;
}

44
src/mzscheme/src/jit_ts_protos.h
View File

@ -1,60 +1,66 @@
#define SIG_siS_s 5
typedef Scheme_Object* (*prim_siS_s)(Scheme_Object*, int, Scheme_Object**);
Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g118, int g119, Scheme_Object** g120);
Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g133, int g134, Scheme_Object** g135);
#define SIG_iSs_s 6
typedef Scheme_Object* (*prim_iSs_s)(int, Scheme_Object**, Scheme_Object*);
Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g121, Scheme_Object** g122, Scheme_Object* g123);
Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g136, Scheme_Object** g137, Scheme_Object* g138);
#define SIG_s_s 7
typedef Scheme_Object* (*prim_s_s)(Scheme_Object*);
Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g124);
Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g139);
#define SIG_n_s 8
typedef Scheme_Object* (*prim_n_s)(Scheme_Native_Closure_Data*);
Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g125);
Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g140);
#define SIG__s 9
typedef Scheme_Object* (*prim__s)();
Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f );
#define SIG_ss_s 10
typedef Scheme_Object* (*prim_ss_s)(Scheme_Object*, Scheme_Object*);
Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g126, Scheme_Object* g127);
Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g141, Scheme_Object* g142);
#define SIG_ss_m 11
typedef MZ_MARK_STACK_TYPE (*prim_ss_m)(Scheme_Object*, Scheme_Object*);
MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g128, Scheme_Object* g129);
MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g143, Scheme_Object* g144);
#define SIG_Sl_s 12
typedef Scheme_Object* (*prim_Sl_s)(Scheme_Object**, long);
Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g130, long g131);
Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g145, long g146);
#define SIG_l_s 13
typedef Scheme_Object* (*prim_l_s)(long);
Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g132);
Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g147);
#define SIG_bsi_v 14
typedef void (*prim_bsi_v)(Scheme_Bucket*, Scheme_Object*, int);
void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g133, Scheme_Object* g134, int g135);
void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g148, Scheme_Object* g149, int g150);
#define SIG_iiS_v 15
typedef void (*prim_iiS_v)(int, int, Scheme_Object**);
void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g136, int g137, Scheme_Object** g138);
void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g151, int g152, Scheme_Object** g153);
#define SIG_ss_v 16
typedef void (*prim_ss_v)(Scheme_Object*, Scheme_Object*);
void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g139, Scheme_Object* g140);
void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g154, Scheme_Object* g155);
#define SIG_b_v 17
typedef void (*prim_b_v)(Scheme_Bucket*);
void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g141);
void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g156);
#define SIG_sl_s 18
typedef Scheme_Object* (*prim_sl_s)(Scheme_Object*, long);
Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g142, long g143);
Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g157, long g158);
#define SIG_iS_s 19
typedef Scheme_Object* (*prim_iS_s)(int, Scheme_Object**);
Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g144, Scheme_Object** g145);
Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g159, Scheme_Object** g160);
#define SIG_S_s 20
typedef Scheme_Object* (*prim_S_s)(Scheme_Object**);
Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g146);
Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g161);
#define SIG_s_v 21
typedef void (*prim_s_v)(Scheme_Object*);
void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g147);
void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g162);
#define SIG_iSi_s 22
typedef Scheme_Object* (*prim_iSi_s)(int, Scheme_Object**, int);
Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g148, Scheme_Object** g149, int g150);
Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g163, Scheme_Object** g164, int g165);
#define SIG_siS_v 23
typedef void (*prim_siS_v)(Scheme_Object*, int, Scheme_Object**);
void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g151, int g152, Scheme_Object** g153);
void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g166, int g167, Scheme_Object** g168);
#define SIG_z_p 24
typedef void* (*prim_z_p)(size_t);
void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g154);
void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g169);
#define SIG_si_s 25
typedef Scheme_Object* (*prim_si_s)(Scheme_Object*, int);
Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g170, int g171);
#define SIG_sis_v 26
typedef void (*prim_sis_v)(Scheme_Object*, int, Scheme_Object*);
void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g172, int g173, Scheme_Object* g174);

22
src/mzscheme/src/jit_ts_runtime_glue.c
View File

@ -216,5 +216,27 @@ case SIG_z_p:
f(future->arg_z0);
future->retval_p = retval;
break;
}
case SIG_si_s:
{
prim_si_s f = (prim_si_s)future->prim_func;
Scheme_Object* retval;
retval =
f(future->arg_s0, future->arg_i1);
future->retval_s = retval;
send_special_result(future, retval);
break;
}
case SIG_sis_v:
{
prim_sis_v f = (prim_sis_v)future->prim_func;
f(future->arg_s0, future->arg_i1, future->arg_s2);
break;
}

680
src/mzscheme/src/list.c
View File

@ -24,6 +24,7 @@
*/
#include "schpriv.h"
#include "schmach.h"
/* read only globals */
READ_ONLY Scheme_Object scheme_null[1];
@ -88,6 +89,7 @@ static Scheme_Object *immutable_box (int argc, Scheme_Object *argv[]);
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 *make_hash(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_hasheq(int argc, Scheme_Object *argv[]);
@ -119,6 +121,7 @@ static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[]);
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 *make_weak_box(int argc, Scheme_Object *argv[]);
static Scheme_Object *weak_box_value(int argc, Scheme_Object *argv[]);
@ -147,6 +150,9 @@ static Scheme_Object *unsafe_set_mcdr (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_unbox (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_box (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key);
static Scheme_Object *chaperone_hash_tree_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val);
#define BOX "box"
#define BOXP "box?"
#define UNBOX "unbox"
@ -446,15 +452,19 @@ scheme_init_list (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant(BOXP, p, env);
p = scheme_make_immed_prim(unbox, UNBOX, 1, 1);
p = scheme_make_noncm_prim(unbox, UNBOX, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant(UNBOX, p, env);
scheme_add_global_constant(SETBOX,
scheme_make_immed_prim(set_box,
SETBOX,
2, 2),
env);
p = scheme_make_immed_prim(set_box, SETBOX, 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant(SETBOX, p, env);
scheme_add_global_constant("chaperone-box",
scheme_make_prim_w_arity(chaperone_box,
"chaperone-box",
3, -1),
env);
scheme_add_global_constant("make-hash",
scheme_make_immed_prim(make_hash,
@ -578,16 +588,22 @@ scheme_init_list (Scheme_Env *env)
2, 2),
env);
scheme_add_global_constant("hash-iterate-value",
scheme_make_immed_prim(hash_table_iterate_value,
scheme_make_noncm_prim(hash_table_iterate_value,
"hash-iterate-value",
2, 2),
env);
scheme_add_global_constant("hash-iterate-key",
scheme_make_immed_prim(hash_table_iterate_key,
scheme_make_noncm_prim(hash_table_iterate_key,
"hash-iterate-key",
2, 2),
env);
scheme_add_global_constant("chaperone-hash",
scheme_make_prim_w_arity(chaperone_hash,
"chaperone-hash",
5, -1),
env);
scheme_add_global_constant("eq-hash-code",
scheme_make_immed_prim(eq_hash_code,
"eq-hash-code",
@ -729,9 +745,17 @@ scheme_init_unsafe_list (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("unsafe-unbox", p, env);
p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox*", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("unsafe-unbox*", p, env);
p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-set-box!", p, env);
p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box*!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-set-box*!", p, env);
}
Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
@ -1100,7 +1124,12 @@ immutablep (int argc, Scheme_Object *argv[])
|| SCHEME_CHAR_STRINGP(v)
|| SCHEME_BOXP(v)
|| SCHEME_HASHTP(v)))
|| SCHEME_HASHTRP(v)))
|| SCHEME_HASHTRP(v)
|| (SCHEME_NP_CHAPERONEP(v)
&& (SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(v))
|| ((SCHEME_VECTORP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_BOXP(SCHEME_CHAPERONE_VAL(v)))
&& SCHEME_IMMUTABLEP(SCHEME_CHAPERONE_VAL(v)))))))
? scheme_true
: scheme_false);
}
@ -1454,17 +1483,107 @@ Scheme_Object *scheme_box(Scheme_Object *v)
return obj;
}
static Scheme_Object *chaperone_unbox_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
p->ku.k.p1 = NULL;
return scheme_unbox(o);
}
static Scheme_Object *chaperone_unbox_overflow(Scheme_Object *o)
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)o;
return scheme_handle_stack_overflow(chaperone_unbox_k);
}
static Scheme_Object *chaperone_unbox(Scheme_Object *obj)
{
Scheme_Chaperone *px = (Scheme_Chaperone *)obj;
Scheme_Object *a[2], *orig;
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
return chaperone_unbox_overflow(obj);
}
#endif
orig = scheme_unbox(px->prev);
if (SCHEME_VECTORP(px->redirects)) {
/* chaperone was on property accessors */
return orig;
}
a[0] = px->prev;
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);
return obj;
}
Scheme_Object *scheme_unbox(Scheme_Object *obj)
{
if (!SCHEME_BOXP(obj))
scheme_wrong_type(UNBOX, "box", 0, 1, &obj);
if (!SCHEME_BOXP(obj)) {
if (SCHEME_NP_CHAPERONEP(obj)
&& SCHEME_BOXP(SCHEME_CHAPERONE_VAL(obj)))
return chaperone_unbox(obj);
scheme_wrong_type(UNBOX, "box", 0, 1, &obj);
}
return (Scheme_Object *)SCHEME_BOX_VAL(obj);
}
static void chaperone_set_box(Scheme_Object *obj, Scheme_Object *v)
{
Scheme_Chaperone *px;
Scheme_Object *a[2];
while (1) {
if (SCHEME_BOXP(obj)) {
SCHEME_BOX_VAL(obj) = v;
return;
} else {
px = (Scheme_Chaperone *)obj;
obj = px->prev;
a[0] = obj;
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]);
}
}
}
void scheme_set_box(Scheme_Object *b, Scheme_Object *v)
{
if (!SCHEME_MUTABLE_BOXP(b))
scheme_wrong_type(SETBOX, "mutable box", 0, 1, &b);
if (!SCHEME_MUTABLE_BOXP(b)) {
if (SCHEME_NP_CHAPERONEP(b)
&& SCHEME_MUTABLE_BOXP(SCHEME_CHAPERONE_VAL(b))) {
chaperone_set_box(b, v);
return;
}
scheme_wrong_type(SETBOX, "mutable box", 0, 1, &b);
}
SCHEME_BOX_VAL(b) = v;
}
@ -1485,7 +1604,7 @@ static Scheme_Object *immutable_box(int c, Scheme_Object *p[])
static Scheme_Object *box_p(int c, Scheme_Object *p[])
{
return SCHEME_BOXP(p[0]) ? scheme_true : scheme_false;
return SCHEME_CHAPERONE_BOXP(p[0]) ? scheme_true : scheme_false;
}
static Scheme_Object *unbox(int c, Scheme_Object *p[])
@ -1499,6 +1618,35 @@ static Scheme_Object *set_box(int c, Scheme_Object *p[])
return scheme_void;
}
static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Hash_Tree *props;
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);
redirects = scheme_make_pair(argv[1], argv[2]);
props = scheme_parse_chaperone_props("chaperone-box", 3, argc, argv);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
px->redirects = redirects;
return (Scheme_Object *)px;
}
static int compare_equal(void *v1, void *v2)
{
return !scheme_equal((Scheme_Object *)v1, (Scheme_Object *)v2);
@ -1701,14 +1849,19 @@ Scheme_Hash_Table *scheme_make_hash_table_eqv()
static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[])
{
if (SCHEME_HASHTP(argv[0])) {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v))
v = SCHEME_CHAPERONE_VAL(v);
if (SCHEME_HASHTP(v)) {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)v;
return scheme_make_integer(t->count);
} else if (SCHEME_HASHTRP(argv[0])) {
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)argv[0];
} else if (SCHEME_HASHTRP(v)) {
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)v;
return scheme_make_integer(t->count);
} else if (SCHEME_BUCKTP(argv[0])) {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
} else if (SCHEME_BUCKTP(v)) {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v;
int count = 0, weak, i;
Scheme_Bucket **buckets, *bucket;
const char *key;
@ -1739,34 +1892,49 @@ static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[])
static Scheme_Object *hash_table_copy(int argc, Scheme_Object *argv[])
{
if (SCHEME_HASHTP(argv[0])) {
Scheme_Object *v = argv[0];
if (SCHEME_NP_CHAPERONEP(v) && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(v))))
return scheme_chaperone_hash_table_copy(v);
if (SCHEME_HASHTP(v)) {
Scheme_Object *o;
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
Scheme_Hash_Table *t = (Scheme_Hash_Table *)v;
if (t->mutex) scheme_wait_sema(t->mutex,0);
o = (Scheme_Object *)scheme_clone_hash_table(t);
if (t->mutex) scheme_post_sema(t->mutex);
return o;
} else if (SCHEME_BUCKTP(argv[0])) {
} else if (SCHEME_BUCKTP(v)) {
Scheme_Object *o;
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v;
if (t->mutex) scheme_wait_sema(t->mutex,0);
o = (Scheme_Object *)scheme_clone_bucket_table(t);
if (t->mutex) scheme_post_sema(t->mutex);
return o;
} else if (SCHEME_HASHTRP(argv[0])) {
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)argv[0];
} else if (SCHEME_HASHTRP(v)) {
Scheme_Hash_Tree *t;
Scheme_Hash_Table *naya;
int i;
Scheme_Object *k, *v;
Scheme_Object *k, *val;
if (SCHEME_NP_CHAPERONEP(v))
t = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(v);
else
t = (Scheme_Hash_Tree *)v;
if (scheme_is_hash_tree_equal((Scheme_Object *)t))
naya = scheme_make_hash_table_equal();
else if (scheme_is_hash_tree_eqv((Scheme_Object *)t))
naya = scheme_make_hash_table_eqv();
else
naya = scheme_make_hash_table(SCHEME_hash_ptr);
for (i = t->count; i--; ) {
scheme_hash_tree_index(t, i, &k, &v);
scheme_hash_set(naya, k, v);
scheme_hash_tree_index(t, i, &k, &val);
if (!SAME_OBJ((Scheme_Object *)t, v))
val = scheme_chaperone_hash_traversal_get(v, k);
scheme_hash_set(naya, k, val);
}
return (Scheme_Object *)naya;
@ -1780,6 +1948,9 @@ static Scheme_Object *hash_p(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0];
if (SCHEME_CHAPERONEP(o))
o = SCHEME_CHAPERONE_VAL(o);
if (SCHEME_HASHTP(o) || SCHEME_HASHTRP(o) || SCHEME_BUCKTP(o))
return scheme_true;
else
@ -1790,6 +1961,9 @@ static Scheme_Object *hash_eq_p(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0];
if (SCHEME_CHAPERONEP(o))
o = SCHEME_CHAPERONE_VAL(o);
if (SCHEME_HASHTP(o)) {
if ((((Scheme_Hash_Table *)o)->compare != compare_equal)
&& (((Scheme_Hash_Table *)o)->compare != compare_eqv))
@ -1812,6 +1986,9 @@ static Scheme_Object *hash_eqv_p(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0];
if (SCHEME_CHAPERONEP(o))
o = SCHEME_CHAPERONE_VAL(o);
if (SCHEME_HASHTP(o)) {
if (((Scheme_Hash_Table *)o)->compare == compare_eqv)
return scheme_true;
@ -1832,6 +2009,9 @@ static Scheme_Object *hash_weak_p(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0];
if (SCHEME_CHAPERONEP(o))
o = SCHEME_CHAPERONE_VAL(o);
if (SCHEME_BUCKTP(o))
return scheme_true;
else if (SCHEME_HASHTP(o) || SCHEME_HASHTRP(o))
@ -1866,7 +2046,10 @@ static Scheme_Object *hash_table_put_bang(int argc, Scheme_Object *argv[])
{
Scheme_Object *v = argv[0];
if (SCHEME_BUCKTP(v)) {
if (SCHEME_NP_CHAPERONEP(v) && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(v))))
scheme_chaperone_hash_set(v, argv[1], argv[2]);
else if (SCHEME_BUCKTP(v)) {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v;
if (t->mutex) scheme_wait_sema(t->mutex,0);
scheme_add_to_table(t, (char *)argv[1], (void *)argv[2], 0);
@ -1889,6 +2072,9 @@ static Scheme_Object *hash_table_put(int argc, Scheme_Object *argv[])
{
Scheme_Object *v = argv[0];
if (SCHEME_NP_CHAPERONEP(v) && SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(v)))
return chaperone_hash_tree_set(v, argv[1], argv[2]);
if (!SCHEME_HASHTRP(v)) {
scheme_wrong_type("hash-set", "immutable hash", 0, argc, argv);
return NULL;
@ -1903,7 +2089,11 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
v = argv[0];
if (SCHEME_BUCKTP(v)) {
if (SCHEME_NP_CHAPERONEP(v) && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(v))))
v = scheme_chaperone_hash_get(v, argv[1]);
else if (SCHEME_BUCKTP(v)) {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v;
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = (Scheme_Object *)scheme_lookup_in_table(t, (char *)argv[1]);
@ -1940,21 +2130,31 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[])
{
if (!(SCHEME_HASHTP(argv[0]) && SCHEME_MUTABLEP(argv[0])) && !SCHEME_BUCKTP(argv[0]))
Scheme_Object *v;
v = argv[0];
if (SCHEME_NP_CHAPERONEP(v) && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(v)))) {
scheme_chaperone_hash_set(v, argv[1], NULL);
return scheme_void;
}
if (!(SCHEME_HASHTP(v) && SCHEME_MUTABLEP(v)) && !SCHEME_BUCKTP(v))
scheme_wrong_type("hash-remove!", "mutable table", 0, argc, argv);
if (SCHEME_BUCKTP(argv[0])) {
if (SCHEME_BUCKTP(v)) {
Scheme_Bucket *b;
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v;
if (t->mutex) scheme_wait_sema(t->mutex, 0);
b = scheme_bucket_or_null_from_table((Scheme_Bucket_Table *)argv[0], (char *)argv[1], 0);
b = scheme_bucket_or_null_from_table((Scheme_Bucket_Table *)v, (char *)argv[1], 0);
if (b) {
HT_EXTRACT_WEAK(b->key) = NULL;
b->val = NULL;
}
if (t->mutex) scheme_post_sema(t->mutex);
} else{
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
Scheme_Hash_Table *t = (Scheme_Hash_Table *)v;
if (t->mutex) scheme_wait_sema(t->mutex, 0);
scheme_hash_set(t, argv[1], NULL);
if (t->mutex) scheme_post_sema(t->mutex);
@ -1965,10 +2165,15 @@ static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[])
static Scheme_Object *hash_table_remove(int argc, Scheme_Object *argv[])
{
if (!SCHEME_HASHTRP(argv[0]))
Scheme_Object *v = argv[0];
if (SCHEME_NP_CHAPERONEP(v) && SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(v)))
return chaperone_hash_tree_set(v, argv[1], NULL);
if (!SCHEME_HASHTRP(v))
scheme_wrong_type("hash-remove", "immutable hash", 0, argc, argv);
return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)argv[0], argv[1], NULL);
return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)v, argv[1], NULL);
}
static Scheme_Object *do_map_hash_table(int argc,
@ -1978,9 +2183,16 @@ static Scheme_Object *do_map_hash_table(int argc,
{
int i;
Scheme_Object *f;
Scheme_Object *first, *last = NULL, *v, *p[2];
Scheme_Object *first, *last = NULL, *v, *p[2], *obj, *chaperone;
if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0]) || SCHEME_HASHTRP(argv[0])))
obj = argv[0];
if (SCHEME_NP_CHAPERONEP(obj)) {
chaperone = obj;
obj = SCHEME_CHAPERONE_VAL(chaperone);
} else
chaperone = NULL;
if (!(SCHEME_HASHTP(obj) || SCHEME_BUCKTP(obj) || SCHEME_HASHTRP(obj)))
scheme_wrong_type(name, "hash", 0, argc, argv);
scheme_check_proc_arity(name, 2, 1, argc, argv);
@ -1991,11 +2203,11 @@ static Scheme_Object *do_map_hash_table(int argc,
else
first = scheme_void;
if (SCHEME_BUCKTP(argv[0])) {
if (SCHEME_BUCKTP(obj)) {
Scheme_Bucket_Table *hash;
Scheme_Bucket *bucket;
hash = (Scheme_Bucket_Table *)argv[0];
hash = (Scheme_Bucket_Table *)obj;
for (i = hash->size; i--; ) {
bucket = hash->buckets[i];
@ -2004,7 +2216,13 @@ static Scheme_Object *do_map_hash_table(int argc,
p[0] = (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key);
else
p[0] = (Scheme_Object *)bucket->key;
p[1] = (Scheme_Object *)bucket->val;
if (chaperone) {
v = chaperone_hash_key(name, chaperone, p[0]);
p[0] = v;
v = scheme_chaperone_hash_get(chaperone, v);
} else
v = (Scheme_Object *)bucket->val;
p[1] = v;
if (keep) {
v = _scheme_apply(f, 2, p);
v = cons(v, scheme_null);
@ -2017,15 +2235,22 @@ static Scheme_Object *do_map_hash_table(int argc,
_scheme_apply_multi(f, 2, p);
}
}
} else if (SCHEME_HASHTP(argv[0])) {
} else if (SCHEME_HASHTP(obj)) {
Scheme_Hash_Table *hash;
hash = (Scheme_Hash_Table *)argv[0];
hash = (Scheme_Hash_Table *)obj;
for (i = hash->size; i--; ) {
if (hash->vals[i]) {
p[0] = hash->keys[i];
p[1] = hash->vals[i];
if (chaperone) {
v = chaperone_hash_key(name, chaperone, p[0]);
p[0] = v;
v = scheme_chaperone_hash_get(chaperone, v);
} else {
v = hash->vals[i];
}
p[1] = v;
if (keep) {
v = _scheme_apply(f, 2, p);
v = cons(v, scheme_null);
@ -2043,12 +2268,16 @@ static Scheme_Object *do_map_hash_table(int argc,
Scheme_Hash_Tree *hash;
long pos;
hash = (Scheme_Hash_Tree *)argv[0];
hash = (Scheme_Hash_Tree *)obj;
pos = scheme_hash_tree_next(hash, -1);
while (pos != -1) {
scheme_hash_tree_index(hash, pos, &ik, &iv);
p[0] = ik;
if (chaperone) {
ik = chaperone_hash_key(name, chaperone, ik);
iv = scheme_chaperone_hash_get(chaperone, ik);
}
p[1] = iv;
if (keep) {
v = _scheme_apply(f, 2, p);
@ -2174,9 +2403,16 @@ static Scheme_Object *hash_table_iterate_next(int argc, Scheme_Object *argv[])
static Scheme_Object *hash_table_index(const char *name, int argc, Scheme_Object *argv[], int get_val)
{
Scheme_Object *p = argv[1];
Scheme_Object *p = argv[1], *obj, *chaperone;
int pos, sz;
obj = argv[0];
if (SCHEME_NP_CHAPERONEP(obj)) {
chaperone = obj;
obj = SCHEME_CHAPERONE_VAL(chaperone);
} else
chaperone = NULL;
if (SCHEME_INTP(p)) {
pos = SCHEME_INT_VAL(p);
if (pos < 0)
@ -2185,42 +2421,61 @@ static Scheme_Object *hash_table_index(const char *name, int argc, Scheme_Object
pos = 0x7FFFFFFF;
}
if (SCHEME_HASHTP(argv[0])) {
if (SCHEME_HASHTP(obj)) {
Scheme_Hash_Table *hash;
hash = (Scheme_Hash_Table *)argv[0];
hash = (Scheme_Hash_Table *)obj;
sz = hash->size;
if (pos < sz) {
if (hash->vals[pos]) {
if (get_val)
if (chaperone) {
if (get_val)
return scheme_chaperone_hash_get(chaperone, chaperone_hash_key(name, chaperone, hash->keys[pos]));
else
return chaperone_hash_key(name, chaperone, hash->keys[pos]);
} else if (get_val)
return hash->vals[pos];
else
return hash->keys[pos];
}
}
} else if (SCHEME_HASHTRP(argv[0])) {
} else if (SCHEME_HASHTRP(obj)) {
Scheme_Object *v, *k;
if (scheme_hash_tree_index((Scheme_Hash_Tree *)argv[0], pos, &k, &v))
return (get_val ? v : k);
} else if (SCHEME_BUCKTP(argv[0])) {
if (scheme_hash_tree_index((Scheme_Hash_Tree *)obj, pos, &k, &v)) {
if (chaperone) {
if (get_val)
return scheme_chaperone_hash_get(chaperone, chaperone_hash_key(name, chaperone, k));
else
return chaperone_hash_key(name, chaperone, k);
} else
return (get_val ? v : k);
}
} else if (SCHEME_BUCKTP(obj)) {
Scheme_Bucket_Table *hash;
int sz;
Scheme_Bucket *bucket;
hash = (Scheme_Bucket_Table *)argv[0];
hash = (Scheme_Bucket_Table *)obj;
sz = hash->size;
if (pos < sz) {
bucket = hash->buckets[pos];
if (bucket && bucket->val && bucket->key) {
if (get_val)
if (get_val && !chaperone)
return (Scheme_Object *)bucket->val;
else {
if (hash->weak)
return (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key);
obj = (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key);
else
return (Scheme_Object *)bucket->key;
obj = (Scheme_Object *)bucket->key;
if (chaperone) {
if (get_val)
return scheme_chaperone_hash_get(chaperone, chaperone_hash_key(name, chaperone, obj));
else
return chaperone_hash_key(name, chaperone, obj);
} else
return obj;
}
}
}
@ -2251,6 +2506,313 @@ 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)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Hash_Tree *props;
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", 3, 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 */
redirects = scheme_make_vector(4, NULL);
SCHEME_VEC_ELS(redirects)[0] = argv[1];
SCHEME_VEC_ELS(redirects)[1] = argv[2];
SCHEME_VEC_ELS(redirects)[2] = argv[3];
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);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
px->redirects = redirects;
return (Scheme_Object *)px;
}
static Scheme_Object *transfer_chaperone(Scheme_Object *chaperone, Scheme_Object *v)
{
Scheme_Chaperone *px;
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
memcpy(px, chaperone, sizeof(Scheme_Chaperone));
px->prev = v;
if (SCHEME_CHAPERONEP(v))
px->val = SCHEME_CHAPERONE_VAL(v);
else
px->val = v;
return (Scheme_Object *)px;
}
static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k,
Scheme_Object *v, int mode);
static Scheme_Object *chaperone_hash_op_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
Scheme_Object *k = (Scheme_Object *)p->ku.k.p2;
Scheme_Object *v = (Scheme_Object *)p->ku.k.p3;
const char *who = (const char *)p->ku.k.p4;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
p->ku.k.p4 = NULL;
return chaperone_hash_op(who, o, k, v, p->ku.k.i1);
}
static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object *o, Scheme_Object *k,
Scheme_Object *v, int mode)
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)o;
p->ku.k.p2 = (void *)k;
p->ku.k.p3 = (void *)v;
p->ku.k.p4 = (void *)who;
p->ku.k.i1 = mode;
return scheme_handle_stack_overflow(chaperone_hash_op_k);
}
static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k,
Scheme_Object *v, int mode)
{
Scheme_Object *wraps = NULL;
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
if (mode == 0) {
if (SCHEME_HASHTP(o))
return scheme_hash_get((Scheme_Hash_Table *)o, k);
else if (SCHEME_HASHTRP(o))
return scheme_hash_tree_get((Scheme_Hash_Tree *)o, k);
else
return scheme_lookup_in_table((Scheme_Bucket_Table *)o, (const char *)k);
} else if ((mode == 1) || (mode == 2)) {
if (SCHEME_HASHTP(o))
scheme_hash_set((Scheme_Hash_Table *)o, k, v);
else if (SCHEME_HASHTRP(o)) {
o = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)o, k, v);
while (wraps) {
o = transfer_chaperone(SCHEME_CAR(wraps), o);
wraps = SCHEME_CDR(wraps);
}
return o;
} else if (!v) {
Scheme_Bucket *b;
b = scheme_bucket_or_null_from_table((Scheme_Bucket_Table *)o, (char *)k, 0);
if (b) {
HT_EXTRACT_WEAK(b->key) = NULL;
b->val = NULL;
}
} else
scheme_add_to_table((Scheme_Bucket_Table *)o, (const char *)k, v, 0);
return scheme_void;
} else
return k;
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red, *orig;
const char *what;
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
return chaperone_hash_op_overflow(who, o, k, v, mode);
}
#endif
if (mode == 0) {
orig = chaperone_hash_op(who, px->prev, k, v, mode);
if (!orig) return NULL;
} else if ((mode == 2) || (mode == 3))
orig = k;
else
orig = v;
if (SCHEME_VECTORP(px->redirects)) {
/* chaperone was on property accessors */
o = orig;
} else {
red = SCHEME_BOX_VAL(px->redirects);
red = SCHEME_VEC_ELS(red)[mode];
a[0] = px->prev;
a[1] = k;
a[2] = orig;
if (mode == 0) {
/* hash-ref */
o = _scheme_apply(red, 3, a);
what = "result";
} else if (mode == 1) {
/* hash-set! */
Scheme_Object **vals;
int cnt;
Scheme_Thread *p;
o = _scheme_apply_multi(red, 3, a);
if (SAME_OBJ(o, SCHEME_MULTIPLE_VALUES)) {
p = scheme_current_thread;
cnt = p->ku.multiple.count;
vals = p->ku.multiple.array;
p->ku.multiple.array = NULL;
if (SAME_OBJ(vals, p->values_buffer))
p->values_buffer = NULL;
p = NULL;
} else {
vals = NULL;
cnt = 1;
}
if (cnt != 2)
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"%s: chaperone: %V: returned %d values, expected 2",
who,
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);
k = vals[0];
o = vals[1];
what = "value";
} else {
/* hash-remove! and key extraction */
o = _scheme_apply(red, 2, a);
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 ((mode == 0) || (mode == 3))
return o;
else {
if (mode == 1)
v = o;
else
k = o;
if (SCHEME_HASHTRP(px->val))
wraps = scheme_make_raw_pair((Scheme_Object *)px, wraps);
o = px->prev;
}
}
}
}
Scheme_Object *scheme_chaperone_hash_get(Scheme_Object *table, Scheme_Object *key)
{
return chaperone_hash_op("hash-ref", table, key, NULL, 0);
}
void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val)
{
(void)chaperone_hash_op(val ? "hash-set!" : "hash-remove!", table, key, val, val ? 1 : 2);
}
Scheme_Object *chaperone_hash_tree_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val)
{
return chaperone_hash_op(val ? "hash-set" : "hash-remove", table, key, val, val ? 1 : 2);
}
static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key)
{
return chaperone_hash_op(name, table, key, NULL, 3);
}
Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_Object *key)
{
key = chaperone_hash_key("hash-table-iterate-key", table, key);
return chaperone_hash_op("hash-ref", table, key, NULL, 0);
}
Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj)
{
Scheme_Object *a[3], *v, *v2, *idx, *key, *val;
int is_eq, is_eqv;
v = SCHEME_CHAPERONE_VAL(obj);
a[0] = obj;
is_eq = SCHEME_TRUEP(hash_eq_p(1, a));
is_eqv = SCHEME_TRUEP(hash_eqv_p(1, a));
if (SCHEME_HASHTP(obj)) {
if (is_eq)
v2 = make_hasheq(0, NULL);
else if (is_eqv)
v2 = make_hasheqv(0, NULL);
else
v2 = make_hash(0, NULL);
} else if (SCHEME_HASHTRP(obj)) {
if (is_eq)
v2 = make_immutable_hasheq(0, NULL);
else if (is_eqv)
v2 = make_immutable_hasheqv(0, NULL);
else
v2 = make_immutable_hash(0, NULL);
} else {
if (is_eq)
v2 = make_weak_hasheq(0, NULL);
else if (is_eqv)
v2 = make_weak_hasheqv(0, NULL);
else
v2 = make_weak_hash(0, NULL);
}
idx = hash_table_iterate_start(1, a);
while (SCHEME_TRUEP(idx)) {
a[0] = v;
a[1] = idx;
key = hash_table_iterate_key(2, a);
val = scheme_chaperone_hash_get(obj, key);
if (val) {
a[0] = v2;
a[1] = key;
a[2] = val;
if (SCHEME_HASHTRP(v2))
v2 = hash_table_put(2, a);
else
(void)hash_table_put_bang(2, a);
}
a[0] = v;
a[1] = idx;
idx = hash_table_iterate_next(2, a);
}
return v2;
}
static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[])
{
long v;

33
src/mzscheme/src/mzmark.c
View File

@ -4845,6 +4845,39 @@ static int mark_nack_guard_evt_FIXUP(void *p) {
#define mark_nack_guard_evt_IS_CONST_SIZE 1
static int mark_chaperone_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Chaperone));
}
static int mark_chaperone_MARK(void *p) {
Scheme_Chaperone *px = (Scheme_Chaperone *)p;
gcMARK(px->val);
gcMARK(px->prev);
gcMARK(px->props);
gcMARK(px->redirects);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Chaperone));
}
static int mark_chaperone_FIXUP(void *p) {
Scheme_Chaperone *px = (Scheme_Chaperone *)p;
gcFIXUP(px->val);
gcFIXUP(px->prev);
gcFIXUP(px->props);
gcFIXUP(px->redirects);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Chaperone));
}
#define mark_chaperone_IS_ATOMIC 0
#define mark_chaperone_IS_CONST_SIZE 1
#endif /* STRUCT */
/**********************************************************************/

13
src/mzscheme/src/mzmarksrc.c
View File

@ -1974,6 +1974,19 @@ mark_nack_guard_evt {
gcBYTES_TO_WORDS(sizeof(Nack_Guard_Evt));
}
mark_chaperone {
mark:
Scheme_Chaperone *px = (Scheme_Chaperone *)p;
gcMARK(px->val);
gcMARK(px->prev);
gcMARK(px->props);
gcMARK(px->redirects);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Chaperone));
}
END struct;
/**********************************************************************/

12
src/mzscheme/src/portfun.c
View File

@ -372,7 +372,7 @@ static MZ_INLINE Scheme_Input_Port *input_port_record_slow(Scheme_Object *port)
if (SCHEME_INPORTP(port))
return (Scheme_Input_Port *)port;
if (!SCHEME_STRUCTP(port)) {
if (!SCHEME_CHAPERONE_STRUCTP(port)) {
return (Scheme_Input_Port *)dummy_input_port;
}
@ -380,7 +380,7 @@ static MZ_INLINE Scheme_Input_Port *input_port_record_slow(Scheme_Object *port)
if (!v)
v = scheme_false;
else if (SCHEME_INTP(v))
v = ((Scheme_Structure *)port)->slots[SCHEME_INT_VAL(v)];
v = scheme_struct_ref(port, SCHEME_INT_VAL(v));
port = v;
SCHEME_USE_FUEL(1);
@ -404,7 +404,7 @@ static MZ_INLINE Scheme_Output_Port *output_port_record_slow(Scheme_Object *port
if (SCHEME_OUTPORTP(port))
return (Scheme_Output_Port *)port;
if (!SCHEME_STRUCTP(port)) {
if (!SCHEME_CHAPERONE_STRUCTP(port)) {
return (Scheme_Output_Port *)dummy_output_port;
}
@ -412,7 +412,7 @@ static MZ_INLINE Scheme_Output_Port *output_port_record_slow(Scheme_Object *port
if (!v)
v = scheme_false;
else if (SCHEME_INTP(v))
v = ((Scheme_Structure *)port)->slots[SCHEME_INT_VAL(v)];
v = scheme_struct_ref(port, SCHEME_INT_VAL(v));
port = v;
SCHEME_USE_FUEL(1);
@ -433,7 +433,7 @@ int scheme_is_input_port(Scheme_Object *port)
if (SCHEME_INPORTP(port))
return 1;
if (SCHEME_STRUCTP(port))
if (SCHEME_CHAPERONE_STRUCTP(port))
if (scheme_struct_type_property_ref(scheme_input_port_property, port))
return 1;
@ -445,7 +445,7 @@ int scheme_is_output_port(Scheme_Object *port)
if (SCHEME_OUTPORTP(port))
return 1;
if (SCHEME_STRUCTP(port))
if (SCHEME_CHAPERONE_STRUCTP(port))
if (scheme_struct_type_property_ref(scheme_output_port_property, port))
return 1;

238
src/mzscheme/src/print.c
View File

@ -122,18 +122,20 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin
#define SCHEME_PREFABP(obj) (((Scheme_Structure *)(obj))->stype->prefab_key)
#define SCHEME_HASHTPx(obj) ((SCHEME_HASHTP(obj) && !(MZ_OPT_HASH_KEY(&(((Scheme_Hash_Table *)obj)->iso)) & 0x1)))
#define SCHEME_CHAPERONE_HASHTPx(obj) (SCHEME_HASHTPx(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(obj))))
#define HAS_SUBSTRUCT(obj, qk) \
(SCHEME_PAIRP(obj) \
|| SCHEME_MUTABLE_PAIRP(obj) \
|| SCHEME_VECTORP(obj) \
|| (qk(pp->print_box, 1) && SCHEME_BOXP(obj)) \
|| SCHEME_CHAPERONE_VECTORP(obj) \
|| (qk(pp->print_box, 1) && SCHEME_CHAPERONE_BOXP(obj)) \
|| (qk(pp->print_struct \
&& SCHEME_STRUCTP(obj) \
&& SCHEME_CHAPERONE_STRUCTP(obj) \
&& PRINTABLE_STRUCT(obj, pp), 0)) \
|| (qk(SCHEME_STRUCTP(obj) && scheme_is_writable_struct(obj), 0)) \
|| (qk(pp->print_struct, 1) && SCHEME_STRUCTP(obj) && SCHEME_PREFABP(obj)) \
|| (qk(pp->print_hash_table, 1) && (SCHEME_HASHTPx(obj) || SCHEME_HASHTRP(obj))))
|| (qk(SCHEME_CHAPERONE_STRUCTP(obj) && scheme_is_writable_struct(obj), 0)) \
|| (qk(pp->print_struct, 1) && SCHEME_CHAPERONE_STRUCTP(obj) && SCHEME_PREFABP(obj)) \
|| (qk(pp->print_hash_table, 1) && (SCHEME_CHAPERONE_HASHTPx(obj) || SCHEME_CHAPERONE_HASHTRP(obj))))
#define ssQUICK(x, isbox) x
#define ssQUICKp(x, isbox) (pp ? x : isbox)
#define ssALLp(x, isbox) isbox
@ -443,8 +445,8 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht
if (SCHEME_PAIRP(obj)
|| SCHEME_MUTABLE_PAIRP(obj)
|| (pp->print_box && SCHEME_BOXP(obj))
|| SCHEME_VECTORP(obj)
|| (pp->print_box && SCHEME_CHAPERONE_BOXP(obj))
|| SCHEME_CHAPERONE_VECTORP(obj)
|| ((SAME_TYPE(t, scheme_structure_type)
|| SAME_TYPE(t, scheme_proc_struct_type))
&& ((pp->print_struct
@ -464,16 +466,29 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht
return 1;
if (check_cycles(SCHEME_CDR(obj), for_write, ht, pp))
return 1;
} else if (SCHEME_BOXP(obj)) {
} else if (SCHEME_CHAPERONE_BOXP(obj)) {
/* got here => printable */
if (check_cycles(SCHEME_BOX_VAL(obj), for_write, ht, pp))
Scheme_Object *v;
if (SCHEME_BOXP(obj))
v = SCHEME_BOX_VAL(obj);
else
v = scheme_unbox(obj);
if (check_cycles(v, for_write, ht, pp))
return 1;
} else if (SCHEME_VECTORP(obj)) {
} else if (SCHEME_CHAPERONE_VECTORP(obj)) {
int i, len;
Scheme_Object *v;
len = SCHEME_VEC_SIZE(obj);
if (SCHEME_VECTORP(obj))
len = SCHEME_VEC_SIZE(obj);
else
len = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(obj));
for (i = 0; i < len; i++) {
if (check_cycles(SCHEME_VEC_ELS(obj)[i], for_write, ht, pp)) {
if (SCHEME_VECTORP(obj))
v = SCHEME_VEC_ELS(obj)[i];
else
v = scheme_chaperone_vector_ref(obj, i);
if (check_cycles(v, for_write, ht, pp)) {
return 1;
}
}
@ -494,33 +509,50 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht
}
}
}
} else if (SCHEME_HASHTPx(obj)) {
} else if (SCHEME_CHAPERONE_HASHTPx(obj)) {
/* got here => printable */
Scheme_Hash_Table *t;
Scheme_Object **keys, **vals, *val;
Scheme_Object **keys, **vals, *val, *key;
int i;
t = (Scheme_Hash_Table *)obj;
if (SCHEME_NP_CHAPERONEP(obj))
t = (Scheme_Hash_Table *)SCHEME_CHAPERONE_VAL(obj);
else
t = (Scheme_Hash_Table *)obj;
keys = t->keys;
vals = t->vals;
for (i = t->size; i--; ) {
for (i = 0; i < t->size; i++) {
if (vals[i]) {
val = vals[i];
if (check_cycles(keys[i], for_write, ht, pp))
return 1;
if (check_cycles(val, for_write, ht, pp))
return 1;
key = keys[i];
if (!SAME_OBJ((Scheme_Object *)t, obj))
val = scheme_chaperone_hash_traversal_get(obj, key);
else
val = vals[i];
if (val) {
if (check_cycles(key, for_write, ht, pp))
return 1;
if (check_cycles(val, for_write, ht, pp))
return 1;
}
}
}
} else if (SCHEME_HASHTRP(obj)) {
} else if (SCHEME_CHAPERONE_HASHTRP(obj)) {
/* got here => printable */
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)obj;
Scheme_Hash_Tree *t;
Scheme_Object *key, *val;
int i;
if (SCHEME_NP_CHAPERONEP(obj))
t = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(obj);
else
t = (Scheme_Hash_Tree *)obj;
i = scheme_hash_tree_next(t, -1);
while (i != -1) {
scheme_hash_tree_index(t, i, &key, &val);
if (!SAME_OBJ((Scheme_Object *)t, obj))
val = scheme_chaperone_hash_traversal_get(obj, key);
if (check_cycles(key, for_write, ht, pp))
return 1;
if (check_cycles(val, for_write, ht, pp))
@ -610,7 +642,9 @@ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_chec
else
/* don't bother with fast checks for non-empty hash trees */
cycle = -1;
} else
} else if (SCHEME_CHAPERONEP(obj))
cycle = -1; /* no fast checks for chaperones */
else
cycle = 0;
return cycle;
@ -682,16 +716,29 @@ static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Tab
if (SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) {
setup_graph_table(SCHEME_CAR(obj), for_write, ht, counter, pp);
setup_graph_table(SCHEME_CDR(obj), for_write, ht, counter, pp);
} else if ((!pp || pp->print_box) && SCHEME_BOXP(obj)) {
setup_graph_table(SCHEME_BOX_VAL(obj), for_write, ht, counter, pp);
} else if (SCHEME_VECTORP(obj)) {
} else if ((!pp || pp->print_box) && SCHEME_CHAPERONE_BOXP(obj)) {
Scheme_Object *v;
if (SCHEME_BOXP(obj))
v = SCHEME_BOX_VAL(obj);
else
v = scheme_unbox(obj);
setup_graph_table(v, for_write, ht, counter, pp);
} else if (SCHEME_CHAPERONE_VECTORP(obj)) {
int i, len;
Scheme_Object *v;
len = SCHEME_VEC_SIZE(obj);
if (SCHEME_VECTORP(obj))
len = SCHEME_VEC_SIZE(obj);
else
len = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(obj));
for (i = 0; i < len; i++) {
setup_graph_table(SCHEME_VEC_ELS(obj)[i], for_write, ht, counter, pp);
if (SCHEME_VECTORP(obj))
v = SCHEME_VEC_ELS(obj)[i];
else
v = scheme_chaperone_vector_ref(obj, i);
setup_graph_table(v, for_write, ht, counter, pp);
}
} else if (pp && SCHEME_STRUCTP(obj)) { /* got here => printable */
} else if (pp && SCHEME_CHAPERONE_STRUCTP(obj)) { /* got here => printable */
if (scheme_is_writable_struct(obj)) {
if (pp->print_unreadable) {
obj = writable_struct_subs(obj, for_write, pp);
@ -702,33 +749,50 @@ static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Tab
while (i--) {
if (scheme_inspector_sees_part(obj, pp->inspector, i))
setup_graph_table(((Scheme_Structure *)obj)->slots[i], for_write, ht, counter, pp);
setup_graph_table(scheme_struct_ref(obj, i), for_write, ht, counter, pp);
}
}
} else if (pp && SCHEME_HASHTPx(obj)) { /* got here => printable */
} else if (pp && SCHEME_CHAPERONE_HASHTPx(obj)) { /* got here => printable */
Scheme_Hash_Table *t;
Scheme_Object **keys, **vals, *val;
Scheme_Object **keys, **vals, *val, *key;
int i;
t = (Scheme_Hash_Table *)obj;
if (SCHEME_NP_CHAPERONEP(obj))
t = (Scheme_Hash_Table *)SCHEME_CHAPERONE_VAL(obj);
else
t = (Scheme_Hash_Table *)obj;
keys = t->keys;
vals = t->vals;
for (i = t->size; i--; ) {
for (i = 0; i < t->size; i++) {
if (vals[i]) {
val = vals[i];
setup_graph_table(keys[i], for_write, ht, counter, pp);
setup_graph_table(val, for_write, ht, counter, pp);
key = keys[i];
if (!SAME_OBJ((Scheme_Object *)t, obj))
val = scheme_chaperone_hash_traversal_get(obj, key);
else
val = vals[i];
if (val) {
setup_graph_table(key, for_write, ht, counter, pp);
setup_graph_table(val, for_write, ht, counter, pp);
}
}
}
} else if (SCHEME_HASHTRP(obj)) {
} else if (SCHEME_CHAPERONE_HASHTRP(obj)) {
/* got here => printable */
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)obj;
Scheme_Hash_Tree *t;
Scheme_Object *key, *val;
int i;
if (SCHEME_NP_CHAPERONEP(obj))
t = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(obj);
else
t = (Scheme_Hash_Tree *)obj;
i = scheme_hash_tree_next(t, -1);
while (i != -1) {
scheme_hash_tree_index(t, i, &key, &val);
if (!SAME_OBJ((Scheme_Object *)t, obj))
val = scheme_chaperone_hash_traversal_get(obj, key);
setup_graph_table(key, for_write, ht, counter, pp);
setup_graph_table(val, for_write, ht, counter, pp);
i = scheme_hash_tree_next(t, i);
@ -1600,6 +1664,12 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
}
}
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_chaperone_type)) {
if (!SCHEME_STRUCTP(SCHEME_CHAPERONE_VAL(obj)))
/* unwrap non-struct procedure to print it: */
obj = SCHEME_CHAPERONE_VAL(obj);
}
if (SCHEME_SYMBOLP(obj)
|| SCHEME_KEYWORDP(obj))
{
@ -1815,33 +1885,42 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_mutable_pair_type, !pp->print_mpair_curly);
closed = 1;
}
else if (SCHEME_VECTORP(obj))
else if (SCHEME_CHAPERONE_VECTORP(obj))
{
print_vector(obj, notdisplay, compact, ht, mt, pp, 0);
closed = 1;
}
else if ((compact || pp->print_box) && SCHEME_BOXP(obj))
else if ((compact || pp->print_box) && SCHEME_CHAPERONE_BOXP(obj))
{
if (compact && !pp->print_box) {
closed = print(scheme_protect_quote(obj), notdisplay, compact, ht, mt, pp);
} else {
Scheme_Object *content;
if (compact)
print_compact(pp, CPT_BOX);
else {
always_scheme(pp, 1);
print_utf8_string(pp, "#&", 0, 2);
}
closed = print(SCHEME_BOX_VAL(obj), notdisplay, compact, ht, mt, pp);
if (SCHEME_BOXP(obj))
content = SCHEME_BOX_VAL(obj);
else
content = scheme_unbox(obj);
closed = print(content, notdisplay, compact, ht, mt, pp);
}
}
else if ((compact || pp->print_hash_table)
&& (SCHEME_HASHTPx(obj) || SCHEME_HASHTRP(obj)))
&& (SCHEME_CHAPERONE_HASHTPx(obj) || SCHEME_CHAPERONE_HASHTRP(obj)))
{
Scheme_Hash_Table *t;
Scheme_Hash_Tree *tr;
Scheme_Object **keys, **vals, *val, *key;
Scheme_Object **keys, **vals, *val, *key, *orig;
int i, size, did_one = 0;
orig = obj;
if (SCHEME_NP_CHAPERONEP(obj))
obj = SCHEME_CHAPERONE_VAL(obj);
if (compact) {
print_compact(pp, CPT_HASH_TABLE);
if ((SCHEME_HASHTP(obj) && scheme_is_hash_table_equal(obj))
@ -1897,23 +1976,32 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (!vals || vals[i]) {
if (!vals) {
scheme_hash_tree_index(tr, i, &key, &val);
if (!SAME_OBJ(obj, orig))
val = scheme_chaperone_hash_traversal_get(orig, key);
} else {
val = vals[i];
key = keys[i];
if (i < t->size) {
val = vals[i];
key = keys[i];
if (!SAME_OBJ(obj, orig))
val = scheme_chaperone_hash_traversal_get(orig, key);
} else
val = 0;
}
if (!compact) {
if (did_one)
print_utf8_string(pp, " ", 0, 1);
print_utf8_string(pp, "(", 0, 1);
}
print(key, notdisplay, compact, ht, mt, pp);
if (!compact)
print_utf8_string(pp, " . ", 0, 3);
print(val, notdisplay, compact, ht, mt, pp);
if (!compact)
print_utf8_string(pp, ")", 0, 1);
did_one++;
if (val) {
if (!compact) {
if (did_one)
print_utf8_string(pp, " ", 0, 1);
print_utf8_string(pp, "(", 0, 1);
}
print(key, notdisplay, compact, ht, mt, pp);
if (!compact)
print_utf8_string(pp, " . ", 0, 3);
print(val, notdisplay, compact, ht, mt, pp);
if (!compact)
print_utf8_string(pp, ")", 0, 1);
did_one++;
}
}
}
@ -1950,9 +2038,10 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
{
print_compact(pp, CPT_VOID);
}
else if (SCHEME_STRUCTP(obj))
else if (SCHEME_CHAPERONE_STRUCTP(obj))
{
if (compact && SCHEME_PREFABP(obj)) {
if (compact && (SCHEME_PREFABP(obj) || (SCHEME_CHAPERONEP(obj)
&& SCHEME_PREFABP(SCHEME_CHAPERONE_VAL(obj))))) {
Scheme_Object *vec, *prefab;
print_compact(pp, CPT_PREFAB);
prefab = ((Scheme_Structure *)obj)->stype->prefab_key;
@ -1980,6 +2069,9 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
} else {
Scheme_Object *src;
if (SCHEME_CHAPERONEP(obj))
obj = SCHEME_CHAPERONE_VAL(obj);
if (SCHEME_PROC_STRUCTP(obj)) {
/* Name by procedure? */
src = scheme_proc_struct_name_source(obj);
@ -3124,15 +3216,21 @@ print_vector(Scheme_Object *vec, int notdisplay, int compact,
int as_prefab)
{
int i, size, common = 0;
Scheme_Object **elems;
Scheme_Object **elems, *elem;
size = SCHEME_VEC_SIZE(vec);
if (SCHEME_VECTORP(vec))
size = SCHEME_VEC_SIZE(vec);
else
size = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec));
if (compact) {
print_compact(pp, CPT_VECTOR);
print_compact_number(pp, size);
} else {
elems = SCHEME_VEC_ELS(vec);
if (SCHEME_VECTORP(vec))
elems = SCHEME_VEC_ELS(vec);
else
elems = SCHEME_VEC_ELS(SCHEME_CHAPERONE_VAL(vec));
for (i = size; i--; common++) {
if (!i || (elems[i] != elems[i - 1]))
break;
@ -3160,7 +3258,11 @@ print_vector(Scheme_Object *vec, int notdisplay, int compact,
}
for (i = 0; i < size; i++) {
print(SCHEME_VEC_ELS(vec)[i], notdisplay, compact, ht, mt, pp);
if (SCHEME_VECTORP(vec))
elem = SCHEME_VEC_ELS(vec)[i];
else
elem = scheme_chaperone_vector_ref(vec, i);
print(elem, notdisplay, compact, ht, mt, pp);
if (i < (size - 1)) {
if (!compact) {
if (pp->honu_mode)

27
src/mzscheme/src/read.c
View File

@ -2113,10 +2113,14 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
result = obj;
scheme_hash_set(dht, obj, result);
}
} else if (SCHEME_VECTORP(obj)) {
} else if (SCHEME_VECTORP(obj)
|| (clone && SCHEME_CHAPERONE_VECTORP(obj))) {
int i, len, diff = 0;
Scheme_Object *prev_rr, *prev_v;
if (SCHEME_NP_CHAPERONEP(obj))
obj = scheme_chaperone_vector_copy(obj);
len = SCHEME_VEC_SIZE(obj);
if (clone) {
@ -2146,11 +2150,17 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
scheme_hash_set(dht, obj, result);
}
} else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_table_placeholder_type)
|| SCHEME_HASHTRP(obj)) {
|| SCHEME_HASHTRP(obj)
|| (clone && SCHEME_NP_CHAPERONEP(obj)
&& (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(obj))
|| SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj))))) {
Scheme_Hash_Tree *t, *base;
Scheme_Object *a, *key, *val, *lst;
int kind;
if (SCHEME_NP_CHAPERONEP(obj))
obj = scheme_chaperone_hash_table_copy(obj);
if (SCHEME_HASHTRP(obj)) {
int i;
if (scheme_is_hash_tree_equal(obj))
@ -2224,22 +2234,27 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
scheme_hash_set(t2, key, val);
}
}
} else if (SCHEME_STRUCTP(obj)) {
Scheme_Structure *s = (Scheme_Structure *)obj;
} else if (SCHEME_STRUCTP(obj)
|| (clone && SCHEME_CHAPERONE_STRUCTP(obj))) {
Scheme_Structure *s;
if (clone && SCHEME_CHAPERONEP(obj))
s = (Scheme_Structure *)SCHEME_CHAPERONE_VAL(obj);
else
s = (Scheme_Structure *)obj;
if (s->stype->prefab_key) {
/* prefab */
int c, i, diff;
Scheme_Object *prev_v, *v;
if (clone) {
result = scheme_clone_prefab_struct_instance(s);
result = scheme_clone_prefab_struct_instance((Scheme_Structure *)obj);
}
scheme_hash_set(dht, obj, result);
c = s->stype->num_slots;
diff = 0;
for (i = 0; i < c; i++) {
prev_v = s->slots[i];
prev_v = ((Scheme_Structure *)result)->slots[i];
v = resolve_references(prev_v, port, top, dht, tht, clone, tail_depth + 1);
if (!SAME_OBJ(prev_v, v))
diff = 1;

2
src/mzscheme/src/regexp.c
View File

@ -2287,7 +2287,7 @@ static int check_and_propagate_depends(void)
}
if (SCHEME_HASHTP(v)) {
/* Check/propagate assumption. The fixpoint direction is
determined by assuming "true" whil erecursively checking. */
determined by assuming "true" while recursively checking. */
scheme_hash_set(regbackknown, backdepends->keys[i], scheme_true);
if (!next_ht)
next_ht = scheme_make_hash_table(SCHEME_hash_ptr);

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

@ -1002,6 +1002,7 @@ MZ_EXTERN void scheme_struct_set(Scheme_Object *s, int pos, Scheme_Object *v);
MZ_EXTERN Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name);
MZ_EXTERN Scheme_Object *scheme_make_struct_type_property_w_guard(Scheme_Object *name, Scheme_Object *guard);
XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s);
MZ_EXTERN Scheme_Object *scheme_chaperone_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s);
MZ_EXTERN Scheme_Object *scheme_make_location(Scheme_Object *src,
Scheme_Object *line,
@ -1020,6 +1021,7 @@ XFORM_NONGCING MZ_EXTERN int scheme_is_subinspector(Scheme_Object *i, Scheme_Obj
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);
#ifdef MZ_PRECISE_GC
XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o);

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

@ -833,6 +833,7 @@ void (*scheme_struct_set)(Scheme_Object *s, int pos, Scheme_Object *v);
Scheme_Object *(*scheme_make_struct_type_property)(Scheme_Object *name);
Scheme_Object *(*scheme_make_struct_type_property_w_guard)(Scheme_Object *name, Scheme_Object *guard);
Scheme_Object *(*scheme_struct_type_property_ref)(Scheme_Object *prop, Scheme_Object *s);
Scheme_Object *(*scheme_chaperone_struct_type_property_ref)(Scheme_Object *prop, Scheme_Object *s);
Scheme_Object *(*scheme_make_location)(Scheme_Object *src,
Scheme_Object *line,
Scheme_Object *col,
@ -847,6 +848,7 @@ int (*scheme_is_subinspector)(Scheme_Object *i, Scheme_Object *sup);
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);
#ifdef MZ_PRECISE_GC
long (*scheme_hash_key)(Scheme_Object *o);
#endif

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

@ -581,6 +581,7 @@
scheme_extension_table->scheme_make_struct_type_property = scheme_make_struct_type_property;
scheme_extension_table->scheme_make_struct_type_property_w_guard = scheme_make_struct_type_property_w_guard;
scheme_extension_table->scheme_struct_type_property_ref = scheme_struct_type_property_ref;
scheme_extension_table->scheme_chaperone_struct_type_property_ref = scheme_chaperone_struct_type_property_ref;
scheme_extension_table->scheme_make_location = scheme_make_location;
scheme_extension_table->scheme_is_location = scheme_is_location;
scheme_extension_table->scheme_make_inspector = scheme_make_inspector;
@ -588,6 +589,7 @@
scheme_extension_table->scheme_eq = scheme_eq;
scheme_extension_table->scheme_eqv = scheme_eqv;
scheme_extension_table->scheme_equal = scheme_equal;
scheme_extension_table->scheme_chaperone_of = scheme_chaperone_of;
#ifdef MZ_PRECISE_GC
scheme_extension_table->scheme_hash_key = scheme_hash_key;
#endif

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

@ -581,6 +581,7 @@
#define scheme_make_struct_type_property (scheme_extension_table->scheme_make_struct_type_property)
#define scheme_make_struct_type_property_w_guard (scheme_extension_table->scheme_make_struct_type_property_w_guard)
#define scheme_struct_type_property_ref (scheme_extension_table->scheme_struct_type_property_ref)
#define scheme_chaperone_struct_type_property_ref (scheme_extension_table->scheme_chaperone_struct_type_property_ref)
#define scheme_make_location (scheme_extension_table->scheme_make_location)
#define scheme_is_location (scheme_extension_table->scheme_is_location)
#define scheme_make_inspector (scheme_extension_table->scheme_make_inspector)
@ -588,6 +589,7 @@
#define scheme_eq (scheme_extension_table->scheme_eq)
#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)
#ifdef MZ_PRECISE_GC
#define scheme_hash_key (scheme_extension_table->scheme_hash_key)
#endif

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

@ -13,8 +13,8 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 966
#define EXPECTED_UNSAFE_COUNT 58
#define EXPECTED_PRIM_COUNT 978
#define EXPECTED_UNSAFE_COUNT 65
#define EXPECTED_FLFXNUM_COUNT 53
#ifdef MZSCHEME_SOMETHING_OMITTED

46
src/mzscheme/src/schpriv.h
View File

@ -329,6 +329,8 @@ extern Scheme_Object *scheme_list_proc;
extern Scheme_Object *scheme_list_star_proc;
extern Scheme_Object *scheme_vector_proc;
extern Scheme_Object *scheme_vector_immutable_proc;
extern Scheme_Object *scheme_vector_ref_proc;
extern Scheme_Object *scheme_vector_set_proc;
extern Scheme_Object *scheme_box_proc;
extern Scheme_Object *scheme_call_with_values_proc;
extern Scheme_Object *scheme_make_struct_type_proc;
@ -733,6 +735,47 @@ 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_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_VAL(obj) (((Scheme_Chaperone *)obj)->val)
#define SCHEME_P_CHAPERONEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_chaperone_type))
#define SCHEME_NP_CHAPERONEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_chaperone_type))
#define SCHEME_CHAPERONE_VECTORP(obj) (SCHEME_VECTORP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_VECTORP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_BOXP(obj) (SCHEME_BOXP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_BOXP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_STRUCTP(obj) (SCHEME_STRUCTP(obj) \
|| (SCHEME_CHAPERONEP(obj) && SCHEME_STRUCTP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_PROC_STRUCTP(obj) (SCHEME_PROC_STRUCTP(obj) \
|| (SCHEME_P_CHAPERONEP(obj) && SCHEME_PROC_STRUCTP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_STRUCT_TYPEP(obj) (SCHEME_STRUCT_TYPEP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_STRUCT_TYPEP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_HASHTP(obj) (SCHEME_HASHTP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_HASHTRP(obj) (SCHEME_HASHTRP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_BUCKTP(obj) (SCHEME_BUCKTP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(obj))))
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i);
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v);
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv);
Scheme_Hash_Tree *scheme_parse_chaperone_props(const char *who, int start_at, int argc, Scheme_Object **argv);
Scheme_Object *scheme_chaperone_hash_get(Scheme_Object *table, Scheme_Object *key);
Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_Object *key);
void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val);
/*========================================================================*/
/* syntax objects */
/*========================================================================*/
@ -3313,6 +3356,9 @@ Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv);
Scheme_Object *scheme_flvector_length(Scheme_Object *v);
Scheme_Object *scheme_chaperone_vector_copy(Scheme_Object *obj);
Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj);
void scheme_bad_vec_index(char *name, Scheme_Object *i,
const char *what, Scheme_Object *vec,
long bottom, long len);

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.5.1"
#define MZSCHEME_VERSION "4.2.5.3"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 5
#define MZSCHEME_VERSION_W 1
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

8
src/mzscheme/src/string.c
View File

@ -938,7 +938,7 @@ void scheme_out_of_string_range(const char *name, const char *which,
scheme_make_provided_string(i, 2, NULL),
start, len,
is_byte ? "byte-" : "",
SCHEME_VECTORP(s) ? "vector" : "string",
SCHEME_CHAPERONE_VECTORP(s) ? "vector" : "string",
sstr, slen);
} else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
@ -946,7 +946,7 @@ void scheme_out_of_string_range(const char *name, const char *which,
name, which,
scheme_make_provided_string(i, 0, NULL),
is_byte ? "byte-" : "",
SCHEME_VECTORP(s) ? "vector" : "string");
SCHEME_CHAPERONE_VECTORP(s) ? "vector" : "string");
}
}
@ -981,7 +981,7 @@ void scheme_get_substring_indices(const char *name, Scheme_Object *str,
long len;
long start, finish;
if (SCHEME_VECTORP(str))
if (SCHEME_CHAPERONE_VECTORP(str))
len = SCHEME_VEC_SIZE(str);
else if (SCHEME_CHAR_STRINGP(str))
len = SCHEME_CHAR_STRTAG_VAL(str);
@ -2347,7 +2347,7 @@ int scheme_strncmp(const char *a, const char *b, int len)
static Scheme_Object *ok_cmdline(int argc, Scheme_Object **argv)
{
if (SCHEME_VECTORP(argv[0])) {
if (SCHEME_CHAPERONE_VECTORP(argv[0])) {
Scheme_Object *vec = argv[0], *vec2, *str;
int i, size = SCHEME_VEC_SIZE(vec);

1060
src/mzscheme/src/struct.c
View File

File diff suppressed because it is too large Load Diff

67
src/mzscheme/src/stxobj.c
View File

@ -115,6 +115,7 @@ static void preemptive_chunk(Scheme_Stx *stx);
#define ICONS scheme_make_pair
#define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj))
#define HAS_CHAPERONE_SUBSTX(obj) (HAS_SUBSTX(obj) || (SCHEME_NP_CHAPERONEP(obj) && HAS_SUBSTX(SCHEME_CHAPERONE_VAL(obj))))
XFORM_NONGCING static int prefab_p(Scheme_Object *o)
{
@ -7887,7 +7888,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
SCHEME_USE_FUEL(1);
if (ht) {
if (HAS_SUBSTX(o)) {
if (HAS_CHAPERONE_SUBSTX(o)) {
if (scheme_hash_get(ht, o)) {
/* Graphs disallowed */
return_NULL;
@ -7985,34 +7986,55 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
result = first;
}
} else if (SCHEME_BOXP(o)) {
o = datum_to_syntax_inner(SCHEME_PTR_VAL(o), ut, stx_src, stx_wraps, ht);
} else if (SCHEME_CHAPERONE_BOXP(o)) {
if (SCHEME_NP_CHAPERONEP(o))
o = scheme_unbox(o);
else
o = SCHEME_PTR_VAL(o);
o = datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht);
if (!o) return_NULL;
result = scheme_box(o);
SCHEME_SET_BOX_IMMUTABLE(result);
} else if (SCHEME_VECTORP(o)) {
int size = SCHEME_VEC_SIZE(o), i;
Scheme_Object *a;
} else if (SCHEME_CHAPERONE_VECTORP(o)) {
int size, i;
Scheme_Object *a, *oo;
oo = o;
if (SCHEME_NP_CHAPERONEP(o))
o = SCHEME_CHAPERONE_VAL(o);
size = SCHEME_VEC_SIZE(o);
result = scheme_make_vector(size, NULL);
for (i = 0; i < size; i++) {
a = datum_to_syntax_inner(SCHEME_VEC_ELS(o)[i], ut, stx_src, stx_wraps, ht);
if (SAME_OBJ(o, oo))
a = SCHEME_VEC_ELS(o)[i];
else
a = scheme_chaperone_vector_ref(oo, i);
a = datum_to_syntax_inner(a, ut, stx_src, stx_wraps, ht);
if (!a) return_NULL;
SCHEME_VEC_ELS(result)[i] = a;
}
SCHEME_SET_VECTOR_IMMUTABLE(result);
} else if (SCHEME_HASHTRP(o)) {
Scheme_Hash_Tree *ht1 = (Scheme_Hash_Tree *)o, *ht2;
} else if (SCHEME_CHAPERONE_HASHTRP(o)) {
Scheme_Hash_Tree *ht1, *ht2;
Scheme_Object *key, *val;
int i;
if (SCHEME_NP_CHAPERONEP(o))
ht1 = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(o);
else
ht1 = (Scheme_Hash_Tree *)o;
ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht1) & 0x3);
i = scheme_hash_tree_next(ht1, -1);
while (i != -1) {
scheme_hash_tree_index(ht1, i, &key, &val);
if (!SAME_OBJ((Scheme_Object *)ht1, o))
val = scheme_chaperone_hash_traversal_get(ht1, key);
val = datum_to_syntax_inner(val, ut, stx_src, stx_wraps, ht);
if (!val) return NULL;
ht2 = scheme_hash_tree_set(ht2, key, val);
@ -8020,12 +8042,14 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
}
result = (Scheme_Object *)ht2;
} else if (prefab_p(o)) {
Scheme_Structure *s = (Scheme_Structure *)o;
} else if (prefab_p(o) || (SCHEME_CHAPERONEP(o) && prefab_p(SCHEME_CHAPERONE_VAL(o)))) {
Scheme_Structure *s;
Scheme_Object *a;
int size = s->stype->num_slots, i;
s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s);
int size, i;
s = (Scheme_Structure *)scheme_clone_prefab_struct_instance((Scheme_Structure *)o);
size = s->stype->num_slots;
for (i = 0; i < size; i++) {
a = datum_to_syntax_inner(s->slots[i], ut, stx_src, stx_wraps, ht);
if (!a) return NULL;
@ -8106,7 +8130,7 @@ static Scheme_Object *general_datum_to_syntax(Scheme_Object *o,
if (SCHEME_STXP(o))
return o;
if (can_graph && HAS_SUBSTX(o))
if (can_graph && HAS_CHAPERONE_SUBSTX(o))
ht = scheme_make_hash_table(SCHEME_hash_ptr);
else
ht = NULL;
@ -8422,6 +8446,19 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
ll = scheme_proper_list_length(src);
if (SCHEME_CHAPERONEP(src)) {
src = SCHEME_CHAPERONE_VAL(src);
if (SCHEME_VECTORP(src) && (SCHEME_VEC_SIZE(src) == 5)) {
Scheme_Object *a;
int i;
src = scheme_make_vector(5, NULL);
for (i = 0; i < 5; i++) {
a = scheme_chaperone_vector_ref(argv[2], i);
SCHEME_VEC_ELS(src)[i] = a;
}
}
}
if (!SCHEME_FALSEP(src)
&& !SCHEME_STXP(src)
&& !(SCHEME_VECTORP(src)

398
src/mzscheme/src/stypes.h
View File

@ -46,210 +46,214 @@ enum {
scheme_escaping_cont_type, /* 32 */
scheme_proc_struct_type, /* 33 */
scheme_native_closure_type, /* 34 */
scheme_proc_chaperone_type, /* 35 */
/* structure types (overlaps with procs) */
scheme_structure_type, /* 35 */
scheme_chaperone_type, /* 36 */
/* structure type (plus one above for procs) */
scheme_structure_type, /* 37 */
/* basic types */
scheme_char_type, /* 36 */
scheme_integer_type, /* 37 */
scheme_bignum_type, /* 38 */
scheme_rational_type, /* 39 */
scheme_float_type, /* 40 */
scheme_double_type, /* 41 */
scheme_complex_type, /* 42 */
scheme_char_string_type, /* 43 */
scheme_byte_string_type, /* 44 */
scheme_unix_path_type, /* 45 */
scheme_windows_path_type, /* 46 */
scheme_symbol_type, /* 47 */
scheme_keyword_type, /* 48 */
scheme_null_type, /* 49 */
scheme_pair_type, /* 50 */
scheme_mutable_pair_type, /* 51 */
scheme_vector_type, /* 52 */
scheme_inspector_type, /* 53 */
scheme_input_port_type, /* 54 */
scheme_output_port_type, /* 55 */
scheme_eof_type, /* 56 */
scheme_true_type, /* 57 */
scheme_false_type, /* 58 */
scheme_void_type, /* 59 */
scheme_syntax_compiler_type, /* 60 */
scheme_macro_type, /* 61 */
scheme_box_type, /* 62 */
scheme_thread_type, /* 63 */
scheme_stx_offset_type, /* 64 */
scheme_cont_mark_set_type, /* 65 */
scheme_sema_type, /* 66 */
scheme_hash_table_type, /* 67 */
scheme_hash_tree_type, /* 68 */
scheme_cpointer_type, /* 69 */
scheme_offset_cpointer_type, /* 70 */
scheme_weak_box_type, /* 71 */
scheme_ephemeron_type, /* 72 */
scheme_struct_type_type, /* 73 */
scheme_module_index_type, /* 74 */
scheme_set_macro_type, /* 75 */
scheme_listener_type, /* 76 */
scheme_namespace_type, /* 77 */
scheme_config_type, /* 78 */
scheme_stx_type, /* 79 */
scheme_will_executor_type, /* 80 */
scheme_custodian_type, /* 81 */
scheme_random_state_type, /* 82 */
scheme_regexp_type, /* 83 */
scheme_bucket_type, /* 84 */
scheme_bucket_table_type, /* 85 */
scheme_subprocess_type, /* 86 */
scheme_compilation_top_type, /* 87 */
scheme_wrap_chunk_type, /* 88 */
scheme_eval_waiting_type, /* 89 */
scheme_tail_call_waiting_type, /* 90 */
scheme_undefined_type, /* 91 */
scheme_struct_property_type, /* 92 */
scheme_multiple_values_type, /* 93 */
scheme_placeholder_type, /* 94 */
scheme_table_placeholder_type, /* 95 */
scheme_case_lambda_sequence_type, /* 96 */
scheme_begin0_sequence_type, /* 97 */
scheme_rename_table_type, /* 98 */
scheme_rename_table_set_type, /* 99 */
scheme_module_type, /* 100 */
scheme_svector_type, /* 101 */
scheme_resolve_prefix_type, /* 102 */
scheme_security_guard_type, /* 103 */
scheme_indent_type, /* 104 */
scheme_udp_type, /* 105 */
scheme_udp_evt_type, /* 106 */
scheme_tcp_accept_evt_type, /* 107 */
scheme_id_macro_type, /* 108 */
scheme_evt_set_type, /* 109 */
scheme_wrap_evt_type, /* 110 */
scheme_handle_evt_type, /* 111 */
scheme_nack_guard_evt_type, /* 112 */
scheme_semaphore_repost_type, /* 113 */
scheme_channel_type, /* 114 */
scheme_channel_put_type, /* 115 */
scheme_thread_resume_type, /* 116 */
scheme_thread_suspend_type, /* 117 */
scheme_thread_dead_type, /* 118 */
scheme_poll_evt_type, /* 119 */
scheme_nack_evt_type, /* 120 */
scheme_module_registry_type, /* 121 */
scheme_thread_set_type, /* 122 */
scheme_string_converter_type, /* 123 */
scheme_alarm_type, /* 124 */
scheme_thread_recv_evt_type, /* 125 */
scheme_thread_cell_type, /* 126 */
scheme_channel_syncer_type, /* 127 */
scheme_special_comment_type, /* 128 */
scheme_write_evt_type, /* 129 */
scheme_always_evt_type, /* 130 */
scheme_never_evt_type, /* 131 */
scheme_progress_evt_type, /* 132 */
scheme_certifications_type, /* 133 */
scheme_already_comp_type, /* 134 */
scheme_readtable_type, /* 135 */
scheme_intdef_context_type, /* 136 */
scheme_lexical_rib_type, /* 137 */
scheme_thread_cell_values_type, /* 138 */
scheme_global_ref_type, /* 139 */
scheme_cont_mark_chain_type, /* 140 */
scheme_raw_pair_type, /* 141 */
scheme_prompt_type, /* 142 */
scheme_prompt_tag_type, /* 143 */
scheme_expanded_syntax_type, /* 144 */
scheme_delay_syntax_type, /* 145 */
scheme_cust_box_type, /* 146 */
scheme_resolved_module_path_type, /* 147 */
scheme_module_phase_exports_type, /* 148 */
scheme_logger_type, /* 149 */
scheme_log_reader_type, /* 150 */
scheme_free_id_info_type, /* 151 */
scheme_rib_delimiter_type, /* 152 */
scheme_noninline_proc_type, /* 153 */
scheme_prune_context_type, /* 154 */
scheme_future_type, /* 155 */
scheme_flvector_type, /* 156 */
scheme_place_type, /* 157 */
scheme_place_async_channel_type, /* 158 */
scheme_place_bi_channel_type, /* 159 */
scheme_once_used_type, /* 160 */
scheme_char_type, /* 38 */
scheme_integer_type, /* 39 */
scheme_bignum_type, /* 40 */
scheme_rational_type, /* 41 */
scheme_float_type, /* 42 */
scheme_double_type, /* 43 */
scheme_complex_type, /* 44 */
scheme_char_string_type, /* 45 */
scheme_byte_string_type, /* 46 */
scheme_unix_path_type, /* 47 */
scheme_windows_path_type, /* 48 */
scheme_symbol_type, /* 49 */
scheme_keyword_type, /* 50 */
scheme_null_type, /* 51 */
scheme_pair_type, /* 52 */
scheme_mutable_pair_type, /* 53 */
scheme_vector_type, /* 54 */
scheme_inspector_type, /* 55 */
scheme_input_port_type, /* 56 */
scheme_output_port_type, /* 57 */
scheme_eof_type, /* 58 */
scheme_true_type, /* 59 */
scheme_false_type, /* 60 */
scheme_void_type, /* 61 */
scheme_syntax_compiler_type, /* 62 */
scheme_macro_type, /* 63 */
scheme_box_type, /* 64 */
scheme_thread_type, /* 65 */
scheme_stx_offset_type, /* 66 */
scheme_cont_mark_set_type, /* 67 */
scheme_sema_type, /* 68 */
scheme_hash_table_type, /* 69 */
scheme_hash_tree_type, /* 70 */
scheme_cpointer_type, /* 71 */
scheme_offset_cpointer_type, /* 72 */
scheme_weak_box_type, /* 73 */
scheme_ephemeron_type, /* 74 */
scheme_struct_type_type, /* 75 */
scheme_module_index_type, /* 76 */
scheme_set_macro_type, /* 77 */
scheme_listener_type, /* 78 */
scheme_namespace_type, /* 79 */
scheme_config_type, /* 80 */
scheme_stx_type, /* 81 */
scheme_will_executor_type, /* 82 */
scheme_custodian_type, /* 83 */
scheme_random_state_type, /* 84 */
scheme_regexp_type, /* 85 */
scheme_bucket_type, /* 86 */
scheme_bucket_table_type, /* 87 */
scheme_subprocess_type, /* 88 */
scheme_compilation_top_type, /* 89 */
scheme_wrap_chunk_type, /* 90 */
scheme_eval_waiting_type, /* 91 */
scheme_tail_call_waiting_type, /* 92 */
scheme_undefined_type, /* 93 */
scheme_struct_property_type, /* 94 */
scheme_chaperone_property_type, /* 95 */
scheme_multiple_values_type, /* 96 */
scheme_placeholder_type, /* 97 */
scheme_table_placeholder_type, /* 98 */
scheme_case_lambda_sequence_type, /* 99 */
scheme_begin0_sequence_type, /* 100 */
scheme_rename_table_type, /* 101 */
scheme_rename_table_set_type, /* 102 */
scheme_module_type, /* 103 */
scheme_svector_type, /* 104 */
scheme_resolve_prefix_type, /* 105 */
scheme_security_guard_type, /* 106 */
scheme_indent_type, /* 107 */
scheme_udp_type, /* 108 */
scheme_udp_evt_type, /* 109 */
scheme_tcp_accept_evt_type, /* 110 */
scheme_id_macro_type, /* 111 */
scheme_evt_set_type, /* 112 */
scheme_wrap_evt_type, /* 113 */
scheme_handle_evt_type, /* 114 */
scheme_nack_guard_evt_type, /* 115 */
scheme_semaphore_repost_type, /* 116 */
scheme_channel_type, /* 117 */
scheme_channel_put_type, /* 118 */
scheme_thread_resume_type, /* 119 */
scheme_thread_suspend_type, /* 120 */
scheme_thread_dead_type, /* 121 */
scheme_poll_evt_type, /* 122 */
scheme_nack_evt_type, /* 123 */
scheme_module_registry_type, /* 124 */
scheme_thread_set_type, /* 125 */
scheme_string_converter_type, /* 126 */
scheme_alarm_type, /* 127 */
scheme_thread_recv_evt_type, /* 128 */
scheme_thread_cell_type, /* 129 */
scheme_channel_syncer_type, /* 130 */
scheme_special_comment_type, /* 131 */
scheme_write_evt_type, /* 132 */
scheme_always_evt_type, /* 133 */
scheme_never_evt_type, /* 134 */
scheme_progress_evt_type, /* 135 */
scheme_certifications_type, /* 136 */
scheme_already_comp_type, /* 137 */
scheme_readtable_type, /* 138 */
scheme_intdef_context_type, /* 139 */
scheme_lexical_rib_type, /* 140 */
scheme_thread_cell_values_type, /* 141 */
scheme_global_ref_type, /* 142 */
scheme_cont_mark_chain_type, /* 143 */
scheme_raw_pair_type, /* 144 */
scheme_prompt_type, /* 145 */
scheme_prompt_tag_type, /* 146 */
scheme_expanded_syntax_type, /* 147 */
scheme_delay_syntax_type, /* 148 */
scheme_cust_box_type, /* 149 */
scheme_resolved_module_path_type, /* 150 */
scheme_module_phase_exports_type, /* 151 */
scheme_logger_type, /* 152 */
scheme_log_reader_type, /* 153 */
scheme_free_id_info_type, /* 154 */
scheme_rib_delimiter_type, /* 155 */
scheme_noninline_proc_type, /* 156 */
scheme_prune_context_type, /* 157 */
scheme_future_type, /* 158 */
scheme_flvector_type, /* 159 */
scheme_place_type, /* 160 */
scheme_place_async_channel_type, /* 161 */
scheme_place_bi_channel_type, /* 162 */
scheme_once_used_type, /* 163 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 161 */
_scheme_last_normal_type_, /* 164 */
scheme_rt_weak_array, /* 162 */
scheme_rt_weak_array, /* 165 */
scheme_rt_comp_env, /* 163 */
scheme_rt_constant_binding, /* 164 */
scheme_rt_resolve_info, /* 165 */
scheme_rt_optimize_info, /* 166 */
scheme_rt_compile_info, /* 167 */
scheme_rt_cont_mark, /* 168 */
scheme_rt_saved_stack, /* 169 */
scheme_rt_reply_item, /* 170 */
scheme_rt_closure_info, /* 171 */
scheme_rt_overflow, /* 172 */
scheme_rt_overflow_jmp, /* 173 */
scheme_rt_meta_cont, /* 174 */
scheme_rt_dyn_wind_cell, /* 175 */
scheme_rt_dyn_wind_info, /* 176 */
scheme_rt_dyn_wind, /* 177 */
scheme_rt_dup_check, /* 178 */
scheme_rt_thread_memory, /* 179 */
scheme_rt_input_file, /* 180 */
scheme_rt_input_fd, /* 181 */
scheme_rt_oskit_console_input, /* 182 */
scheme_rt_tested_input_file, /* 183 */
scheme_rt_tested_output_file, /* 184 */
scheme_rt_indexed_string, /* 185 */
scheme_rt_output_file, /* 186 */
scheme_rt_load_handler_data, /* 187 */
scheme_rt_pipe, /* 188 */
scheme_rt_beos_process, /* 189 */
scheme_rt_system_child, /* 190 */
scheme_rt_tcp, /* 191 */
scheme_rt_write_data, /* 192 */
scheme_rt_tcp_select_info, /* 193 */
scheme_rt_param_data, /* 194 */
scheme_rt_will, /* 195 */
scheme_rt_struct_proc_info, /* 196 */
scheme_rt_linker_name, /* 197 */
scheme_rt_param_map, /* 198 */
scheme_rt_finalization, /* 199 */
scheme_rt_finalizations, /* 200 */
scheme_rt_cpp_object, /* 201 */
scheme_rt_cpp_array_object, /* 202 */
scheme_rt_stack_object, /* 203 */
scheme_rt_preallocated_object, /* 204 */
scheme_thread_hop_type, /* 205 */
scheme_rt_srcloc, /* 206 */
scheme_rt_evt, /* 207 */
scheme_rt_syncing, /* 208 */
scheme_rt_comp_prefix, /* 209 */
scheme_rt_user_input, /* 210 */
scheme_rt_user_output, /* 211 */
scheme_rt_compact_port, /* 212 */
scheme_rt_read_special_dw, /* 213 */
scheme_rt_regwork, /* 214 */
scheme_rt_buf_holder, /* 215 */
scheme_rt_parameterization, /* 216 */
scheme_rt_print_params, /* 217 */
scheme_rt_read_params, /* 218 */
scheme_rt_native_code, /* 219 */
scheme_rt_native_code_plus_case, /* 220 */
scheme_rt_jitter_data, /* 221 */
scheme_rt_module_exports, /* 222 */
scheme_rt_delay_load_info, /* 223 */
scheme_rt_marshal_info, /* 224 */
scheme_rt_unmarshal_info, /* 225 */
scheme_rt_runstack, /* 226 */
scheme_rt_sfs_info, /* 227 */
scheme_rt_validate_clearing, /* 228 */
scheme_rt_rb_node, /* 229 */
scheme_rt_frozen_tramp, /* 230 */
scheme_rt_comp_env, /* 166 */
scheme_rt_constant_binding, /* 167 */
scheme_rt_resolve_info, /* 168 */
scheme_rt_optimize_info, /* 169 */
scheme_rt_compile_info, /* 170 */
scheme_rt_cont_mark, /* 171 */
scheme_rt_saved_stack, /* 172 */
scheme_rt_reply_item, /* 173 */
scheme_rt_closure_info, /* 174 */
scheme_rt_overflow, /* 175 */
scheme_rt_overflow_jmp, /* 176 */
scheme_rt_meta_cont, /* 177 */
scheme_rt_dyn_wind_cell, /* 178 */
scheme_rt_dyn_wind_info, /* 179 */
scheme_rt_dyn_wind, /* 180 */
scheme_rt_dup_check, /* 181 */
scheme_rt_thread_memory, /* 182 */
scheme_rt_input_file, /* 183 */
scheme_rt_input_fd, /* 184 */
scheme_rt_oskit_console_input, /* 185 */
scheme_rt_tested_input_file, /* 186 */
scheme_rt_tested_output_file, /* 187 */
scheme_rt_indexed_string, /* 188 */
scheme_rt_output_file, /* 189 */
scheme_rt_load_handler_data, /* 190 */
scheme_rt_pipe, /* 191 */
scheme_rt_beos_process, /* 192 */
scheme_rt_system_child, /* 193 */
scheme_rt_tcp, /* 194 */
scheme_rt_write_data, /* 195 */
scheme_rt_tcp_select_info, /* 196 */
scheme_rt_param_data, /* 197 */
scheme_rt_will, /* 198 */
scheme_rt_struct_proc_info, /* 199 */
scheme_rt_linker_name, /* 200 */
scheme_rt_param_map, /* 201 */
scheme_rt_finalization, /* 202 */
scheme_rt_finalizations, /* 203 */
scheme_rt_cpp_object, /* 204 */
scheme_rt_cpp_array_object, /* 205 */
scheme_rt_stack_object, /* 206 */
scheme_rt_preallocated_object, /* 207 */
scheme_thread_hop_type, /* 208 */
scheme_rt_srcloc, /* 209 */
scheme_rt_evt, /* 210 */
scheme_rt_syncing, /* 211 */
scheme_rt_comp_prefix, /* 212 */
scheme_rt_user_input, /* 213 */
scheme_rt_user_output, /* 214 */
scheme_rt_compact_port, /* 215 */
scheme_rt_read_special_dw, /* 216 */
scheme_rt_regwork, /* 217 */
scheme_rt_buf_holder, /* 218 */
scheme_rt_parameterization, /* 219 */
scheme_rt_print_params, /* 220 */
scheme_rt_read_params, /* 221 */
scheme_rt_native_code, /* 222 */
scheme_rt_native_code_plus_case, /* 223 */
scheme_rt_jitter_data, /* 224 */
scheme_rt_module_exports, /* 225 */
scheme_rt_delay_load_info, /* 226 */
scheme_rt_marshal_info, /* 227 */
scheme_rt_unmarshal_info, /* 228 */
scheme_rt_runstack, /* 229 */
scheme_rt_sfs_info, /* 230 */
scheme_rt_validate_clearing, /* 231 */
scheme_rt_rb_node, /* 232 */
scheme_rt_frozen_tramp, /* 233 */
#endif

73
src/mzscheme/src/thread.c
View File

@ -6184,12 +6184,6 @@ void scheme_install_config(Scheme_Config *config)
scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
}
#ifdef MZTAG_REQUIRED
# define IS_VECTOR(c) SCHEME_VECTORP((c)->content)
#else
# define IS_VECTOR(c) (!(c)->is_param)
#endif
Scheme_Object *find_param_cell(Scheme_Config *c, Scheme_Object *k, int force_cell)
/* Unless force_cell, the result may actually be a value, if there has been
no reason to set it before */
@ -6342,7 +6336,8 @@ static Scheme_Object *parameterization_p(int argc, Scheme_Object **argv)
#define SCHEME_PARAMETERP(v) ((SCHEME_PRIMP(v) || SCHEME_CLSD_PRIMP(v)) \
&& (((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_IS_PARAMETER))
&& ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK) \
== SCHEME_PRIM_TYPE_PARAMETER))
static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[])
{
@ -6503,7 +6498,7 @@ static Scheme_Object *make_parameter(int argc, Scheme_Object **argv)
p = scheme_make_closed_prim_w_arity(do_param, (void *)data,
"parameter-procedure", 0, 1);
((Scheme_Primitive_Proc *)p)->pp.flags |= SCHEME_PRIM_IS_PARAMETER;
((Scheme_Primitive_Proc *)p)->pp.flags |= SCHEME_PRIM_TYPE_PARAMETER;
return p;
}
@ -6530,7 +6525,7 @@ static Scheme_Object *make_derived_parameter(int argc, Scheme_Object **argv)
p = scheme_make_closed_prim_w_arity(do_param, (void *)data,
"parameter-procedure", 0, 1);
((Scheme_Primitive_Proc *)p)->pp.flags |= SCHEME_PRIM_IS_PARAMETER;
((Scheme_Primitive_Proc *)p)->pp.flags |= SCHEME_PRIM_TYPE_PARAMETER;
return p;
}
@ -6542,11 +6537,9 @@ static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object **argv)
a = argv[0];
b = argv[1];
if (!((SCHEME_PRIMP(a) || SCHEME_CLSD_PRIMP(a))
&& (((Scheme_Primitive_Proc *)a)->pp.flags & SCHEME_PRIM_IS_PARAMETER)))
if (!SCHEME_PARAMETERP(a))
scheme_wrong_type("parameter-procedure=?", "parameter-procedure", 0, argc, argv);
if (!((SCHEME_PRIMP(b) || SCHEME_CLSD_PRIMP(b))
&& (((Scheme_Primitive_Proc *)b)->pp.flags & SCHEME_PRIM_IS_PARAMETER)))
if (!SCHEME_PARAMETERP(b))
scheme_wrong_type("parameter-procedure=?", "parameter-procedure", 1, argc, argv);
return (SAME_OBJ(a, b)
@ -6770,7 +6763,7 @@ Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int
return config_map[which];
o = scheme_make_prim_w_arity(function, name, 0, 1);
((Scheme_Primitive_Proc *)o)->pp.flags |= SCHEME_PRIM_IS_PARAMETER;
((Scheme_Primitive_Proc *)o)->pp.flags |= SCHEME_PRIM_TYPE_PARAMETER;
config_map[which] = o;
@ -7462,13 +7455,25 @@ END_XFORM_SKIP;
/* stats */
/*========================================================================*/
static void set_perf_vector(Scheme_Object *v, Scheme_Object *ov, int i, Scheme_Object *a)
{
if (SAME_OBJ(v, ov))
SCHEME_VEC_ELS(v)[i] = a;
else
scheme_chaperone_vector_set(ov, i, a);
}
static Scheme_Object *current_stats(int argc, Scheme_Object *argv[])
{
Scheme_Object *v;
Scheme_Object *v, *ov;
Scheme_Thread *t = NULL;
v = argv[0];
ov = v;
if (SCHEME_CHAPERONEP(v))
v = SCHEME_CHAPERONE_VAL(v);
if (!SCHEME_MUTABLE_VECTORP(v))
scheme_wrong_type("vector-set-performance-stats!", "mutable vector", 0, argc, argv);
if (argc > 1) {
@ -7532,25 +7537,25 @@ static Scheme_Object *current_stats(int argc, Scheme_Object *argv[])
}
}
SCHEME_VEC_ELS(v)[3] = scheme_make_integer(sz);
set_perf_vector(v, ov, 3, scheme_make_integer(sz));
}
case 3:
SCHEME_VEC_ELS(v)[2] = (t->block_descriptor
? scheme_true
: ((t->running & MZTHREAD_SUSPENDED)
? scheme_true
: scheme_false));
set_perf_vector(v, ov, 2, (t->block_descriptor
? scheme_true
: ((t->running & MZTHREAD_SUSPENDED)
? scheme_true
: scheme_false)));
case 2:
{
Scheme_Object *dp;
dp = thread_dead_p(1, (Scheme_Object **) mzALIAS &t);
SCHEME_VEC_ELS(v)[1] = dp;
set_perf_vector(v, ov, 1, dp);
}
case 1:
{
Scheme_Object *rp;
rp = thread_running_p(1, (Scheme_Object **) mzALIAS &t);
SCHEME_VEC_ELS(v)[0] = rp;
set_perf_vector(v, ov, 0, rp);
}
case 0:
break;
@ -7565,27 +7570,27 @@ static Scheme_Object *current_stats(int argc, Scheme_Object *argv[])
switch (SCHEME_VEC_SIZE(v)) {
default:
case 11:
SCHEME_VEC_ELS(v)[10] = scheme_make_integer(scheme_jit_malloced);
set_perf_vector(v, ov, 10, scheme_make_integer(scheme_jit_malloced));
case 10:
SCHEME_VEC_ELS(v)[9] = scheme_make_integer(scheme_hash_iteration_count);
set_perf_vector(v, ov, 9, scheme_make_integer(scheme_hash_iteration_count));
case 9:
SCHEME_VEC_ELS(v)[8] = scheme_make_integer(scheme_hash_request_count);
set_perf_vector(v, ov, 8, scheme_make_integer(scheme_hash_request_count));
case 8:
SCHEME_VEC_ELS(v)[7] = scheme_make_integer(scheme_num_read_syntax_objects);
set_perf_vector(v, ov, 7, scheme_make_integer(scheme_num_read_syntax_objects));
case 7:
SCHEME_VEC_ELS(v)[6] = scheme_make_integer(num_running_threads+1);
set_perf_vector(v, ov, 6, scheme_make_integer(num_running_threads+1));
case 6:
SCHEME_VEC_ELS(v)[5] = scheme_make_integer(scheme_overflow_count);
set_perf_vector(v, ov, 5, scheme_make_integer(scheme_overflow_count));
case 5:
SCHEME_VEC_ELS(v)[4] = scheme_make_integer(thread_swap_count);
set_perf_vector(v, ov, 4, scheme_make_integer(thread_swap_count));
case 4:
SCHEME_VEC_ELS(v)[3] = scheme_make_integer(scheme_did_gc_count);
set_perf_vector(v, ov, 3, scheme_make_integer(scheme_did_gc_count));
case 3:
SCHEME_VEC_ELS(v)[2] = scheme_make_integer(gcend);
set_perf_vector(v, ov, 2, scheme_make_integer(gcend));
case 2:
SCHEME_VEC_ELS(v)[1] = scheme_make_integer(end);
set_perf_vector(v, ov, 1, scheme_make_integer(end));
case 1:
SCHEME_VEC_ELS(v)[0] = scheme_make_integer(cpuend);
set_perf_vector(v, ov, 0, scheme_make_integer(cpuend));
case 0:
break;
}

3
src/mzscheme/src/type.c
View File

@ -152,7 +152,10 @@ scheme_init_type ()
set_name(scheme_unix_path_type, "<unix-path>");
set_name(scheme_windows_path_type, "<windows-path>");
set_name(scheme_struct_property_type, "<struct-property>");
set_name(scheme_chaperone_property_type, "<chaperone-property>");
set_name(scheme_structure_type, "<struct>");
set_name(scheme_proc_chaperone_type, "<chaperone>");
set_name(scheme_chaperone_type, "<chaperone>");
#ifdef USE_SENORA_GC
set_name(scheme_proc_struct_type, "<procedure-struct>");
#else

421
src/mzscheme/src/vector.c
View File

@ -24,10 +24,13 @@
*/
#include "schpriv.h"
#include "schmach.h"
/* globals */
READ_ONLY Scheme_Object *scheme_vector_proc;
READ_ONLY Scheme_Object *scheme_vector_immutable_proc;
READ_ONLY Scheme_Object *scheme_vector_ref_proc;
READ_ONLY Scheme_Object *scheme_vector_set_proc;
/* locals */
static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]);
@ -41,6 +44,7 @@ static Scheme_Object *vector_fill (int argc, Scheme_Object *argv[]);
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 *unsafe_vector_len (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]);
@ -89,15 +93,19 @@ scheme_init_vector (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("vector-length", p, env);
p = scheme_make_immed_prim(scheme_checked_vector_ref,
"vector-ref",
2, 2);
REGISTER_SO(scheme_vector_ref_proc);
p = scheme_make_noncm_prim(scheme_checked_vector_ref,
"vector-ref",
2, 2);
scheme_vector_ref_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("vector-ref", p, env);
p = scheme_make_immed_prim(scheme_checked_vector_set,
"vector-set!",
3, 3);
REGISTER_SO(scheme_vector_set_proc);
p = scheme_make_noncm_prim(scheme_checked_vector_set,
"vector-set!",
3, 3);
scheme_vector_set_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("vector-set!", p, env);
@ -132,6 +140,12 @@ scheme_init_vector (Scheme_Env *env)
1, 3,
0, -1),
env);
scheme_add_global_constant("chaperone-vector",
scheme_make_prim_w_arity(chaperone_vector,
"chaperone-vector",
3, -1),
env);
}
void
@ -139,85 +153,79 @@ scheme_init_unsafe_vector (Scheme_Env *env)
{
Scheme_Object *p;
p = scheme_make_immed_prim(unsafe_vector_len,
"unsafe-vector-length",
1, 1);
p = scheme_make_immed_prim(unsafe_vector_len, "unsafe-vector-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-vector-length", p, env);
p = scheme_make_immed_prim(unsafe_vector_ref,
"unsafe-vector-ref",
2, 2);
p = scheme_make_immed_prim(unsafe_vector_len, "unsafe-vector*-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-vector*-length", p, env);
p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-vector-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_set,
"unsafe-vector-set!",
3, 3);
p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector*-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-vector*-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_set, "unsafe-vector-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-vector-set!", p, env);
p = scheme_make_immed_prim(unsafe_vector_ref,
"unsafe-vector-ref",
2, 2);
p = scheme_make_immed_prim(unsafe_struct_ref,
"unsafe-struct-ref",
2, 2);
p = scheme_make_immed_prim(unsafe_vector_set, "unsafe-vector*-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-vector*-set!", p, env);
p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-struct-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_set,
"unsafe-struct-set!",
3, 3);
p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct*-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-struct*-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_set, "unsafe-struct-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-struct-set!", p, env);
p = scheme_make_immed_prim(unsafe_struct_set, "unsafe-struct*-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-struct*-set!", p, env);
p = scheme_make_immed_prim(unsafe_string_len,
"unsafe-string-length",
1, 1);
p = scheme_make_immed_prim(unsafe_string_len, "unsafe-string-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-string-length", p, env);
p = scheme_make_immed_prim(unsafe_string_ref,
"unsafe-string-ref",
2, 2);
p = scheme_make_immed_prim(unsafe_string_ref, "unsafe-string-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-string-ref", p, env);
p = scheme_make_immed_prim(unsafe_string_set,
"unsafe-string-set!",
3, 3);
p = scheme_make_immed_prim(unsafe_string_set, "unsafe-string-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-string-set!", p, env);
p = scheme_make_immed_prim(unsafe_bytes_len,
"unsafe-bytes-length",
1, 1);
p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-bytes-length", p, env);
p = scheme_make_immed_prim(unsafe_bytes_ref,
"unsafe-bytes-ref",
2, 2);
p = scheme_make_immed_prim(unsafe_bytes_ref, "unsafe-bytes-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-bytes-ref", p, env);
p = scheme_make_immed_prim(unsafe_bytes_set,
"unsafe-bytes-set!",
3, 3);
p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-bytes-set!", p, env);
p = scheme_make_immed_prim(unsafe_bytes_ref,
"unsafe-bytes-ref",
2, 2);
scheme_add_global_constant("unsafe-bytes-set!", p, env);
}
#define VECTOR_BYTES(size) (sizeof(Scheme_Vector) + ((size) - 1) * sizeof(Scheme_Object *))
@ -256,7 +264,7 @@ scheme_make_vector (long size, Scheme_Object *fill)
static Scheme_Object *
vector_p (int argc, Scheme_Object *argv[])
{
return (SCHEME_VECTORP(argv[0]) ? scheme_true : scheme_false);
return (SCHEME_CHAPERONE_VECTORP(argv[0]) ? scheme_true : scheme_false);
}
static Scheme_Object *
@ -312,10 +320,15 @@ vector_immutable (int argc, Scheme_Object *argv[])
static Scheme_Object *
vector_length (int argc, Scheme_Object *argv[])
{
if (!SCHEME_VECTORP(argv[0]))
Scheme_Object *vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_type("vector-length", "vector", 0, argc, argv);
return scheme_make_integer(SCHEME_VEC_SIZE(argv[0]));
return scheme_make_integer(SCHEME_VEC_SIZE(vec));
}
Scheme_Object *scheme_vector_length(Scheme_Object *v)
@ -355,30 +368,127 @@ bad_index(char *name, Scheme_Object *i, Scheme_Object *vec, int bottom)
return NULL;
}
static Scheme_Object *chaperone_vector_ref_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
p->ku.k.p1 = NULL;
return scheme_chaperone_vector_ref(o, p->ku.k.i1);
}
static Scheme_Object *chaperone_vector_ref_overflow(Scheme_Object *o, int i)
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)o;
p->ku.k.i1 = i;
return scheme_handle_stack_overflow(chaperone_vector_ref_k);
}
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
{
if (!SCHEME_NP_CHAPERONEP(o)) {
return SCHEME_VEC_ELS(o)[i];
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red, *orig;
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
return chaperone_vector_ref_overflow(o, i);
}
#endif
orig = scheme_chaperone_vector_ref(px->prev, i);
if (SCHEME_VECTORP(px->redirects)) {
/* chaperone was on property accessors */
return orig;
}
a[0] = px->prev;
a[1] = scheme_make_integer(i);
a[2] = orig;
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);
return o;
}
}
Scheme_Object *
scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
{
long i, len;
Scheme_Object *vec;
if (!SCHEME_VECTORP(argv[0]))
vec = argv[0];
if (SCHEME_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_type("vector-ref", "vector", 0, argc, argv);
len = SCHEME_VEC_SIZE(argv[0]);
len = SCHEME_VEC_SIZE(vec);
i = scheme_extract_index("vector-ref", 1, argc, argv, len, 0);
if (i >= len)
return bad_index("vector-ref", argv[1], argv[0], 0);
return (SCHEME_VEC_ELS(argv[0]))[i];
if (!SAME_OBJ(vec, argv[0]))
/* chaperone */
return scheme_chaperone_vector_ref(argv[0], i);
else
return (SCHEME_VEC_ELS(vec))[i];
}
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
{
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
SCHEME_VEC_ELS(o)[i] = v;
return;
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red;
o = px->prev;
a[0] = o;
a[1] = scheme_make_integer(i);
a[2] = 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]);
}
}
}
Scheme_Object *
scheme_checked_vector_set(int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
long i, len;
if (!SCHEME_MUTABLE_VECTORP(argv[0]))
if (SCHEME_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_MUTABLE_VECTORP(vec))
scheme_wrong_type("vector-set!", "mutable vector", 0, argc, argv);
len = SCHEME_VEC_SIZE(argv[0]);
@ -388,20 +498,14 @@ scheme_checked_vector_set(int argc, Scheme_Object *argv[])
if (i >= len)
return bad_index("vector-set!", argv[1], argv[0], 0);
(SCHEME_VEC_ELS(argv[0]))[i] = argv[2];
if (!SAME_OBJ(vec, argv[0]))
scheme_chaperone_vector_set(argv[0], i, argv[2]);
else
SCHEME_VEC_ELS(vec)[i] = argv[2];
return scheme_void;
}
static Scheme_Object *
vector_to_list (int argc, Scheme_Object *argv[])
{
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector->list", "vector", 0, argc, argv);
return scheme_vector_to_list(argv[0]);
}
# define cons(car, cdr) scheme_make_pair(car, cdr)
Scheme_Object *
@ -427,6 +531,43 @@ scheme_vector_to_list (Scheme_Object *vec)
return pair;
}
Scheme_Object *
chaperone_vector_to_list (Scheme_Object *vec)
{
int i;
Scheme_Object *pair = scheme_null;
i = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec));
for (; i--; ) {
if (!(i & 0xFFF))
SCHEME_USE_FUEL(0xFFF);
pair = cons(scheme_chaperone_vector_ref(vec, i), pair);
}
return pair;
}
static Scheme_Object *
vector_to_list (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec)) {
scheme_wrong_type("vector->list", "vector", 0, argc, argv);
return NULL;
}
if (!SAME_OBJ(vec, argv[0]))
return chaperone_vector_to_list(argv[0]);
else
return scheme_vector_to_list(vec);
}
static Scheme_Object *
list_to_vector (int argc, Scheme_Object *argv[])
{
@ -456,18 +597,27 @@ static Scheme_Object *
vector_fill (int argc, Scheme_Object *argv[])
{
int i, sz;
Scheme_Object *v;
Scheme_Object *v, *vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_MUTABLE_VECTORP(argv[0]))
if (!SCHEME_MUTABLE_VECTORP(vec))
scheme_wrong_type("vector-fill!", "mutable vector", 0, argc, argv);
v = argv[1];
sz = SCHEME_VEC_SIZE(argv[0]);
for (i = 0; i < sz; i++) {
SCHEME_VEC_ELS(argv[0])[i] = v;
sz = SCHEME_VEC_SIZE(vec);
if (SAME_OBJ(vec, argv[0])) {
for (i = 0; i < sz; i++) {
SCHEME_VEC_ELS(argv[0])[i] = v;
}
} else {
for (i = 0; i < sz; i++) {
scheme_chaperone_vector_set(argv[0], i, v);
}
}
return argv[0];
return scheme_void;
}
static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
@ -475,8 +625,13 @@ static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
Scheme_Object *s1, *s2;
long istart, ifinish;
long ostart, ofinish;
int slow = 0;
s1 = argv[0];
if (SCHEME_NP_CHAPERONEP(s1)) {
slow = 1;
s1 = SCHEME_CHAPERONE_VAL(s1);
}
if (!SCHEME_MUTABLE_VECTORP(s1))
scheme_wrong_type("vector-copy!", "mutable vector", 0, argc, argv);
@ -485,6 +640,10 @@ static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
&ostart, &ofinish, SCHEME_VEC_SIZE(s1));
s2 = argv[2];
if (SCHEME_NP_CHAPERONEP(s2)) {
slow = 1;
s2 = SCHEME_CHAPERONE_VAL(s2);
}
if (!SCHEME_VECTORP(s2))
scheme_wrong_type("vector-copy!", "vector", 2, argc, argv);
@ -499,30 +658,66 @@ static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
return NULL;
}
memmove(SCHEME_VEC_ELS(s1) + ostart,
SCHEME_VEC_ELS(s2) + istart,
(ifinish - istart) * sizeof(Scheme_Object*));
if (slow) {
int i, o;
for (i = istart, o = ostart; i < ifinish; i++, o++) {
scheme_chaperone_vector_set(argv[0], o, scheme_chaperone_vector_ref(argv[2], i));
}
} else {
memmove(SCHEME_VEC_ELS(s1) + ostart,
SCHEME_VEC_ELS(s2) + istart,
(ifinish - istart) * sizeof(Scheme_Object*));
}
return scheme_void;
}
Scheme_Object *scheme_chaperone_vector_copy(Scheme_Object *vec)
{
int len;
Scheme_Object *a[3], *vec2;
if (SCHEME_NP_CHAPERONEP(vec))
len = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec));
else
len = SCHEME_VEC_SIZE(vec);
vec2 = scheme_make_vector(len, NULL);
a[0] = vec2;
a[1] = scheme_make_integer(0);
a[2] = vec;
return vector_copy_bang(3, a);
}
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *ovec;
Scheme_Object *vec, *ovec, *v;
long len, i;
if (!SCHEME_VECTORP(argv[0]))
vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_type("vector->immutable-vector", "vector", 0, argc, argv);
if (SCHEME_IMMUTABLEP(argv[0]))
if (SCHEME_IMMUTABLEP(vec))
return argv[0];
ovec = argv[0];
ovec = vec;
len = SCHEME_VEC_SIZE(ovec);
vec = scheme_make_vector(len, NULL);
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
if (!SAME_OBJ(ovec, argv[0])) {
for (i = 0; i < len; i++) {
v = scheme_chaperone_vector_ref(argv[0], i);
SCHEME_VEC_ELS(vec)[i] = v;
}
} else {
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
}
}
SCHEME_SET_IMMUTABLE(vec);
@ -536,6 +731,8 @@ static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
long len, start, finish, i;
vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_type("vector->values", "vector", 0, argc, argv);
@ -552,15 +749,19 @@ static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
finish = len;
if (!(start <= len)) {
bad_index("vector->values", argv[1], vec, 0);
bad_index("vector->values", argv[1], argv[0], 0);
}
if (!(finish >= start && finish <= len)) {
bad_index("vector->values", argv[2], vec, start);
bad_index("vector->values", argv[2], argv[0], start);
}
len = finish - start;
if (len == 1)
return SCHEME_VEC_ELS(vec)[start];
if (len == 1) {
if (!SAME_OBJ(vec, argv[0]))
return scheme_chaperone_vector_ref(argv[0], start);
else
return SCHEME_VEC_ELS(vec)[start];
}
p = scheme_current_thread;
if (p->values_buffer && (p->values_buffer_size >= len))
@ -574,31 +775,76 @@ static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
p->ku.multiple.array = a;
p->ku.multiple.count = len;
for (i = 0; i < len; i++) {
a[i] = SCHEME_VEC_ELS(vec)[start + i];
if (!SAME_OBJ(vec, argv[0])) {
for (i = 0; i < len; i++) {
vec = scheme_chaperone_vector_ref(argv[0], start + i);
a[i] = vec;
}
} else {
for (i = 0; i < len; i++) {
a[i] = SCHEME_VEC_ELS(vec)[start + i];
}
}
return SCHEME_MULTIPLE_VALUES;
}
static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Hash_Tree *props;
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);
props = scheme_parse_chaperone_props("chaperone-vector", 3, argc, argv);
redirects = scheme_make_pair(argv[1], argv[2]);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->so.type = scheme_chaperone_type;
px->props = props;
px->val = val;
px->prev = argv[0];
px->redirects = redirects;
return (Scheme_Object *)px;
}
/************************************************************/
/* unsafe */
/************************************************************/
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[])
{
long n = SCHEME_VEC_SIZE(argv[0]);
Scheme_Object *vec = argv[0];
long n;
if (SCHEME_NP_CHAPERONEP(vec)) vec = SCHEME_CHAPERONE_VAL(vec);
n = SCHEME_VEC_SIZE(vec);
return scheme_make_integer(n);
}
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[])
{
return SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])];
if (SCHEME_NP_CHAPERONEP(argv[0]))
return scheme_chaperone_vector_ref(argv[0], SCHEME_INT_VAL(argv[1]));
else
return SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])];
}
static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[])
{
SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])] = argv[2];
if (SCHEME_NP_CHAPERONEP(argv[0]))
scheme_chaperone_vector_set(argv[0], SCHEME_INT_VAL(argv[1]), argv[2]);
else
SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])] = argv[2];
return scheme_void;
}
@ -650,4 +896,3 @@ static Scheme_Object *unsafe_bytes_set (int argc, Scheme_Object *argv[])
SCHEME_BYTE_STR_VAL(argv[0])[SCHEME_INT_VAL(argv[1])] = (char)SCHEME_INT_VAL(argv[2]);
return scheme_void;
}