Compare commits

..

7 Commits

286 changed files with 17414 additions and 22172 deletions

View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "6.4.0.15") (define version "6.4.0.4")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

View File

@ -48,19 +48,6 @@ exec racket -qu "$0" ${1+"$@"}
(compile-file name (compile-file name
"compiled/current-bm_rkt.zo")))) "compiled/current-bm_rkt.zo"))))
(define (mk-errortrace bm)
(unless (directory-exists? "compiled")
(make-directory "compiled"))
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t]
[current-compile (current-compile)]
[error-display-handler (error-display-handler)]
[use-compiled-file-paths (use-compiled-file-paths)])
(dynamic-require 'errortrace #f)
(let ([name (format "~a.rkt" bm)])
(compile-file name
"compiled/current-bm_rkt.zo"))))
(define (compiled-path bm) (define (compiled-path bm)
"current-bm.rkt") "current-bm.rkt")
@ -408,14 +395,6 @@ exec racket -qu "$0" ${1+"$@"}
extract-racket-times extract-racket-times
clean-up-zo clean-up-zo
racket-skip-progs) racket-skip-progs)
(make-impl 'errortrace
void
mk-errortrace
(lambda (bm)
(system (format "racket -l errortrace -u ~a" (compiled-path bm))))
extract-racket-times
clean-up-zo
racket-skip-progs)
(make-impl 'plt-r5rs (make-impl 'plt-r5rs
void void
mk-plt-r5rs mk-plt-r5rs

View File

@ -33,7 +33,7 @@ information about packages:
@exec{version=}@nonterm{version} query (where @nonterm{version} @exec{version=}@nonterm{version} query (where @nonterm{version}
is a Racket version number) in the case of a remote URL. is a Racket version number) in the case of a remote URL.
This URL/path form is used to obtain information about This URL/path form is use to obtain information about
@nonterm{package}. An HTTP request for a remote URL should @nonterm{package}. An HTTP request for a remote URL should
respond with a @racket[read]-able hash table, as described respond with a @racket[read]-able hash table, as described
below. A path in a local directory formed by adding below. A path in a local directory formed by adding
@ -130,8 +130,7 @@ information about packages:
Note that a local directory served as files through an HTTP server Note that a local directory served as files through an HTTP server
works as a remote URL, as long as the @filepath{pkgs} and works as a remote URL, as long as the @filepath{pkgs} and
@filepath{pkgs-all} files are present (since those are optional for @filepath{pkgs-all} files are present.
local but required for HTTP).
The source for the PLT-hosted @tech{package catalog} is in the The source for the PLT-hosted @tech{package catalog} is in the
@racket[(collection-file-path "pkg-catalog" "meta")] @racket[(collection-file-path "pkg-catalog" "meta")]

View File

@ -385,9 +385,7 @@ is:
If you want the package to be @nonterm{branch} or @nonterm{tag} If you want the package to be @nonterm{branch} or @nonterm{tag}
instead of @exec{master}, then add @filepath{#@nonterm{branch}} or instead of @exec{master}, then add @filepath{#@nonterm{branch}} or
@filepath{#@nonterm{tag}} to the end of the package source. If your @filepath{#@nonterm{tag}} to the end of the package source.
package is a subdirectory @nonterm{path} within the repository, add
@filepath{?path=@nonterm{path}} to the end of the package source.
Whenever you Whenever you
@ -397,10 +395,9 @@ your changes will automatically be discovered by those who use
@command-ref{update} after installing from your @command-ref{update} after installing from your
GitHub-based @tech{package source}. GitHub-based @tech{package source}.
Other Git repository services@margin-note*{Support for services other As of Racket version 6.1.1.1, other Git repository services can work
than GitHub requires Racket version 6.1.1.1 or later.} can work
just as well as GitHub---including Gitorious or BitBucket---as long as just as well as GitHub---including Gitorious or BitBucket---as long as
the server supports either the HTTP(S) protocol or the the server supports either the ``smart'' HTTP(S) protocol or the
native Git protocol (but use a @exec{git://} path for the latter). native Git protocol (but use a @exec{git://} path for the latter).
The Racket package manager provides more support for Git-based The Racket package manager provides more support for Git-based

View File

@ -265,8 +265,7 @@ is true, error messages may suggest specific command-line flags for
[#:force-strip? force-string? boolean? #f] [#:force-strip? force-string? boolean? #f]
[#:multi-clone-mode multi-clone-mode (or/c 'fail 'force 'convert 'ask) 'fail] [#:multi-clone-mode multi-clone-mode (or/c 'fail 'force 'convert 'ask) 'fail]
[#:pull-mode pull-mode (or/c 'ff-only 'try 'rebase) 'ff-only] [#:pull-mode pull-mode (or/c 'ff-only 'try 'rebase) 'ff-only]
[#:link-dirs? link-dirs? boolean? #f] [#:link-dirs? link-dirs? boolean? #f])
[#:dry-run? dry-run? boolean? #f])
(or/c 'skip (or/c 'skip
#f #f
(listof (or/c path-string? (listof (or/c path-string?
@ -300,8 +299,7 @@ The package lock must be held; see @racket[with-pkg-lock].
@history[#:changed "6.1.1.5" @elem{Added the @racket[#:multi-clone-mode] @history[#:changed "6.1.1.5" @elem{Added the @racket[#:multi-clone-mode]
and @racket[#:infer-clone-from-dir?] arguments.} and @racket[#:infer-clone-from-dir?] arguments.}
#:changed "6.1.1.6" @elem{Added the @racket[#:use-trash?] argument.} #:changed "6.1.1.6" @elem{Added the @racket[#:use-trash?] argument.}
#:changed "6.1.1.8" @elem{Added the @racket[#:pull-mode] argument.} #:changed "6.1.1.8" @elem{Added the @racket[#:pull-mode] argument.}]}
#:changed "6.4.0.14" @elem{Added the @racket[#:dry-run] argument.}]}
@defproc[(pkg-update [sources (listof (or/c string? pkg-desc?))] @defproc[(pkg-update [sources (listof (or/c string? pkg-desc?))]
@ -316,7 +314,7 @@ The package lock must be held; see @racket[with-pkg-lock].
[#:use-cache? use-cache? boolean? #t] [#:use-cache? use-cache? boolean? #t]
[#:skip-uninstalled? skip-uninstalled? boolean? #t] [#:skip-uninstalled? skip-uninstalled? boolean? #t]
[#:quiet? quiet? boolean? #f] [#:quiet? quiet? boolean? #f]
[#:use-trash? use-trash? boolean? #f] [#:use-trash? boolean? use-trash? #f]
[#:from-command-line? from-command-line? boolean? #f] [#:from-command-line? from-command-line? boolean? #f]
[#:strip strip (or/c #f 'source 'binary 'binary-lib) #f] [#:strip strip (or/c #f 'source 'binary 'binary-lib) #f]
[#:force-strip? force-string? boolean? #f] [#:force-strip? force-string? boolean? #f]
@ -324,8 +322,7 @@ The package lock must be held; see @racket[with-pkg-lock].
[#:multi-clone-mode multi-clone-mode (or/c 'fail 'force 'convert 'ask) 'fail] [#:multi-clone-mode multi-clone-mode (or/c 'fail 'force 'convert 'ask) 'fail]
[#:pull-mode pull-mode (or/c 'ff-only 'try 'rebase) 'ff-only] [#:pull-mode pull-mode (or/c 'ff-only 'try 'rebase) 'ff-only]
[#:link-dirs? link-dirs? boolean? #f] [#:link-dirs? link-dirs? boolean? #f]
[#:infer-clone-from-dir? infer-clone-from-dir? boolean? #f] [#:infer-clone-from-dir? infer-clone-from-dir? boolean? #f])
[#:dry-run? dry-run? boolean? #f])
(or/c 'skip (or/c 'skip
#f #f
(listof (or/c path-string? (listof (or/c path-string?
@ -360,8 +357,7 @@ The package lock must be held; see @racket[with-pkg-lock].
@history[#:changed "6.1.1.5" @elem{Added the @racket[#:multi-clone-mode] @history[#:changed "6.1.1.5" @elem{Added the @racket[#:multi-clone-mode]
and @racket[#:infer-clone-from-dir?] arguments.} and @racket[#:infer-clone-from-dir?] arguments.}
#:changed "6.1.1.6" @elem{Added the @racket[#:use-trash?] argument.} #:changed "6.1.1.6" @elem{Added the @racket[#:use-trash?] argument.}
#:changed "6.1.1.8" @elem{Added the @racket[#:skip-uninstalled?] and @racket[#:pull-mode] arguments.} #:changed "6.1.1.8" @elem{Added the @racket[#:skip-uninstalled?] and @racket[#:pull-mode] arguments.}]}
#:changed "6.4.0.14" @elem{Added the @racket[#:dry-run] argument.}]}
@defproc[(pkg-remove [names (listof string?)] @defproc[(pkg-remove [names (listof string?)]
@ -370,8 +366,7 @@ The package lock must be held; see @racket[with-pkg-lock].
[#:force? force? boolean? #f] [#:force? force? boolean? #f]
[#:quiet? quiet? boolean? #f] [#:quiet? quiet? boolean? #f]
[#:use-trash? boolean? use-trash? #f] [#:use-trash? boolean? use-trash? #f]
[#:from-command-line? from-command-line? boolean? #f] [#:from-command-line? from-command-line? boolean? #f])
[#:dry-run? dry-run? boolean? #f])
(or/c 'skip (or/c 'skip
#f #f
(listof (or/c path-string? (listof (or/c path-string?
@ -386,8 +381,7 @@ specific command-line flags for @command-ref{remove}.
The package lock must be held; see @racket[with-pkg-lock]. The package lock must be held; see @racket[with-pkg-lock].
@history[#:changed "6.1.1.6" @elem{Added the @racket[#:use-trash?] argument.} @history[#:changed "6.1.1.6" @elem{Added the @racket[#:use-trash?] argument.}]}
#:changed "6.4.0.14" @elem{Added the @racket[#:dry-run] argument.}]}
@defproc[(pkg-new [name path-string?]) @defproc[(pkg-new [name path-string?])
@ -425,8 +419,7 @@ The package lock must be held to allow reads; see
[#:quiet? quiet? boolean? #f] [#:quiet? quiet? boolean? #f]
[#:from-command-line? from-command-line? boolean? #f] [#:from-command-line? from-command-line? boolean? #f]
[#:strip strip (or/c #f 'source 'binary 'binary-lib) #f] [#:strip strip (or/c #f 'source 'binary 'binary-lib) #f]
[#:force-strip? force-string? boolean? #f] [#:force-strip? force-string? boolean? #f])
[#:dry-run? dry-run? boolean? #f])
(or/c 'skip (or/c 'skip
#f #f
(listof (or/c path-string? (listof (or/c path-string?
@ -438,9 +431,7 @@ Implements @racket[pkg-migrate-command]. The result is the same as for
If @racket[from-command-line?] is true, error messages may suggest If @racket[from-command-line?] is true, error messages may suggest
specific command-line flags for @command-ref{migrate}. specific command-line flags for @command-ref{migrate}.
The package lock must be held; see @racket[with-pkg-lock]. The package lock must be held; see @racket[with-pkg-lock].}
@history[#:changed "6.4.0.14" @elem{Added the @racket[#:dry-run] argument.}]}
@defproc[(pkg-catalog-show [names (listof string?)] @defproc[(pkg-catalog-show [names (listof string?)]

View File

@ -173,8 +173,8 @@ For example,
A package source is inferred to refer A package source is inferred to refer
to a directory only when it does not have a file-archive suffix, does to a directory only when it does not have a file-archive suffix, does
not match the grammar of a package name, and either starts with not match the grammar of a package name, and either starts with starts
@litchar{file://} or does not start with @litchar{file://} or does not start
with alphabetic characters followed by @litchar{://}. In the with alphabetic characters followed by @litchar{://}. In the
case that the package source starts with @litchar{file://}, case that the package source starts with @litchar{file://},
it must be a URL without a @litchar{type} query or it must be a URL without a @litchar{type} query or
@ -596,9 +596,6 @@ sub-commands.
]} ]}
@item{@DFlag{dry-run} --- Prevents changes to the current installation. All installation and update work is
staged and checked, but the final installation step is skipped.}
@item{@DFlag{no-setup} --- Does not run @exec{raco setup} after installation. This behavior is also the case if the @item{@DFlag{no-setup} --- Does not run @exec{raco setup} after installation. This behavior is also the case if the
environment variable @envvar{PLT_PKG_NOSETUP} is set to any non-empty value.} environment variable @envvar{PLT_PKG_NOSETUP} is set to any non-empty value.}
@ -616,8 +613,7 @@ sub-commands.
@DFlag{multi-clone} flags.} @DFlag{multi-clone} flags.}
#:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag, and changed #:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag, and changed
the @DFlag{deps} default to depend only on interactive mode.} the @DFlag{deps} default to depend only on interactive mode.}
#:changed "6.1.1.8" @elem{Added the @DFlag{pull} flag.} #:changed "6.1.1.8" @elem{Added the @DFlag{pull} flag.}]}
#:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.}]}
@subcommand{@command/toc{update} @nonterm{option} ... @nonterm{pkg-source} ... @subcommand{@command/toc{update} @nonterm{option} ... @nonterm{pkg-source} ...
@ -727,7 +723,6 @@ the given @nonterm{pkg-source}s.
@item{@DFlag{pull} @nonterm{mode} --- Same as for @command-ref{install}} @item{@DFlag{pull} @nonterm{mode} --- Same as for @command-ref{install}}
@item{@DFlag{dry-run} --- Same as for @command-ref{install}.}
@item{@DFlag{no-setup} --- Same as for @command-ref{install}.} @item{@DFlag{no-setup} --- Same as for @command-ref{install}.}
@item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.} @item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.}
@item{@DFlag{batch} --- Same as for @command-ref{install}.} @item{@DFlag{batch} --- Same as for @command-ref{install}.}
@ -740,8 +735,7 @@ the given @nonterm{pkg-source}s.
when no arguments are provided.} when no arguments are provided.}
#:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag, and changed #:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag, and changed
the @DFlag{deps} default to depend only on interactive mode.} the @DFlag{deps} default to depend only on interactive mode.}
#:changed "6.1.1.8" @elem{Added the @DFlag{skip-uninstalled} and @DFlag{pull} flags.}] #:changed "6.1.1.8" @elem{Added the @DFlag{skip-uninstalled} and @DFlag{pull} flags.}]}
#:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.}}
@subcommand{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ... @subcommand{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ...
--- Attempts to remove the given packages. By default, if a package is the dependency --- Attempts to remove the given packages. By default, if a package is the dependency
@ -767,7 +761,6 @@ the given @nonterm{pkg}s.
@item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.} @item{@Flag{i} or @DFlag{installation} --- Shorthand for @exec{--scope installation}.}
@item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.} @item{@Flag{u} or @DFlag{user} --- Shorthand for @exec{--scope user}.}
@item{@DFlag{scope-dir} @nonterm{dir} --- Selects @nonterm{dir} as the @tech{package scope}, the same as for @command-ref{install}.} @item{@DFlag{scope-dir} @nonterm{dir} --- Selects @nonterm{dir} as the @tech{package scope}, the same as for @command-ref{install}.}
@item{@DFlag{dry-run} --- Same as for @command-ref{install}.}
@item{@DFlag{no-setup} --- Same as for @command-ref{install}.} @item{@DFlag{no-setup} --- Same as for @command-ref{install}.}
@item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.} @item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.}
@item{@DFlag{batch} --- Same as for @command-ref{install}.} @item{@DFlag{batch} --- Same as for @command-ref{install}.}
@ -775,8 +768,7 @@ the given @nonterm{pkg}s.
] ]
@history[#:changed "6.1.1.5" @elem{Added the @DFlag{batch} flag.} @history[#:changed "6.1.1.5" @elem{Added the @DFlag{batch} flag.}
#:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag.} #:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag.}]}
#:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.}]}
@subcommand{@command/toc{new} @nonterm{pkg} --- @subcommand{@command/toc{new} @nonterm{pkg} ---
@ -856,12 +848,10 @@ package is created.
@item{@DFlag{ignore-checksums} --- Same as for @command-ref{install}.} @item{@DFlag{ignore-checksums} --- Same as for @command-ref{install}.}
@item{@DFlag{strict-doc-conflicts} --- Same as for @command-ref{install}.} @item{@DFlag{strict-doc-conflicts} --- Same as for @command-ref{install}.}
@item{@DFlag{no-cache} --- Same as for @command-ref{install}.} @item{@DFlag{no-cache} --- Same as for @command-ref{install}.}
@item{@DFlag{dry-run} --- Same as for @command-ref{install}.}
@item{@DFlag{no-setup} --- Same as for @command-ref{install}.} @item{@DFlag{no-setup} --- Same as for @command-ref{install}.}
@item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.} @item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.}
] ]
}
@history[#:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.}]}
@subcommand{@command/toc{create} @nonterm{option} ... @nonterm{directory-or-package} @subcommand{@command/toc{create} @nonterm{option} ... @nonterm{directory-or-package}
--- Bundles a package into an archive. Bundling --- Bundles a package into an archive. Bundling

View File

@ -11,17 +11,11 @@ computation in this sense is @emph{not} atomic with respect to other
@tech[#:doc reference.scrbl]{places}, but only to other @tech[#:doc @tech[#:doc reference.scrbl]{places}, but only to other @tech[#:doc
reference.scrbl]{threads} within a place. reference.scrbl]{threads} within a place.
@elemtag["atomic-unsafe"]{Atomic mode is @bold{unsafe}}, because the Atomic mode is unsafe, because the Racket scheduler is not able to
Racket scheduler is not able to operate while execution is in atomic operate while execution is in atomic mode; the scheduler cannot switch
mode; the scheduler cannot switch threads or poll certain kinds of threads or poll certain kinds of events, which can lead to deadlock or
events, which can lead to deadlock or starvation of other threads. starvation of other threads. Beware that many operations can involve
Beware that many operations can involve such synchronization, such as such synchronization, such as writing to an output port.
writing to an output port. Even if an output target is known to be
free of synchronization, beware that values can have arbitrary
printing procedures attached through @racket[prop:custom-write].
Successful use of atomic mode requires a detailed knowledge of any
implementation that might be reached during atomic mode to ensure that
it terminates and does not involve synchronization.
@deftogether[( @deftogether[(
@defproc[(start-atomic) void?] @defproc[(start-atomic) void?]
@ -57,9 +51,7 @@ Using @racket[call-as-atomic] is somewhat safer than using
exiting atomic mode, and it wraps any call to the error value exiting atomic mode, and it wraps any call to the error value
conversion handler with @racket[call-as-nonatomic]. The latter is safe conversion handler with @racket[call-as-nonatomic]. The latter is safe
for a particular atomic region, however, only if the region can be for a particular atomic region, however, only if the region can be
safely interrupted by a non-atomic exception construction. safely interrupted by a non-atomic exception construction.}
See also the caveat that @elemref["atomic-unsafe"]{atomic mode is unsafe}.}
@deftogether[( @deftogether[(
@ -90,7 +82,11 @@ re-raised after exiting atomic mode. Any call to the current
@tech[#:doc reference.scrbl]{error value conversion handler} is @tech[#:doc reference.scrbl]{error value conversion handler} is
effectively wrapped with @racket[call-as-nonatomic]. effectively wrapped with @racket[call-as-nonatomic].
See also the caveat that @elemref["atomic-unsafe"]{atomic mode is unsafe}.} Besides obvious paths to unknown expressions that may not be safe for
atomic mode, beware of printing an arbitrary value in any way other
than the error value conversion handler, because values can have
arbitrary printing procedures attached through
@racket[prop:custom-write].}
@defproc[(call-as-nonatomic [thunk (-> any)]) any]{ @defproc[(call-as-nonatomic [thunk (-> any)]) any]{

View File

@ -26,16 +26,11 @@ internal representation of @racket[vec].}
Returns a pointer to an array of @racket[_double] values, which is the Returns a pointer to an array of @racket[_double] values, which is the
internal representation of @racket[flvec].} internal representation of @racket[flvec].}
@defproc*[([(saved-errno) exact-integer?] @defproc[(saved-errno) exact-integer?]{
[(saved-errno [new-value exact-integer?]) void?])]{
Returns or sets the error code saved for the current Racket Returns the value most recently saved (in the current thread) after a
thread. The saved error code is set after a foreign call with a foreign call with a non-@racket[#f] @racket[#:save-errno] option (see
non-@racket[#f] @racket[#:save-errno] option (see @racket[_fun] and @racket[_fun] and @racket[_cprocedure]).}
@racket[_cprocedure]), but it can also be set explicitly (for example,
to create mock foreign functions for testing).
@history[#:changed "6.4.0.9"]{Added the one-argument variant.}}
@defproc[(lookup-errno [sym (or/c 'EINTR 'EEXIST 'EAGAIN)]) @defproc[(lookup-errno [sym (or/c 'EINTR 'EEXIST 'EAGAIN)])
exact-integer?]{ exact-integer?]{

View File

@ -233,7 +233,7 @@ see @|InsideRacket|.
ctype?) ctype?)
@#,elem{absent}] @#,elem{absent}]
[cptr cpointer? @#,elem{absent}] [cptr cpointer? @#,elem{absent}]
[mode (one-of/c 'raw 'atomic 'nonatomic 'tagged [mode (one-of/c 'raw 'atomic 'nonatomic
'atomic-interior 'interior 'atomic-interior 'interior
'stubborn 'uncollectable 'eternal) 'stubborn 'uncollectable 'eternal)
@#,elem{absent}] @#,elem{absent}]
@ -266,8 +266,6 @@ specification is required at minimum:
what allocation function to use. It should be one of what allocation function to use. It should be one of
@indexed-racket['nonatomic] (uses @cpp{scheme_malloc} from @indexed-racket['nonatomic] (uses @cpp{scheme_malloc} from
Racket's C API), @indexed-racket['atomic] Racket's C API), @indexed-racket['atomic]
(@cpp{scheme_malloc_atomic}), @indexed-racket['tagged]
(@cpp{scheme_malloc_tagged}), @indexed-racket['atomic]
(@cpp{scheme_malloc_atomic}), @indexed-racket['stubborn] (@cpp{scheme_malloc_atomic}), @indexed-racket['stubborn]
(@cpp{scheme_malloc_stubborn}), @indexed-racket['uncollectable] (@cpp{scheme_malloc_stubborn}), @indexed-racket['uncollectable]
(@cpp{scheme_malloc_uncollectable}), @indexed-racket['eternal] (@cpp{scheme_malloc_uncollectable}), @indexed-racket['eternal]
@ -284,9 +282,7 @@ specification is required at minimum:
If no mode is specified, then @racket['nonatomic] allocation is used If no mode is specified, then @racket['nonatomic] allocation is used
when the type is a @racket[_gcpointer]- or @racket[_scheme]-based when the type is a @racket[_gcpointer]- or @racket[_scheme]-based
type, and @racket['atomic] allocation is used otherwise. type, and @racket['atomic] allocation is used otherwise.}
@history[#:changed "6.4.0.10" @elem{Added the @racket['tagged] allocation mode.}]}
@defproc[(free [cptr cpointer?]) void]{ @defproc[(free [cptr cpointer?]) void]{

View File

@ -1055,7 +1055,7 @@ members.}
@defproc[(_list-struct [#:alignment alignment (or/c #f 1 2 4 8 16) #f] @defproc[(_list-struct [#:alignment alignment (or/c #f 1 2 4 8 16) #f]
[#:malloc-mode malloc-mode [#:malloc-mode malloc-mode
(one-of/c 'raw 'atomic 'nonatomic 'tagged (one-of/c 'raw 'atomic 'nonatomic
'atomic-interior 'interior 'atomic-interior 'interior
'stubborn 'uncollectable 'eternal) 'stubborn 'uncollectable 'eternal)
'atomic] 'atomic]
@ -1085,7 +1085,7 @@ below for a more efficient approach.
#:define-unsafe)] #:define-unsafe)]
#:contracts ([offset-expr exact-integer?] #:contracts ([offset-expr exact-integer?]
[alignment-expr (or/c #f 1 2 4 8 16)] [alignment-expr (or/c #f 1 2 4 8 16)]
[malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic 'tagged [malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic
'atomic-interior 'interior 'atomic-interior 'interior
'stubborn 'uncollectable 'eternal)] 'stubborn 'uncollectable 'eternal)]
[prop-expr struct-type-property?])]{ [prop-expr struct-type-property?])]{

View File

@ -1,7 +1,6 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual scribble/eval "utils.rkt" @(require scribble/manual scribble/eval "utils.rkt"
(for-label racket/base (for-label racket/contract))
racket/contract))
@title[#:tag "contract-boundaries"]{Contracts and Boundaries} @title[#:tag "contract-boundaries"]{Contracts and Boundaries}

View File

@ -404,13 +404,10 @@ the contract so that error messages become intelligible:
@interaction[#:eval @interaction[#:eval
contract-eval contract-eval
(module improved-bank-server racket (module improved-bank-server racket
(provide (define (amount? x) (and (number? x) (integer? x) (>= x 0)))
(contract-out (define amount (flat-named-contract 'amount amount?))
[deposit (-> (flat-named-contract
'amount (provide (contract-out [deposit (amount . -> . any)]))
(λ (x)
(and (number? x) (integer? x) (>= x 0))))
any)]))
(define total 0) (define total 0)
(define (deposit a) (set! total (+ a total))))] (define (deposit a) (set! total (+ a total))))]

View File

@ -55,7 +55,7 @@ popular among Racketeers as well.
name @tt{geiser}.} name @tt{geiser}.}
@item{Emacs ships with a major mode for Scheme, @tt{scheme-mode}, @item{Emacs ships with a major mode for Scheme, @tt{scheme-mode},
that while not as featureful as the above options, but works that while not as featureful as the above options, works
reasonably well for editing Racket code. However, this mode reasonably well for editing Racket code. However, this mode
does not provide support for Racket-specific forms.} does not provide support for Racket-specific forms.}

View File

@ -387,7 +387,7 @@ definition
At the same time, @racket[define-cbr] needs to define @racket[do-f] At the same time, @racket[define-cbr] needs to define @racket[do-f]
using the body of @racket[f], this second part is slightly more using the body of @racket[f], this second part is slightly more
complex, so we defer most of it to a @racket[define-for-cbr] helper complex, so we defer most it to a @racket[define-for-cbr] helper
module, which lets us write @racket[define-cbr] easily enough: module, which lets us write @racket[define-cbr] easily enough:

View File

@ -67,8 +67,13 @@ to the same binding:
(free-identifier=? #'car #'car) (free-identifier=? #'car #'car)
(require (only-in racket/base [car also-car])) (require (only-in racket/base [car also-car]))
(free-identifier=? #'car #'also-car) (free-identifier=? #'car #'also-car)
(free-identifier=? #'car (let ([car 8])
#'car))
] ]
The last example above, in particular, illustrates how syntax objects
preserve lexical-context information.
To see the lists, symbols, numbers, @|etc| within a syntax object, use To see the lists, symbols, numbers, @|etc| within a syntax object, use
@racket[syntax->datum]: @racket[syntax->datum]:

View File

@ -5,8 +5,6 @@
@title[#:tag "hash-reader"]{Reader Extensions} @title[#:tag "hash-reader"]{Reader Extensions}
@refdetails["parse-reader"]{reader extensions}
The @tech{reader} layer of the Racket language can be extended through The @tech{reader} layer of the Racket language can be extended through
the @racketmetafont{#reader} form. A reader extension is implemented the @racketmetafont{#reader} form. A reader extension is implemented
as a module that is named after @racketmetafont{#reader}. The module as a module that is named after @racketmetafont{#reader}. The module

View File

@ -11,8 +11,7 @@
The Racket run-time system can be embedded into a larger program. The The Racket run-time system can be embedded into a larger program. The
embedding process for Racket CGC or Racket 3m (see @secref[cgc-v-3m]) embedding process for Racket CGC or Racket 3m (see @secref[cgc-v-3m])
is essentially the same, but the process for Racket 3m is most easily is essentially the same, but the process for Racket 3m is most easily
understood as a variant of the process for Racket CGC (even though understood as a variant of the process for Racket CGC.
Racket 3m is the standard variant of Racket).
@section{CGC Embedding} @section{CGC Embedding}
@ -182,7 +181,6 @@ static int run(Scheme_Env *e, int argc, char *argv[])
{ {
Scheme_Object *curout; Scheme_Object *curout;
int i; int i;
Scheme_Thread *th;
mz_jmp_buf * volatile save, fresh; mz_jmp_buf * volatile save, fresh;
/* Declare embedded modules in "base.c": */ /* Declare embedded modules in "base.c": */
@ -193,13 +191,11 @@ static int run(Scheme_Env *e, int argc, char *argv[])
curout = scheme_get_param(scheme_current_config(), curout = scheme_get_param(scheme_current_config(),
MZCONFIG_OUTPUT_PORT); MZCONFIG_OUTPUT_PORT);
th = scheme_get_current_thread();
for (i = 1; i < argc; i++) { for (i = 1; i < argc; i++) {
save = th->error_buf; save = scheme_current_thread->error_buf;
th->error_buf = &fresh; scheme_current_thread->error_buf = &fresh;
if (scheme_setjmp(*th->error_buf)) { if (scheme_setjmp(scheme_error_buf)) {
th->error_buf = save; scheme_current_thread->error_buf = save;
return -1; /* There was an error */ return -1; /* There was an error */
} else { } else {
Scheme_Object *v, *a[2]; Scheme_Object *v, *a[2];
@ -210,7 +206,7 @@ static int run(Scheme_Env *e, int argc, char *argv[])
a[0] = scheme_intern_symbol("racket/base"); a[0] = scheme_intern_symbol("racket/base");
a[1] = scheme_intern_symbol("read-eval-print-loop"); a[1] = scheme_intern_symbol("read-eval-print-loop");
scheme_apply(scheme_dynamic_require(2, a), 0, NULL); scheme_apply(scheme_dynamic_require(2, a), 0, NULL);
th->error_buf = save; scheme_current_thread->error_buf = save;
} }
} }
return 0; return 0;
@ -311,17 +307,15 @@ static int run(Scheme_Env *e, int argc, char *argv[])
Scheme_Object *curout = NULL, *v = NULL, *a[2] = {NULL, NULL}; Scheme_Object *curout = NULL, *v = NULL, *a[2] = {NULL, NULL};
Scheme_Config *config = NULL; Scheme_Config *config = NULL;
int i; int i;
Scheme_Thread *th = NULL;
mz_jmp_buf * volatile save = NULL, fresh; mz_jmp_buf * volatile save = NULL, fresh;
MZ_GC_DECL_REG(9); MZ_GC_DECL_REG(8);
MZ_GC_VAR_IN_REG(0, e); MZ_GC_VAR_IN_REG(0, e);
MZ_GC_VAR_IN_REG(1, curout); MZ_GC_VAR_IN_REG(1, curout);
MZ_GC_VAR_IN_REG(2, save); MZ_GC_VAR_IN_REG(2, save);
MZ_GC_VAR_IN_REG(3, config); MZ_GC_VAR_IN_REG(3, config);
MZ_GC_VAR_IN_REG(4, v); MZ_GC_VAR_IN_REG(4, v);
MZ_GC_VAR_IN_REG(5, th); MZ_GC_ARRAY_VAR_IN_REG(5, a, 2);
MZ_GC_ARRAY_VAR_IN_REG(6, a, 2);
MZ_GC_REG(); MZ_GC_REG();
@ -333,13 +327,11 @@ static int run(Scheme_Env *e, int argc, char *argv[])
config = scheme_current_config(); config = scheme_current_config();
curout = scheme_get_param(config, MZCONFIG_OUTPUT_PORT); curout = scheme_get_param(config, MZCONFIG_OUTPUT_PORT);
th = scheme_get_current_thread();
for (i = 1; i < argc; i++) { for (i = 1; i < argc; i++) {
save = th->error_buf; save = scheme_current_thread->error_buf;
th->error_buf = &fresh; scheme_current_thread->error_buf = &fresh;
if (scheme_setjmp(*th->error_buf)) { if (scheme_setjmp(scheme_error_buf)) {
th->error_buf = save; scheme_current_thread->error_buf = save;
return -1; /* There was an error */ return -1; /* There was an error */
} else { } else {
v = scheme_eval_string(argv[i], e); v = scheme_eval_string(argv[i], e);
@ -351,7 +343,7 @@ static int run(Scheme_Env *e, int argc, char *argv[])
a[1] = scheme_intern_symbol("read-eval-print-loop"); a[1] = scheme_intern_symbol("read-eval-print-loop");
v = scheme_dynamic_require(2, a); v = scheme_dynamic_require(2, a);
scheme_apply(v, 0, NULL); scheme_apply(v, 0, NULL);
th->error_buf = save; scheme_current_thread->error_buf = save;
} }
} }

View File

@ -206,7 +206,7 @@ which case the @DFlag{xform} step should be skipped.
To create an extension that behaves as a module, return a symbol from To create an extension that behaves as a module, return a symbol from
@cpp{scheme_module_name}, and have @cpp{scheme_initialize} and @cpp{scheme_module_name}, and have @cpp{scheme_initialize} and
@cpp{scheme_reload} declare a module using @cpp{scheme_primitive_module}. @cpp{scheme_rename} declare a module using @cpp{scheme_primitive_module}.
For example, the following extension implements a module named For example, the following extension implements a module named
@racket[hello] that exports a binding @racket[greeting]: @racket[hello] that exports a binding @racket[greeting]:

View File

@ -1130,49 +1130,6 @@ moved before it is fixed. With other implementations, an object might
be moved after the fixup process, and the result is the location that be moved after the fixup process, and the result is the location that
the object will have after garbage collection finished.} the object will have after garbage collection finished.}
@function[(void scheme_register_type_gc_shape [short type]
[intptr_t* shape])]{
Like @cpp{GC_register_traversers}, but using a set of predefined
functions that interpret @var{shape} to traverse a value. The
@var{shape} array is a sequence of commands terminated with
@cpp{SCHEME_GC_SHAPE_TERM}, where each command has a single argument.
Commands:
@itemlist[
@item{@tt{#define @cppdef{SCHEME_GC_SHAPE_TERM} 0} --- the terminator
command, which has no argument.}
@item{@tt{#define @cppdef{SCHEME_GC_SHAPE_PTR_OFFSET} 1} ---
specifies that a object tagged with @var{type} has a pointer
to be made visible to the garbage collector, where the command
argument is the offset from the beginning of the object.}
@item{@tt{#define @cppdef{SCHEME_GC_SHAPE_ADD_SIZE} 2} --- specifies
the allocated size of an object tagged with @var{type},
where the command argument is an amount to add to an
accumulated size; currently, size information is not used, but
it may be needed with future implementations of the garbage
collector.}
]
To improve forward compatibility, any other command is assumed to take
a single argument and is ignored.
A GC-shape registration is place-specific, even though
@cpp{scheme_make_type} creates a type tag that spans places. If a
traversal is already installed for @cpp{type} in the current place,
the old traversal specification is replaced. The
@cpp{scheme_register_type_gc_shape} function keeps its own copy of the
array @var{shape}, so the array need not be retained.
@history[#:added "6.4.0.10"]}
@function[(Scheme_Object* scheme_add_gc_callback [Scheme_Object* pre_desc] @function[(Scheme_Object* scheme_add_gc_callback [Scheme_Object* pre_desc]
[Scheme_Object* post_desc])]{ [Scheme_Object* post_desc])]{

View File

@ -364,12 +364,10 @@ any place.}
[void* val])]{ [void* val])]{
Gets or sets a value in a process-global table (i.e., shared across Gets or sets a value in a process-global table (i.e., shared across
multiple places, if any). If @var{val} is @cpp{NULL}, the current mapping multiple places, if any). If @var{val} is NULL, the current mapping
for @var{key} is given. If @var{val} is not @cpp{NULL}, and no value has been for @var{key} is given, otherwise @var{val} is installed as the value
installed for that @var{key}, then the value is installed and @cpp{NULL} is returned. If a for @var{key} and @cpp{NULL} is returned. The given @var{val} must not
value has already been installed, then no new value is installed and the old refer to garbage-collected memory.
value is returned. The given @var{val} must not refer to garbage-collected
memory.
This function is intended for infrequent use with a small number of This function is intended for infrequent use with a small number of
keys.} keys.}

View File

@ -9,8 +9,7 @@ Racket thread; all other threads are created through calls to
Information about each internal Racket thread is kept in a Information about each internal Racket thread is kept in a
@cppi{Scheme_Thread} structure. A pointer to the current thread's @cppi{Scheme_Thread} structure. A pointer to the current thread's
structure is available as @cppdef{scheme_current_thread} or structure is available as @cppi{scheme_current_thread}. A
from @cppi{scheme_get_current_thread}. A
@cpp{Scheme_Thread} structure includes the following fields: @cpp{Scheme_Thread} structure includes the following fields:
@itemize[ @itemize[
@ -379,12 +378,6 @@ The following function @cpp{mzsleep} is an appropriate
@section{Thread Functions} @section{Thread Functions}
@function[(Scheme_Thread* scheme_get_current_thread)]{
Returns the currently executing thread. The result is equivalent to
@cppi{scheme_current_thread}, but the function form must be used in
some embedding contexts.}
@function[(Scheme_Object* scheme_thread @function[(Scheme_Object* scheme_thread
[Scheme_Object* thunk])]{ [Scheme_Object* thunk])]{

View File

@ -296,9 +296,6 @@ There are six global constants:
] ]
In some embedding contexts, the function forms
@cppi{scheme_make_null}, etc., must be used, instead.
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@section[#:tag "im:strings"]{Strings} @section[#:tag "im:strings"]{Strings}
@ -328,31 +325,6 @@ For more fine-grained control over UTF-8 encoding, use the
@section{Value Functions} @section{Value Functions}
@function[(Scheme_Object* scheme_make_null)]{
Returns @cppi{scheme_null}.
}
@function[(Scheme_Object* scheme_make_eof)]{
Returns @cppi{scheme_eof}.
}
@function[(Scheme_Object* scheme_make_true)]{
Returns @cppi{scheme_true}.
}
@function[(Scheme_Object* scheme_make_false)]{
Returns @cppi{scheme_false}.
}
@function[(Scheme_Object* scheme_make_void)]{
Returns @cppi{scheme_void}.
}
@function[(Scheme_Object* scheme_make_char @function[(Scheme_Object* scheme_make_char
[mzchar ch])]{ [mzchar ch])]{

View File

@ -24,31 +24,3 @@ Normally, @nonterm{dir} is a relative path, and files are found at run
time in @nonterm{dir} relative to the executable, but a separate path time in @nonterm{dir} relative to the executable, but a separate path
(usually relative) for run time can be specified with (usually relative) for run time can be specified with
@DFlag{runtime-access}. @DFlag{runtime-access}.
Typically, @exec{raco ctool --c-mods} is used with @DPFlag{lib} to
specify a collection-based module path. For example,
@commandline{raco ctool --c-mods base.c ++lib racket/base}
generates a @filepath{base.c} whose @tt{declare_modules} function
makes @racketmodname[racket/base] available for use via the
@tt{scheme_namespace_require} or @tt{scheme_dynamic_require} functions
within the embedding application.
When a module file is provided to @exec{raco ctool --c-mods}, then
@tt{declare_modules} declares a module with the symbolic name of the
module file. For example,
@commandline{raco ctool --c-mods base.c hello.rkt}
creates a @tt{declare_modules} that defines the module
@racket['hello], which could be required into the current namespace
with @racket[(namespace-require ''hello)] or similarly at the C level:
@verbatim[#:indent 2]{
p = scheme_make_pair(scheme_intern_symbol("quote"),
scheme_make_pair(scheme_intern_symbol("hello"),
scheme_make_null()));
scheme_namespace_require(p);
}

View File

@ -11,11 +11,10 @@
@title[#:tag "exe"]{@exec{raco exe}: Creating Stand-Alone Executables} @title[#:tag "exe"]{@exec{raco exe}: Creating Stand-Alone Executables}
@margin-note{To achieve a faster startup time, instead of trying @margin-note{Use a smaller base language to achieve a faster startup time such
@exec{raco exe}, use a smaller base language---such as as @racketmodfont{#lang} @racketmodname[racket/base] instead of
@racketmodfont{#lang} @racketmodname[racket/base] instead of @racketmodfont{#lang} @racketmodname[racket] rather than relying on @exec{raco
@racketmodfont{#lang} @racketmodname[racket]. Also, ensure that exe}.}
bytecode files are compiled by using @seclink["make"]{@exec{raco make}}.}
Compiled code produced by @exec{raco make} relies on Racket Compiled code produced by @exec{raco make} relies on Racket
executables to provide run-time support to the compiled code. However, executables to provide run-time support to the compiled code. However,
@ -89,11 +88,8 @@ The @exec{raco exe} command accepts the following command-line flags:
@item{@Flag{l} or @DFlag{launcher} --- create a @tech{launcher} (see @item{@Flag{l} or @DFlag{launcher} --- create a @tech{launcher} (see
@secref["launcher"]), instead of a stand-alone executable. Flags @secref["launcher"]), instead of a stand-alone executable. Flags
such as @DFlag{config-path}, @DFlag{collects-path}, and @DFlag{lib} such as @DFlag{config-path}, @DFlag{collects-path}, and
have no effect on launchers. Beware that the default command-line @DFlag{lib} have no effect on launchers.}
flags to build into the launcher prevent access to packages that
are installed in user scope; use @exec{--exf -U} to enable access
to user-scope packages from the launcher.}
@item{@DFlag{config-path} @nonterm{path} --- set @nonterm{path} @item{@DFlag{config-path} @nonterm{path} --- set @nonterm{path}
within the executable as the path to the @tech{configuration within the executable as the path to the @tech{configuration
@ -157,19 +153,19 @@ The @exec{raco exe} command accepts the following command-line flags:
in the executable, even if it is not referenced by the main program, in the executable, even if it is not referenced by the main program,
so that it is available via @racket[dynamic-require].} so that it is available via @racket[dynamic-require].}
@item{@DPFlag{exf} @nonterm{flag} --- provide the @nonterm{flag} @item{@DPFlag{exfl} @nonterm{flag} --- provide the @nonterm{flag}
command-line argument on startup to the embedded @exec{racket} or command-line argument on startup to the embedded @exec{racket} or
@exec{gracket}.} @exec{gracket}.}
@item{@DFlag{exf} @nonterm{flag} --- remove @nonterm{flag} from the @item{@DFlag{exfl} @nonterm{flag} --- remove @nonterm{flag} from the
command-line arguments to be provided on startup to the embedded command-line arguments to be provided on startup to the embedded
@exec{racket} or @exec{gracket}.} @exec{racket} or @exec{gracket}.}
@item{@DFlag{exf-clear} --- remove all command-line arguments to be @item{@DFlag{exfl-clear} --- remove all command-line arguments to be
provided on startup to the embedded @exec{racket} or provided on startup to the embedded @exec{racket} or
@exec{gracket}.} @exec{gracket}.}
@item{@DFlag{exf-show} --- show (without changing) the command-line @item{@DFlag{exfl-show} --- show (without changing) the command-line
arguments to be provided on startup to the embedded arguments to be provided on startup to the embedded
@exec{racket} or @exec{gracket}.} @exec{racket} or @exec{gracket}.}

View File

@ -8,8 +8,7 @@
racket/file racket/file
compiler/cm compiler/cm
compiler/cm-accomplice compiler/cm-accomplice
setup/parallel-build setup/parallel-build))
compiler/compilation-path))
@(define cm-eval (make-base-eval)) @(define cm-eval (make-base-eval))
@ -391,29 +390,6 @@ A parameter whose value is called for each file that is loaded and
@racket[#f], then the file is compiled as usual. The default is @racket[#f], then the file is compiled as usual. The default is
@racket[(lambda (x) #f)].} @racket[(lambda (x) #f)].}
@defparam[current-path->mode path->mode
(or/c #f (-> path? (and/c path? relative-path?)))
#:value #f]{
Used by @racket[make-compilation-manager-load/use-compiled-handler] and
@racket[make-caching-managed-compile-zo] to override @racket[use-compiled-file-paths]
for deciding where to write compiled @filepath{.zo} files. If it is @racket[#f],
then the first element of @racket[use-compiled-file-paths] is used. If it isn't
@racket[#f], then it is called with the original source file's location and its
result is treated the same as if it had been the first element of
@racket[use-compiled-file-paths].
Note that this parameter is not used by @racket[current-load/use-compiled]. So if
the parameter causes @filepath{.zo} files to be placed in different directories, then
the correct @filepath{.zo} file must still be communicated via @racket[use-compiled-file-paths],
and one way to do that is to override @racket[current-load/use-compiled] to delete
@filepath{.zo} files that would cause the wrong one to be chosen right before they are
loaded.
@history[#:added "6.4.0.14"]
}
@defproc[(file-stamp-in-collection [p path?]) (or/c (cons/c number? promise?) #f)]{ @defproc[(file-stamp-in-collection [p path?]) (or/c (cons/c number? promise?) #f)]{
Calls @racket[file-stamp-in-paths] with @racket[p] and Calls @racket[file-stamp-in-paths] with @racket[p] and
@racket[(current-library-collection-paths)].} @racket[(current-library-collection-paths)].}
@ -732,14 +708,14 @@ of @racket[modes] and @racket[roots].}
[#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)]) [#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)])
path?]{ path?]{
The same as @racket[get-compilation-dir+name], but returning only the first result.} The same as @racket[get-compilation-dir+home], but returning only the first result.}
@defproc[(get-compilation-bytecode-file [path path-string?] @defproc[(get-compilation-bytecode-file [path path-string?]
[#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)] [#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)]
[#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)]) [#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)])
path?]{ path?]{
The same as @racket[get-compilation-dir+name], but combines the The same as @racket[get-compilation-dir+home], but combines the
results and adds a @filepath{.zo} suffix to arrive at a bytecode file results and adds a @filepath{.zo} suffix to arrive at a bytecode file
path.} path.}

View File

@ -80,8 +80,8 @@ failed, and anything else to indicate it passed.}
Contracts in Racket are subdivided into three different categories: Contracts in Racket are subdivided into three different categories:
@; @;
@itemlist[@item{@deftech{Flat @tech{contracts}} can be fully checked immediately for @itemlist[@item{@deftech{Flat contract}s can be fully checked immediately for
a given value. These kinds of @tech{contracts} are essentially a given value. These kinds of contracts are essentially
predicate functions. Using @racket[flat-contract-predicate], predicate functions. Using @racket[flat-contract-predicate],
you can extract the predicate from an arbitrary flat contract; some you can extract the predicate from an arbitrary flat contract; some
flat contracts can be applied like functions, in which case flat contracts can be applied like functions, in which case
@ -93,7 +93,7 @@ Contracts in Racket are subdivided into three different categories:
cannot. cannot.
The function @racket[flat-contract?] recognizes a flat contract.} The function @racket[flat-contract?] recognizes a flat contract.}
@item{@deftech{Chaperone @tech{contracts}} are not always immediately @item{@deftech{Chaperone contracts} are not always immediately
checkable, but are guaranteed to not change any properties checkable, but are guaranteed to not change any properties
of any values that they check. That is, they may wrap of any values that they check. That is, they may wrap
a value in such a way that it signals contract violations a value in such a way that it signals contract violations
@ -103,18 +103,18 @@ Contracts in Racket are subdivided into three different categories:
that the value had before being wrapped by the contract that the value had before being wrapped by the contract
are preserved by the contract wrapper. are preserved by the contract wrapper.
All @tech{flat contracts} are also @tech{chaperone contracts} (but All flat contracts are also chaperone contracts (but
not vice-versa).} not vice-versa).}
@item{@deftech{Impersonator @tech{contracts}} do not provide any @item{@deftech{Impersonator contracts} do not provide any
guarantees about values they check. Impersonator contracts guarantees about values they check. Impersonator contracts
may hide properties of values, or even make them completely may hide properties of values, or even make them completely
opaque (e.g, @racket[new-∀/c]). opaque (e.g, @racket[new-∀/c]).
All @tech{contracts} are impersonator contracts.}] All contracts are impersonator contracts.}]
For more about this hierarchy, see the section ``@secref["chaperones"]'' For more about this hierarchy, see @tech{chaperones} and
as well as a research paper @cite{Strickland12} on chaperones, impersonators, a research paper on chaperones, impersonators, and how they can be used to
and how they can be used to implement contracts. implement contracts @cite{Strickland12}.
@history[#:changed "6.1.1.8" @list{Changed @racket[+nan.0] and @racket[+nan.f] to @history[#:changed "6.1.1.8" @list{Changed @racket[+nan.0] and @racket[+nan.f] to
be @racket[equal?]-based contracts.}] be @racket[equal?]-based contracts.}]
@ -130,7 +130,7 @@ and how they can be used to implement contracts.
[flat-contract flat-contract?] [flat-contract flat-contract?]
[generator (or/c #f (-> contract (-> int? any))) #f]) [generator (or/c #f (-> contract (-> int? any))) #f])
flat-contract?]{ flat-contract?]{
Produces a @tech{flat contract} like @racket[flat-contract], but with the name @racket[name]. Produces a contract like @racket[flat-contract], but with the name @racket[name].
For example, For example,
@racketblock[(define/contract i @racketblock[(define/contract i
@ -145,7 +145,7 @@ The generator argument adds a generator for the flat-named-contract. See
@defthing[any/c flat-contract?]{ @defthing[any/c flat-contract?]{
A @tech{flat contract} that accepts any value. A flat contract that accepts any value.
When using this contract as the result portion of a function contract, When using this contract as the result portion of a function contract,
consider using @racket[any] instead; using @racket[any] leads to consider using @racket[any] instead; using @racket[any] leads to
@ -160,8 +160,8 @@ A @tech{flat contract} that accepts no values.}
@defproc[(or/c [contract contract?] ...) @defproc[(or/c [contract contract?] ...)
contract?]{ contract?]{
Takes any number of @tech{contracts} and returns Takes any number of contracts and returns
a @tech{contract} that accepts any value that any one of the contracts a contract that accepts any value that any one of the contracts
accepts individually. accepts individually.
The @racket[or/c] result tests any value by applying the contracts in The @racket[or/c] result tests any value by applying the contracts in
@ -202,7 +202,7 @@ returns a @racket[list-contract?].
@defproc[(first-or/c [contract contract?] ...) @defproc[(first-or/c [contract contract?] ...)
contract?]{ contract?]{
Takes any number of @tech{contracts} and returns a @tech{contract} that Takes any number of contracts and returns a contract that
accepts any value that any one of the contracts accepts accepts any value that any one of the contracts accepts
individually. individually.
@ -243,7 +243,7 @@ returns a @racket[list-contract?].
@defproc[(and/c [contract contract?] ...) contract?]{ @defproc[(and/c [contract contract?] ...) contract?]{
Takes any number of @tech{contracts} and returns a @tech{contract} that Takes any number of contracts and returns a contract that
accepts any value that satisfies all of the contracts simultaneously. accepts any value that satisfies all of the contracts simultaneously.
If all of the arguments are procedures or @tech{flat contracts}, If all of the arguments are procedures or @tech{flat contracts},
@ -255,19 +255,19 @@ the contracts in order, from left to right.}
@defproc[(not/c [flat-contract flat-contract?]) flat-contract?]{ @defproc[(not/c [flat-contract flat-contract?]) flat-contract?]{
Accepts a @tech{flat contract} or a predicate and returns a @tech{flat contract} Accepts a flat contract or a predicate and returns a flat contract
that checks the inverse of the argument.} that checks the inverse of the argument.}
@defproc[(=/c [z real?]) flat-contract?]{ @defproc[(=/c [z real?]) flat-contract?]{
Returns a @tech{flat contract} that requires the input to be a number and Returns a flat contract that requires the input to be a number and
@racket[=] to @racket[z].} @racket[=] to @racket[z].}
@defproc[(</c [n real?]) flat-contract?]{ @defproc[(</c [n real?]) flat-contract?]{
Returns a @tech{flat contract} that requires the input to be a number and Returns a flat contract that requires the input to be a number and
@racket[<] than @racket[n].} @racket[<] than @racket[n].}
@ -283,7 +283,7 @@ Like @racket[</c], but for @racket[<=].}
Like @racket[</c], but for @racket[>=].} Like @racket[</c], but for @racket[>=].}
@defproc[(between/c [n real?] [m real?]) @defproc[(between/c [n real?] [m real?])
flat-contract?]{ Returns a @tech{flat contract} that requires the flat-contract?]{ Returns a flat contract that requires the
input to be a real number between @racket[n] and @racket[m] or equal to input to be a real number between @racket[n] and @racket[m] or equal to
one of them.} one of them.}
@ -292,41 +292,41 @@ An alias for @racket[between/c].}
@defproc[(integer-in [j exact-integer?] [k exact-integer?]) flat-contract?]{ @defproc[(integer-in [j exact-integer?] [k exact-integer?]) flat-contract?]{
Returns a @tech{flat contract} that requires the input to be an exact integer Returns a flat contract that requires the input to be an exact integer
between @racket[j] and @racket[k], inclusive.} between @racket[j] and @racket[k], inclusive.}
@defproc[(char-in [a char?] [b char?]) flat-contract?]{ @defproc[(char-in [a char?] [b char?]) flat-contract?]{
Returns a @tech{flat contract} that requires the input to be a character whose Returns a flat contract that requires the input to be a character whose
code point number is between the code point numbers of @racket[a] and code point number is between the code point numbers of @racket[a] and
@racket[b], inclusive.} @racket[b], inclusive.}
@defthing[natural-number/c flat-contract?]{ @defthing[natural-number/c flat-contract?]{
A @tech{flat contract} that requires the input to be an exact non-negative integer.} A flat contract that requires the input to be an exact non-negative integer.}
@defproc[(string-len/c [len real?]) flat-contract?]{ @defproc[(string-len/c [len real?]) flat-contract?]{
Returns a @tech{flat contract} that recognizes strings that have fewer than Returns a flat contract that recognizes strings that have fewer than
@racket[len] characters.} @racket[len] characters.}
@defthing[false/c flat-contract?]{ @defthing[false/c flat-contract?]{
An alias for @racket[#f] for backwards compatibility.} An alias @racket[#f] for backwards compatibility.}
@defthing[printable/c flat-contract?]{ @defthing[printable/c flat-contract?]{
A @tech{flat contract} that recognizes values that can be written out and A flat contract that recognizes values that can be written out and
read back in with @racket[write] and @racket[read].} read back in with @racket[write] and @racket[read].}
@defproc[(one-of/c [v any/c] ...+) flat-contract?]{ @defproc[(one-of/c [v any/c] ...+) flat-contract?]{
Accepts any number of atomic values and returns a @tech{flat contract} that Accepts any number of atomic values and returns a flat contract that
recognizes those values, using @racket[eqv?] as the comparison recognizes those values, using @racket[eqv?] as the comparison
predicate. For the purposes of @racket[one-of/c], atomic values are predicate. For the purposes of @racket[one-of/c], atomic values are
defined to be: @tech{characters}, @tech{symbols}, @tech{booleans}, defined to be: @tech{characters}, @tech{symbols}, @tech{booleans},
@ -341,7 +341,7 @@ it simply passes its arguments to @racket[or/c].
@defproc[(symbols [sym symbol?] ...+) flat-contract?]{ @defproc[(symbols [sym symbol?] ...+) flat-contract?]{
Accepts any number of symbols and returns a @tech{flat contract} that Accepts any number of symbols and returns a flat contract that
recognizes those symbols. recognizes those symbols.
This is a backwards compatibility constructor; it merely This is a backwards compatibility constructor; it merely
@ -352,22 +352,22 @@ passes its arguments to @racket[or/c].
[#:immutable immutable (or/c #t #f 'dont-care) 'dont-care] [#:immutable immutable (or/c #t #f 'dont-care) 'dont-care]
[#:flat? flat? boolean? #f]) [#:flat? flat? boolean? #f])
contract?]{ contract?]{
Returns a @tech{contract} that recognizes vectors. The elements of the vector must Returns a contract that recognizes vectors. The elements of the vector must
match @racket[c]. match @racket[c].
If the @racket[flat?] argument is @racket[#t], then the resulting contract is If the @racket[flat?] argument is @racket[#t], then the resulting contract is
a @tech{flat contract}, and the @racket[c] argument must also be a @tech{flat contract}. Such a flat contract, and the @racket[c] argument must also be a flat contract. Such
@tech{flat contracts} will be unsound if applied to mutable vectors, as they will not flat contracts will be unsound if applied to mutable vectors, as they will not
check future operations on the vector. check future operations on the vector.
If the @racket[immutable] argument is @racket[#t] and the @racket[c] argument is If the @racket[immutable] argument is @racket[#t] and the @racket[c] argument is
a @tech{flat contract}, the result will be a @tech{flat contract}. If the @racket[c] argument a flat contract, the result will be a flat contract. If the @racket[c] argument
is a @tech{chaperone contract}, then the result will be a @tech{chaperone contract}. is a chaperone contract, then the result will be a chaperone contract.
When a higher-order @racket[vectorof] contract is applied to a vector, the result When a higher-order @racket[vectorof] contract is applied to a vector, the result
is not @racket[eq?] to the input. The result will be a copy for immutable vectors is not @racket[eq?] to the input. The result will be a copy for immutable vectors
and a @tech{chaperone} or @tech{impersonator} of the input for mutable vectors, and a @tech{chaperone} or @tech{impersonator} of the input for mutable vectors,
unless the @racket[c] argument is a @tech{flat contract} and the vector is immutable, unless the @racket[c] argument is a flat contract and the vector is immutable,
in which case the result is the original vector. in which case the result is the original vector.
@history[#:changed "6.3.0.5" @list{Changed flat vector contracts to not copy @history[#:changed "6.3.0.5" @list{Changed flat vector contracts to not copy
@ -376,24 +376,24 @@ in which case the result is the original vector.
@defproc[(vector-immutableof [c contract?]) contract?]{ @defproc[(vector-immutableof [c contract?]) contract?]{
Returns the same @tech{contract} as @racket[(vectorof c #:immutable #t)]. This form exists for Returns the same contract as @racket[(vectorof c #:immutable #t)]. This form exists for
backwards compatibility.} backwards compatibility.}
@defproc[(vector/c [c contract?] ... @defproc[(vector/c [c contract?] ...
[#:immutable immutable (or/c #t #f 'dont-care) 'dont-care] [#:immutable immutable (or/c #t #f 'dont-care) 'dont-care]
[#:flat? flat? boolean? #f]) [#:flat? flat? boolean? #f])
contract?]{ contract?]{
Returns a @tech{contract} that recognizes vectors whose lengths match the number of Returns a contract that recognizes vectors whose lengths match the number of
contracts given. Each element of the vector must match its corresponding contract. contracts given. Each element of the vector must match its corresponding contract.
If the @racket[flat?] argument is @racket[#t], then the resulting contract is If the @racket[flat?] argument is @racket[#t], then the resulting contract is
a @tech{flat contract}, and the @racket[c] arguments must also be @tech{flat contracts}. Such a flat contract, and the @racket[c] arguments must also be flat contracts. Such
@tech{flat contracts} will be unsound if applied to mutable vectors, as they will not flat contracts will be unsound if applied to mutable vectors, as they will not
check future operations on the vector. check future operations on the vector.
If the @racket[immutable] argument is @racket[#t] and the @racket[c] arguments are If the @racket[immutable] argument is @racket[#t] and the @racket[c] arguments are
@tech{flat contracts}, the result will be a @tech{flat contract}. If the @racket[c] arguments flat contracts, the result will be a flat contract. If the @racket[c] arguments
are @tech{chaperone contracts}, then the result will be a @tech{chaperone contract}. are chaperone contracts, then the result will be a chaperone contract.
When a higher-order @racket[vector/c] contract is applied to a vector, the result When a higher-order @racket[vector/c] contract is applied to a vector, the result
is not @racket[eq?] to the input. The result will be a copy for immutable vectors is not @racket[eq?] to the input. The result will be a copy for immutable vectors
@ -415,13 +415,13 @@ Returns a contract that recognizes boxes. The content of the box must match @rac
and mutations on mutable boxes must match @racket[in-c]. and mutations on mutable boxes must match @racket[in-c].
If the @racket[flat?] argument is @racket[#t], then the resulting contract is If the @racket[flat?] argument is @racket[#t], then the resulting contract is
a @tech{flat contract}, and the @racket[out] argument must also be a @tech{flat contract}. Such a flat contract, and the @racket[out] argument must also be a flat contract. Such
@tech{flat contracts} will be unsound if applied to mutable boxes, as they will not check flat contracts will be unsound if applied to mutable boxes, as they will not check
future operations on the box. future operations on the box.
If the @racket[immutable] argument is @racket[#t] and the @racket[c] argument is If the @racket[immutable] argument is @racket[#t] and the @racket[c] argument is
a @tech{flat contract}, the result will be a @tech{flat contract}. If the @racket[c] argument is a flat contract, the result will be a flat contract. If the @racket[c] argument is
a @tech{chaperone contract}, then the result will be a @tech{chaperone contract}. a chaperone contract, then the result will be a chaperone contract.
When a higher-order @racket[box/c] contract is applied to a box, the result When a higher-order @racket[box/c] contract is applied to a box, the result
is not @racket[eq?] to the input. The result will be a copy for immutable boxes is not @racket[eq?] to the input. The result will be a copy for immutable boxes
@ -469,14 +469,13 @@ a value, the result is not necessarily @racket[eq?] to the input.
(list)))] (list)))]
} }
@defproc[(list*of [ele-c contract?] [last-c contract? ele-c]) contract?]{ @defproc[(list*of [c contract?]) contract?]{
Returns a contract that recognizes improper lists whose elements match Returns a contract that recognizes improper lists whose elements match
the contract @racket[ele-c] and whose last position matches @racket[last-c]. the contract @racket[c]. If an improper list is created with @racket[cons],
If an improper list is created with @racket[cons], then its @racket[car] position is expected to match @racket[c] and
then its @racket[car] position is expected to match @racket[ele-c] and its @racket[cdr] position is expected to be @racket[(list*of c)]. Otherwise,
its @racket[cdr] position is expected to be @racket[(list*of ele-c list-c)]. Otherwise, it is expected to match @racket[c]. Beware that when this contract is applied to
it is expected to match @racket[last-c]. Beware that when this contract is applied to
a value, the result is not necessarily @racket[eq?] to the input. a value, the result is not necessarily @racket[eq?] to the input.
@examples[#:eval (contract-eval) #:once @examples[#:eval (contract-eval) #:once
@ -489,8 +488,7 @@ a value, the result is not necessarily @racket[eq?] to the input.
(list*of number?) (list*of number?)
(list 1 2 3)))] (list 1 2 3)))]
@history[#:added "6.1.1.1" @history[#:added "6.1.1.1"]
#:changed "6.4.0.4" @list{Added the @racket[last-c] argument.}]
} }
@ -552,33 +550,10 @@ each element of the list must match the corresponding contract. Beware
that when this contract is applied to a value, the result is not that when this contract is applied to a value, the result is not
necessarily @racket[eq?] to the input.} necessarily @racket[eq?] to the input.}
@defproc[(*list/c [prefix contract?] [suffix contract?] ...) list-contract?]{
Produces a contract for a list. The number of elements in the list
must be at least as long as the number of @racket[suffix] contracts
and the tail of the list must match those contracts, one for each
element. The beginning portion of the list can be arbitrarily long,
and each element must match @racket[prefix].
Beware that when this contract is applied to a value, the result is not
necessarily @racket[eq?] to the input.
@examples[#:eval (contract-eval) #:once
(define/contract a-list-of-numbers-ending-with-two-integers
(*list/c number? integer? integer?)
(list 1/2 4/5 +1i -11 322))
(eval:error
(define/contract not-enough-integers-at-the-end
(*list/c number? integer? integer? integer?)
(list 1/2 4/5 1/2 321 322)))]
}
@defproc[(syntax/c [c flat-contract?]) flat-contract?]{ @defproc[(syntax/c [c flat-contract?]) flat-contract?]{
Produces a @tech{flat contract} that recognizes syntax objects whose Produces a flat contract that recognizes syntax objects whose
@racket[syntax-e] content matches @racket[c].} @racket[syntax-e] content matches @racket[c].}
@ -587,11 +562,11 @@ Produces a contract that recognizes instances of the structure
type named by @racket[struct-id], and whose field values match the type named by @racket[struct-id], and whose field values match the
contracts produced by the @racket[contract-expr]s. contracts produced by the @racket[contract-expr]s.
Contracts for immutable fields must be either flat or @tech{chaperone contracts}. Contracts for immutable fields must be either flat or chaperone contracts.
Contracts for mutable fields may be impersonator contracts. Contracts for mutable fields may be impersonator contracts.
If all fields are immutable and the @racket[contract-expr]s evaluate If all fields are immutable and the @racket[contract-expr]s evaluate
to @tech{flat contracts}, a @tech{flat contract} is produced. If all the to flat contracts, a flat contract is produced. If all the
@racket[contract-expr]s are @tech{chaperone contracts}, a @tech{chaperone contract} is @racket[contract-expr]s are chaperone contracts, a chaperone contract is
produced. Otherwise, an impersonator contract is produced. produced. Otherwise, an impersonator contract is produced.
} }
@ -622,8 +597,8 @@ for the fields based on the values of the @racket[dep-field-name] fields (the
@racket[dep-field-name] syntax is the same as the @racket[field-name] syntax). @racket[dep-field-name] syntax is the same as the @racket[field-name] syntax).
If the field is a dependent field and no @racket[contract-type] annotation If the field is a dependent field and no @racket[contract-type] annotation
appears, then it is assumed that the contract is appears, then it is assumed that the contract is
a chaperone, but not always a @tech{flat contract} (and thus the entire @racket[struct/dc] a chaperone, but not always a flat contract (and thus the entire @racket[struct/dc]
contract is not a @tech{flat contract}). contract is not a flat contract).
If this is not the case, and the contract is If this is not the case, and the contract is
always flat then the field must be annotated with always flat then the field must be annotated with
the @racket[#:flat], or the field must be annotated with the @racket[#:flat], or the field must be annotated with
@ -651,11 +626,11 @@ If the @racket[#:inv] clause appears, then the invariant expression is
evaluated (and must return a non-@racket[#f] value) when the contract evaluated (and must return a non-@racket[#f] value) when the contract
is applied to a struct. is applied to a struct.
Contracts for immutable fields must be either flat or @tech{chaperone contracts}. Contracts for immutable fields must be either flat or chaperone contracts.
Contracts for mutable fields may be impersonator contracts. Contracts for mutable fields may be impersonator contracts.
If all fields are immutable and the @racket[contract-expr]s evaluate If all fields are immutable and the @racket[contract-expr]s evaluate
to @tech{flat contracts}, a @tech{flat contract} is produced. If all the to flat contracts, a flat contract is produced. If all the
@racket[contract-expr]s are @tech{chaperone contracts}, a @tech{chaperone contract} is @racket[contract-expr]s are chaperone contracts, a chaperone contract is
produced. Otherwise, an impersonator contract is produced. produced. Otherwise, an impersonator contract is produced.
As an example, the function @racket[bst/c] below As an example, the function @racket[bst/c] below
@ -731,15 +706,15 @@ There are a number of technicalities that control how @racket[hash/c] contracts
behave. behave.
@itemlist[@item{ @itemlist[@item{
If the @racket[flat?] argument is @racket[#t], then the resulting contract is If the @racket[flat?] argument is @racket[#t], then the resulting contract is
a @tech{flat contract}, and the @racket[key] and @racket[val] arguments must also be a flat contract, and the @racket[key] and @racket[val] arguments must also be flat
@tech{flat contracts}. contracts.
@examples[#:eval (contract-eval) #:once @examples[#:eval (contract-eval) #:once
(flat-contract? (hash/c integer? boolean?)) (flat-contract? (hash/c integer? boolean?))
(flat-contract? (hash/c integer? boolean? #:flat? #t)) (flat-contract? (hash/c integer? boolean? #:flat? #t))
(eval:error (hash/c integer? (-> integer? integer?) #:flat? #t))] (eval:error (hash/c integer? (-> integer? integer?) #:flat? #t))]
Such @tech{flat contracts} will be unsound if applied to mutable hash tables, Such flat contracts will be unsound if applied to mutable hash tables,
as they will not check future mutations to the hash table. as they will not check future mutations to the hash table.
@examples[#:eval (contract-eval) #:once @examples[#:eval (contract-eval) #:once
@ -823,8 +798,8 @@ for mutable hash tables.
Produces a contract that recognizes @tech{channel}s that communicate Produces a contract that recognizes @tech{channel}s that communicate
values as specified by the @racket[val] argument. values as specified by the @racket[val] argument.
If the @racket[val] argument is a @tech{chaperone contract}, then the resulting contract If the @racket[val] argument is a chaperone contract, then the resulting contract
is a @tech{chaperone contract}. Otherwise, the resulting contract is an impersonator is a chaperone contract. Otherwise, the resulting contract is an impersonator
contract. When a channel contract is applied to a channel, the resulting channel contract. When a channel contract is applied to a channel, the resulting channel
is not @racket[eq?] to the input. is not @racket[eq?] to the input.
@ -851,7 +826,7 @@ Each @racket[contract] will check the corresponding value passed to
an @racket[abort-current-continuation] and handled by the handler of a an @racket[abort-current-continuation] and handled by the handler of a
call to @racket[call-with-continuation-prompt]. call to @racket[call-with-continuation-prompt].
If all of the @racket[contract]s are @tech{chaperone contracts}, the resulting If all of the @racket[contract]s are chaperone contracts, the resulting
contract will also be a @tech{chaperone} contract. Otherwise, the contract is contract will also be a @tech{chaperone} contract. Otherwise, the contract is
an @tech{impersonator} contract. an @tech{impersonator} contract.
@ -882,7 +857,7 @@ Takes a single contract and returns a contract that recognizes
continuation marks and will check any mappings of marks to values continuation marks and will check any mappings of marks to values
or any accesses of the mark value. or any accesses of the mark value.
If the argument @racket[contract] is a @tech{chaperone contract}, the resulting If the argument @racket[contract] is a chaperone contract, the resulting
contract will also be a @tech{chaperone} contract. Otherwise, the contract is contract will also be a @tech{chaperone} contract. Otherwise, the contract is
an @tech{impersonator} contract. an @tech{impersonator} contract.
@ -907,7 +882,7 @@ Returns a contract that recognizes @tech{synchronizable event}s whose
@racket[contract]s. @racket[contract]s.
The resulting contract is always a @tech{chaperone} contract and its The resulting contract is always a @tech{chaperone} contract and its
arguments must all be @tech{chaperone contracts}. arguments must all be chaperone contracts.
@examples[#:eval (contract-eval) #:once @examples[#:eval (contract-eval) #:once
(define/contract my-evt (define/contract my-evt
@ -937,7 +912,7 @@ For example, the contract
symbol?) symbol?)
] ]
is a @tech{flat contract} that checks for (a limited form of) is a flat contract that checks for (a limited form of)
S-expressions. It says that a @racket[sexp] is either two S-expressions. It says that a @racket[sexp] is either two
@racket[sexp]s combined with @racket[cons], or a number, or a symbol. @racket[sexp]s combined with @racket[cons], or a number, or a symbol.
@ -948,7 +923,7 @@ checking will not terminate.}
@defform[(flat-murec-contract ([id flat-contract-expr ...] ...) body ...+)]{ @defform[(flat-murec-contract ([id flat-contract-expr ...] ...) body ...+)]{
A generalization of @racket[flat-rec-contract] for defining several A generalization of @racket[flat-rec-contract] for defining several
mutually recursive @tech{flat contracts} simultaneously. Each @racket[id] is mutually recursive flat contracts simultaneously. Each @racket[id] is
visible in the entire @racket[flat-murec-contract] form, and the visible in the entire @racket[flat-murec-contract] form, and the
result of the final @racket[body] is the result of the entire form.} result of the final @racket[body] is the result of the entire form.}
@ -971,38 +946,19 @@ Constructs a @tech{flat contract} from @racket[predicate]. A value
satisfies the contract if the predicate returns a true value. satisfies the contract if the predicate returns a true value.
This function is a holdover from before predicates could be used This function is a holdover from before predicates could be used
directly as @tech{flat contracts}. It exists today for backwards compatibility. directly as flat contracts. It exists today for backwards compatibility.
} }
@defproc[(flat-contract-predicate [v flat-contract?]) @defproc[(flat-contract-predicate [v flat-contract?])
(-> any/c any/c)]{ (-> any/c any/c)]{
Extracts the predicate from a @tech{flat contract}. Extracts the predicate from a flat contract.
This function is a holdover from before @tech{flat contracts} could be used This function is a holdover from before flat contracts could be used
directly as predicates. It exists today for backwards compatibility. directly as predicates. It exists today for backwards compatibility.
} }
@defproc[(suggest/c [c contract?]
[field string?]
[message string?]) contract?]{
Returns a contract that behaves like @racket[c], except
that it adds an extra line to the error message on a contract
violation.
The @racket[field] and @racket[message] strings are added
following the guidelines in
@secref["err-msg-conventions"].
@examples[#:eval (contract-eval) #:once
(define allow-calls? #f)
(define/contract (f)
(suggest/c (->* () #:pre allow-calls? any)
"suggestion" "maybe you should set! allow-calls? to #t")
5)
(eval:error (f))]
}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@ -1030,18 +986,13 @@ designed to match @racket[case-lambda] and
without requiring that the domain have any particular shape without requiring that the domain have any particular shape
(see below for an example use). (see below for an example use).
@(define lit-ellipsis (racket ...))
@defform*/subs[#:literals (any values) @defform*/subs[#:literals (any values)
[(-> dom ... range) [(-> dom ... range)]
(-> dom ... ellipsis dom-expr ... range)]
([dom dom-expr (code:line keyword dom-expr)] ([dom dom-expr (code:line keyword dom-expr)]
[range range-expr (values range-expr ...) any] [range range-expr (values range-expr ...) any])]{
[ellipsis #,lit-ellipsis])]{
Produces a contract for a function that accepts the argument Produces a contract for a function that accepts a fixed
specified by the @racket[dom-expr] contracts and returns number of arguments and returns either a fixed number of
either a fixed number of
results or completely unspecified results (the latter when results or completely unspecified results (the latter when
@racket[any] is specified). @racket[any] is specified).
@ -1049,13 +1000,6 @@ Each @racket[dom-expr] is a contract on an argument to a
function, and each @racket[range-expr] is a contract on a function, and each @racket[range-expr] is a contract on a
result of the function. result of the function.
If the domain contain @racket[...]
then the function accepts as many arguments as the rest of
the contracts in the domain portion specify, as well as
arbitrarily many more that match the contract just before the
@racket[...]. Otherwise, the contract accepts exactly the
argument specified.
@margin-note{Using a @racket[->] between two whitespace-delimited @margin-note{Using a @racket[->] between two whitespace-delimited
@racketparenfont{.}s is the same as putting the @racket[->] right @racketparenfont{.}s is the same as putting the @racket[->] right
after the enclosing opening parenthesis. See after the enclosing opening parenthesis. See
@ -1063,7 +1007,9 @@ after the enclosing opening parenthesis. See
information.} information.}
For example, For example,
@racketblock[(integer? boolean? . -> . integer?)] @racketblock[(integer? boolean? . -> . integer?)]
produces a contract on functions of two arguments. The first argument produces a contract on functions of two arguments. The first argument
must be an integer, and the second argument must be a boolean. The must be an integer, and the second argument must be a boolean. The
function must produce an integer. function must produce an integer.
@ -1072,16 +1018,12 @@ A domain specification may include a keyword. If so, the function must
accept corresponding (mandatory) keyword arguments, and the values for accept corresponding (mandatory) keyword arguments, and the values for
the keyword arguments must match the corresponding contracts. For the keyword arguments must match the corresponding contracts. For
example: example:
@racketblock[(integer? #:x boolean? . -> . integer?)] @racketblock[(integer? #:x boolean? . -> . integer?)]
is a contract on a function that accepts a by-position argument that is a contract on a function that accepts a by-position argument that
is an integer and a @racket[#:x] argument that is a boolean. is an integer and a @racket[#:x] argument that is a boolean.
As an example that uses an @racket[...], this contract:
@racketblock[(integer? string? ... integer? . -> . any)]
on a function insists that the first and last arguments to
the function must be integers (and there must be at least
two arguments) and any other arguments must be strings.
If @racket[any] is used as the last sub-form for @racket[->], no If @racket[any] is used as the last sub-form for @racket[->], no
contract checking is performed on the result of the function, and contract checking is performed on the result of the function, and
thus any number of values is legal (even different numbers on different thus any number of values is legal (even different numbers on different
@ -1089,10 +1031,7 @@ invocations of the function).
If @racket[(values range-expr ...)] is used as the last sub-form of If @racket[(values range-expr ...)] is used as the last sub-form of
@racket[->], the function must produce a result for each contract, and @racket[->], the function must produce a result for each contract, and
each value must match its respective contract. each value must match its respective contract.}
@history[#:changed "6.4.0.5" @list{Added support for ellipses}]
}
@defform*/subs[#:literals (any values) @defform*/subs[#:literals (any values)
@ -1206,9 +1145,9 @@ In other words, @racket[->i] expresses dependencies among arguments and results.
The optional first keyword argument to @racket[->i] indicates if the result The optional first keyword argument to @racket[->i] indicates if the result
contract will be a chaperone. If it is @racket[#:chaperone], all of the contract for the arguments contract will be a chaperone. If it is @racket[#:chaperone], all of the contract for the arguments
and results must be @tech{chaperone contracts} and the result of @racket[->i] will be and results must be chaperone contracts and the result of @racket[->i] will be
a @tech{chaperone contract}. If it is not present, then the result a chaperone contract. If it is not present, then the result
contract will not be a @tech{chaperone contract}. contract will not be a chaperone contract.
The first sub-form of a @racket[->i] contract covers the mandatory and the The first sub-form of a @racket[->i] contract covers the mandatory and the
second sub-form covers the optional arguments. Following that is an optional second sub-form covers the optional arguments. Following that is an optional
@ -2025,15 +1964,15 @@ accepted by the third argument to @racket[datum->syntax].
flat-contract?] flat-contract?]
)]{ )]{
These functions build simple higher-order contracts, @tech{chaperone contracts}, and @tech{flat contracts}, These functions build simple higher-order contracts, chaperone contracts, and flat contracts,
respectively. They both take the same set of three optional arguments: a name, respectively. They both take the same set of three optional arguments: a name,
a first-order predicate, and a blame-tracking projection. a first-order predicate, and a blame-tracking projection.
The @racket[name] argument is any value to be rendered using @racket[display] to The @racket[name] argument is any value to be rendered using @racket[display] to
describe the contract when a violation occurs. The default name for simple describe the contract when a violation occurs. The default name for simple
higher-order contracts is @racketresult[anonymous-contract], for higher-order contracts is @racketresult[anonymous-contract], for chaperone
@tech{chaperone contracts} is @racketresult[anonymous-chaperone-contract], and for contracts is @racketresult[anonymous-chaperone-contract], and for flat
@tech{flat contracts} is @racketresult[anonymous-flat-contract]. contracts is @racketresult[anonymous-flat-contract].
The first-order predicate @racket[test] can be used to determine which values The first-order predicate @racket[test] can be used to determine which values
the contract applies to; this must be the set of values for which the the contract applies to; this must be the set of values for which the
@ -2073,14 +2012,14 @@ The projection arguments (@racket[late-neg-proj], @racket[proj], and
In particular, if the test argument returns @racket[#f] for some value, In particular, if the test argument returns @racket[#f] for some value,
then the projections must raise a blame error for that value. then the projections must raise a blame error for that value.
Projections for @tech{chaperone contracts} must produce a value that passes Projections for chaperone contracts must produce a value that passes
@racket[chaperone-of?] when compared with the original, uncontracted value. @racket[chaperone-of?] when compared with the original, uncontracted value.
Projections for @tech{flat contracts} must fail precisely when the first-order test Projections for flat contracts must fail precisely when the first-order test
does, and must produce the input value unchanged otherwise. Applying a does, and must produce the input value unchanged otherwise. Applying a flat
@tech{flat contract} may result in either an application of the predicate, or the contract may result in either an application of the predicate, or the
projection, or both; therefore, the two must be consistent. The existence of a projection, or both; therefore, the two must be consistent. The existence of a
separate projection only serves to provide more specific error messages. Most separate projection only serves to provide more specific error messages. Most
@tech{flat contracts} do not need to supply an explicit projection. flat contracts do not need to supply an explicit projection.
The @racket[stronger] argument is used to implement @racket[contract-stronger?]. The The @racket[stronger] argument is used to implement @racket[contract-stronger?]. The
first argument is always the contract itself and the second argument is whatever first argument is always the contract itself and the second argument is whatever
@ -2151,23 +2090,23 @@ contracts. The error messages assume that the function named by
@defproc[(coerce-chaperone-contract [id symbol?] [x any/c]) chaperone-contract?]{ @defproc[(coerce-chaperone-contract [id symbol?] [x any/c]) chaperone-contract?]{
Like @racket[coerce-contract], but requires the result Like @racket[coerce-contract], but requires the result
to be a @tech{chaperone contract}, not an arbitrary contract. to be a chaperone contract, not an arbitrary contract.
} }
@defproc[(coerce-chaperone-contracts [id symbol?] [x (listof any/c)]) @defproc[(coerce-chaperone-contracts [id symbol?] [x (listof any/c)])
(listof chaperone-contract?)]{ (listof chaperone-contract?)]{
Like @racket[coerce-contracts], but requires the results Like @racket[coerce-contracts], but requires the results
to be @tech{chaperone contracts}, not arbitrary contracts. to be chaperone contracts, not arbitrary contracts.
} }
@defproc[(coerce-flat-contract [id symbol?] [x any/c]) flat-contract?]{ @defproc[(coerce-flat-contract [id symbol?] [x any/c]) flat-contract?]{
Like @racket[coerce-contract], but requires the result Like @racket[coerce-contract], but requires the result
to be a @tech{flat contract}, not an arbitrary contract. to be a flat contract, not an arbitrary contract.
} }
@defproc[(coerce-flat-contracts [id symbol?] [x (listof any/c)]) (listof flat-contract?)]{ @defproc[(coerce-flat-contracts [id symbol?] [x (listof any/c)]) (listof flat-contract?)]{
Like @racket[coerce-contracts], but requires the results Like @racket[coerce-contracts], but requires the results
to be @tech{flat contracts}, not arbitrary contracts. to be flat contracts, not arbitrary contracts.
} }
@defproc[(coerce-contract/f [x any/c]) (or/c contract? #f)]{ @defproc[(coerce-contract/f [x any/c]) (or/c contract? #f)]{
@ -2208,24 +2147,6 @@ contracts. The error messages assume that the function named by
functions, the wrapping (and thus the checks) are skipped. functions, the wrapping (and thus the checks) are skipped.
} }
@defform*[[(with-contract-continuation-mark blame body ...)
(with-contract-continuation-mark blame+neg-party body ...)]]{
Inserts a continuation mark that informs the contract profiler (see
@other-doc['(lib "contract-profile/scribblings/contract-profile")
#:indirect "contract profiling"])
that contract checking is happening.
For the costs from checking your new combinator to be included, you should wrap
any deferred, higher-order checks with this form. First-order checks are
recognized automatically and do not require this form.
If your combinator's projections operate on complete blame objects (i.e., no
missing blame parties), the blame object should be the first argument to this
form. Otherwise (e.g., in the case of @racket[_late-neg] projections), a pair
of the blame object and the negative party should be used instead.
@history[#:added "6.4.0.4"]
}
@subsection{Blame Objects} @subsection{Blame Objects}
@defproc[(blame? [x any/c]) boolean?]{ @defproc[(blame? [x any/c]) boolean?]{
@ -2425,12 +2346,12 @@ the message that indicates the violation.
@para{ @para{
The property @racket[prop:contract] allows arbitrary structures to act as The property @racket[prop:contract] allows arbitrary structures to act as
contracts. The property @racket[prop:chaperone-contract] allows arbitrary contracts. The property @racket[prop:chaperone-contract] allows arbitrary
structures to act as @tech{chaperone contracts}; @racket[prop:chaperone-contract] structures to act as chaperone contracts; @racket[prop:chaperone-contract]
inherits @racket[prop:contract], so @tech{chaperone contract} structures may also act inherits @racket[prop:contract], so chaperone contract structures may also act
as general contracts. The property @racket[prop:flat-contract] allows arbitrary structures as general contracts. The property @racket[prop:flat-contract] allows arbitrary structures
to act as @tech{flat contracts}; @racket[prop:flat-contract] inherits both to act as flat contracts; @racket[prop:flat-contract] inherits both
@racket[prop:chaperone-contract] and @racket[prop:procedure], so @tech{flat contract} structures @racket[prop:chaperone-contract] and @racket[prop:procedure], so flat contract structures
may also act as @tech{chaperone contracts}, as general contracts, and as predicate procedures. may also act as chaperone contracts, as general contracts, and as predicate procedures.
} }
@deftogether[( @deftogether[(
@ -2438,7 +2359,7 @@ may also act as @tech{chaperone contracts}, as general contracts, and as predica
@defthing[prop:chaperone-contract struct-type-property?] @defthing[prop:chaperone-contract struct-type-property?]
@defthing[prop:flat-contract struct-type-property?] @defthing[prop:flat-contract struct-type-property?]
)]{ )]{
These properties declare structures to be contracts or @tech{flat contracts}, These properties declare structures to be contracts or flat contracts,
respectively. The value for @racket[prop:contract] must be a @tech{contract respectively. The value for @racket[prop:contract] must be a @tech{contract
property} constructed by @racket[build-contract-property]; likewise, the value property} constructed by @racket[build-contract-property]; likewise, the value
for @racket[prop:chaperone-contract] must be a @tech{chaperone contract property} for @racket[prop:chaperone-contract] must be a @tech{chaperone contract property}
@ -2683,7 +2604,7 @@ projection accessor must return a value that passes @racket[chaperone-of?] when
compared with the original, uncontracted value. compared with the original, uncontracted value.
A @deftech{flat contract property} specifies the behavior of a structure when A @deftech{flat contract property} specifies the behavior of a structure when
used as a @tech{flat contract}. It is specified using used as a flat contract. It is specified using
@racket[build-flat-contract-property], and accepts exactly the same set of @racket[build-flat-contract-property], and accepts exactly the same set of
arguments as @racket[build-contract-property]. The only difference is that the arguments as @racket[build-contract-property]. The only difference is that the
projection accessor is expected not to wrap its argument in a higher-order projection accessor is expected not to wrap its argument in a higher-order
@ -2854,22 +2775,20 @@ higher-order contracts.
@defproc[(contract? [v any/c]) boolean?]{ @defproc[(contract? [v any/c]) boolean?]{
Returns @racket[#t] if its argument is a @tech{contract} (i.e., constructed Returns @racket[#t] if its argument is a contract (i.e., constructed
with one of the combinators described in this section or a value that with one of the combinators described in this section or a value that
can be used as a contract) and @racket[#f] otherwise.} can be used as a contract) and @racket[#f] otherwise.}
@defproc[(chaperone-contract? [v any/c]) boolean?]{ @defproc[(chaperone-contract? [v any/c]) boolean?]{
Returns @racket[#t] if its argument is a @tech{chaperone contract}, Returns @racket[#t] if its argument is a contract that guarantees that
i.e., one that guarantees that
it returns a value which passes @racket[chaperone-of?] when compared to it returns a value which passes @racket[chaperone-of?] when compared to
the original, uncontracted value.} the original, uncontracted value.}
@defproc[(impersonator-contract? [v any/c]) boolean?]{ @defproc[(impersonator-contract? [v any/c]) boolean?]{
Returns @racket[#t] if its argument is an @tech{impersonator contract}, Returns @racket[#t] if its argument is a contract that is not a chaperone
i.e., a @tech{contract} that is neither a @tech{chaperone contract} contract nor a flat contract.}
nor a @tech{flat contract}.}
@defproc[(flat-contract? [v any/c]) boolean?]{ @defproc[(flat-contract? [v any/c]) boolean?]{
@ -2877,10 +2796,10 @@ Returns @racket[#t] when its argument is a contract that can be
checked immediately (unlike, say, a function contract). checked immediately (unlike, say, a function contract).
For example, For example,
@racket[flat-contract] constructs @tech{flat contracts} from predicates, and @racket[flat-contract] constructs flat contracts from predicates, and
symbols, booleans, numbers, and other ordinary Racket values symbols, booleans, numbers, and other ordinary Racket values
(that are defined as @tech{contracts}) are also (that are defined as @tech{contracts}) are also
@tech{flat contracts}.} flat contracts.}
@defproc[(list-contract? [v any/c]) boolean?]{ @defproc[(list-contract? [v any/c]) boolean?]{
Recognizes certain @racket[contract?] values that accept @racket[list?]s. Recognizes certain @racket[contract?] values that accept @racket[list?]s.
@ -3009,8 +2928,7 @@ the name @racket[opt/c].
@defform[(define-opt/c (id id ...) expr)]{ @defform[(define-opt/c (id id ...) expr)]{
This defines a recursive contract and simultaneously This defines a recursive contract and simultaneously
optimizes it. As long as the defined function terminates, optimizes it. Semantically, it behaves just as if
@racket[define-opt/c] behaves just as if
the @racket[-opt/c] were not present, defining a function on the @racket[-opt/c] were not present, defining a function on
contracts (except that the body expression must return a contracts (except that the body expression must return a
contract). But, it also optimizes that contract definition, contract). But, it also optimizes that contract definition,
@ -3033,15 +2951,7 @@ For example,
defines the @racket[bst/c] contract that checks the binary defines the @racket[bst/c] contract that checks the binary
search tree invariant. Removing the @racket[-opt/c] also search tree invariant. Removing the @racket[-opt/c] also
makes a binary search tree contract, but one that is makes a binary search tree contract, but one that is
(approximately) 20 times slower. (approximately) 20 times slower.}
Note that in some cases, a call to a function defined by
@racket[define-opt/c] may terminate, even if the corresponding
@racket[define]-based function would not terminate. This is a
shortcoming in @racket[define-opt/c] that we hope to understand
and fix at some point, but have no concrete plans currently.
}
@defthing[contract-continuation-mark-key continuation-mark-key?]{ @defthing[contract-continuation-mark-key continuation-mark-key?]{
Key used by continuation marks that are present during contract checking. Key used by continuation marks that are present during contract checking.
@ -3064,8 +2974,8 @@ currently being checked.
Produces a contract that acts like @racket[contract] but with the name Produces a contract that acts like @racket[contract] but with the name
@racket[name]. @racket[name].
The resulting contract is a @tech{flat contract} if @racket[contract] is a The resulting contract is a flat contract if @racket[contract] is a
@tech{flat contract}. flat contract.
@history[#:added "6.3"] @history[#:added "6.3"]
} }
@ -3106,9 +3016,9 @@ currently being checked.
Produces a contract that, when applied to a value, first tests the Produces a contract that, when applied to a value, first tests the
value with @racket[predicate]; if @racket[predicate] returns true, the value with @racket[predicate]; if @racket[predicate] returns true, the
@racket[then-contract] is applied; otherwise, the @racket[then-contract] is applied; otherwise, the
@racket[else-contract] is applied. The resulting contract is a @racket[else-contract] is applied. The resulting contract is a flat
@tech{flat contract} if both @racket[then-contract] and @racket[else-contract] are contract if both @racket[then-contract] and @racket[else-contract] are
@tech{flat contracts}. flat contracts.
For example, the following contract enforces that if a value is a For example, the following contract enforces that if a value is a
procedure, it is a thunk; otherwise it can be any (non-procedure) procedure, it is a thunk; otherwise it can be any (non-procedure)
@ -3117,7 +3027,7 @@ currently being checked.
Note that the following contract is @bold{not} equivalent: Note that the following contract is @bold{not} equivalent:
@racketblock[(or/c (-> any) any/c) (code:comment "wrong!")] @racketblock[(or/c (-> any) any/c) (code:comment "wrong!")]
The last contract is the same as @racket[any/c] because The last contract is the same as @racket[any/c] because
@racket[or/c] tries @tech{flat contracts} before higher-order contracts. @racket[or/c] tries flat contracts before higher-order contracts.
@history[#:added "6.3"] @history[#:added "6.3"]
} }
@ -3231,10 +3141,6 @@ it is called with @racket[#t] when there is no generator for @racket[ctc]
and called with @racket[#f] when there is a generator, but the generator and called with @racket[#f] when there is a generator, but the generator
ended up returning @racket[contract-random-generate-fail]. ended up returning @racket[contract-random-generate-fail].
@examples[#:eval (contract-eval) #:once
(for/list ([i (in-range 10)])
(contract-random-generate (or/c integer? #f)))]
@history[#:changed "6.1.1.5" @list{Allow @racket[fail] to accept a boolean.}] @history[#:changed "6.1.1.5" @list{Allow @racket[fail] to accept a boolean.}]
} }
@ -3246,20 +3152,6 @@ ended up returning @racket[contract-random-generate-fail].
contract and, for those that do, uses information about the contract's shape contract and, for those that do, uses information about the contract's shape
to poke and prod at the value. For example, if the value is function, it will to poke and prod at the value. For example, if the value is function, it will
use the contract to tell it what arguments to supply to the value. use the contract to tell it what arguments to supply to the value.
@examples[#:eval (contract-eval) #:once
(define/contract (returns-false x)
(-> integer? integer?)
(code:comment "does not obey its contract")
#f)
(eval:error (contract-exercise returns-false))
(define/contract (calls-its-argument-with-eleven f)
(-> (-> integer? integer?) boolean?)
(code:comment "f returns an integer, but")
(code:comment "we're supposed to return a boolean")
(f 11))
(eval:error (contract-exercise calls-its-argument-with-eleven))]
} }
@defproc[(contract-random-generate/choose [c contract?] [fuel exact-nonnegative-integer?]) @defproc[(contract-random-generate/choose [c contract?] [fuel exact-nonnegative-integer?])

View File

@ -233,11 +233,6 @@ supplied, then the @racket[struct] form is equivalent to
(eval:error ellipse-width) (eval:error ellipse-width)
] ]
@margin-note{
Expressions supplied to @racket[#:auto-value] are evaluated once and shared
between every instance of the structure type. In particular, updates to
a mutable @racket[#:auto-value] affect all current and future instances.
}
If @racket[#:auto] is supplied as a @racket[field-option], then the If @racket[#:auto] is supplied as a @racket[field-option], then the
@tech{constructor} procedure for the structure type does not accept an @tech{constructor} procedure for the structure type does not accept an
argument corresponding to the field. Instead, the structure type's argument corresponding to the field. Instead, the structure type's

View File

@ -300,8 +300,7 @@ renamed successfully, the @exnraise[exn:fail:filesystem].
This procedure can be used to move a file/directory to a different This procedure can be used to move a file/directory to a different
directory (on the same filesystem) as well as rename a file/directory within directory (on the same filesystem) as well as rename a file/directory within
a directory. Unless @racket[exists-ok?] is provided as a true value, a directory. Unless @racket[exists-ok?] is provided as a true value,
@racket[new] cannot refer to an existing file or directory, but the @racket[new] cannot refer to an existing file or directory. Even if
check is not atomic with the rename operation on Unix and Mac OS X. Even if
@racket[exists-ok?] is true, @racket[new] cannot refer to an existing @racket[exists-ok?] is true, @racket[new] cannot refer to an existing
file when @racket[old] is a directory, and vice versa. file when @racket[old] is a directory, and vice versa.

View File

@ -27,7 +27,6 @@ shorter than @racket[format] (with format string),
[#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)] [#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)]
[#:min-width min-width exact-nonnegative-integer? (or width 0)] [#:min-width min-width exact-nonnegative-integer? (or width 0)]
[#:limit-marker limit-marker string? ""] [#:limit-marker limit-marker string? ""]
[#:limit-prefix? limit-prefix? boolean? #f]
[#:align align (or/c 'left 'center 'right) 'left] [#:align align (or/c 'left 'center 'right) 'left]
[#:pad-string pad-string non-empty-string? " "] [#:pad-string pad-string non-empty-string? " "]
[#:left-pad-string left-pad-string non-empty-string? pad-string] [#:left-pad-string left-pad-string non-empty-string? pad-string]
@ -69,8 +68,6 @@ If @racket[_s] is longer than @racket[max-width] characters, it is
truncated and the end of the string is replaced with truncated and the end of the string is replaced with
@racket[limit-marker]. If @racket[limit-marker] is longer than @racket[limit-marker]. If @racket[limit-marker] is longer than
@racket[max-width], an exception is raised. @racket[max-width], an exception is raised.
If @racket[limit-prefix?] is @racket[#t], the beginning of the string
is truncated instead of the end.
@examples[#:eval the-eval @examples[#:eval the-eval
(~a "abcde" #:max-width 5) (~a "abcde" #:max-width 5)
@ -79,7 +76,6 @@ is truncated instead of the end.
(~a "abcde" #:max-width 4 #:limit-marker "...") (~a "abcde" #:max-width 4 #:limit-marker "...")
(~a "The quick brown fox" #:max-width 15 #:limit-marker "") (~a "The quick brown fox" #:max-width 15 #:limit-marker "")
(~a "The quick brown fox" #:max-width 15 #:limit-marker "...") (~a "The quick brown fox" #:max-width 15 #:limit-marker "...")
(~a "The quick brown fox" #:max-width 15 #:limit-marker "..." #:limit-prefix? #f)
] ]
If @racket[_s] is shorter than @racket[min-width], it is padded to at If @racket[_s] is shorter than @racket[min-width], it is padded to at
@ -124,7 +120,6 @@ simultaneously, ensuring that the resulting string is exactly
[#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)] [#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)]
[#:min-width min-width exact-nonnegative-integer? (or width 0)] [#:min-width min-width exact-nonnegative-integer? (or width 0)]
[#:limit-marker limit-marker string? "..."] [#:limit-marker limit-marker string? "..."]
[#:limit-prefix? limit-prefix? boolean? #f]
[#:align align (or/c 'left 'center 'right) 'left] [#:align align (or/c 'left 'center 'right) 'left]
[#:pad-string pad-string non-empty-string? " "] [#:pad-string pad-string non-empty-string? " "]
[#:left-pad-string left-pad-string non-empty-string? pad-string] [#:left-pad-string left-pad-string non-empty-string? pad-string]
@ -159,7 +154,6 @@ Use @racket[~v] to produce text that talks about Racket values.
[#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)] [#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)]
[#:min-width min-width exact-nonnegative-integer? (or width 0)] [#:min-width min-width exact-nonnegative-integer? (or width 0)]
[#:limit-marker limit-marker string? "..."] [#:limit-marker limit-marker string? "..."]
[#:limit-prefix? limit-prefix? boolean? #f]
[#:align align (or/c 'left 'center 'right) 'left] [#:align align (or/c 'left 'center 'right) 'left]
[#:pad-string pad-string non-empty-string? " "] [#:pad-string pad-string non-empty-string? " "]
[#:left-pad-string left-pad-string non-empty-string? pad-string] [#:left-pad-string left-pad-string non-empty-string? pad-string]
@ -187,7 +181,6 @@ marker is @racket["..."].
[#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)] [#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)]
[#:min-width min-width exact-nonnegative-integer? (or width 0)] [#:min-width min-width exact-nonnegative-integer? (or width 0)]
[#:limit-marker limit-marker string? "..."] [#:limit-marker limit-marker string? "..."]
[#:limit-prefix? limit-prefix? boolean? #f]
[#:align align (or/c 'left 'center 'right) 'left] [#:align align (or/c 'left 'center 'right) 'left]
[#:pad-string pad-string non-empty-string? " "] [#:pad-string pad-string non-empty-string? " "]
[#:left-pad-string left-pad-string non-empty-string? pad-string] [#:left-pad-string left-pad-string non-empty-string? pad-string]
@ -413,7 +406,6 @@ the resulting string is appended to the significand:
[#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)] [#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)]
[#:min-width min-width exact-nonnegative-integer? (or width 0)] [#:min-width min-width exact-nonnegative-integer? (or width 0)]
[#:limit-marker limit-marker string? ""] [#:limit-marker limit-marker string? ""]
[#:limit-prefix? limit-prefix? boolean? #f]
[#:align align (or/c 'left 'center 'right) 'left] [#:align align (or/c 'left 'center 'right) 'left]
[#:pad-string pad-string non-empty-string? " "] [#:pad-string pad-string non-empty-string? " "]
[#:left-pad-string left-pad-string non-empty-string? pad-string] [#:left-pad-string left-pad-string non-empty-string? pad-string]
@ -425,7 +417,6 @@ the resulting string is appended to the significand:
[#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)] [#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)]
[#:min-width min-width exact-nonnegative-integer? (or width 0)] [#:min-width min-width exact-nonnegative-integer? (or width 0)]
[#:limit-marker limit-marker string? "..."] [#:limit-marker limit-marker string? "..."]
[#:limit-prefix? limit-prefix? boolean? #f]
[#:align align (or/c 'left 'center 'right) 'left] [#:align align (or/c 'left 'center 'right) 'left]
[#:pad-string pad-string non-empty-string? " "] [#:pad-string pad-string non-empty-string? " "]
[#:left-pad-string left-pad-string non-empty-string? pad-string] [#:left-pad-string left-pad-string non-empty-string? pad-string]
@ -437,7 +428,6 @@ the resulting string is appended to the significand:
[#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)] [#:max-width max-width (or/c exact-nonnegative-integer? +inf.0) (or width +inf.0)]
[#:min-width min-width exact-nonnegative-integer? (or width 0)] [#:min-width min-width exact-nonnegative-integer? (or width 0)]
[#:limit-marker limit-marker string? "..."] [#:limit-marker limit-marker string? "..."]
[#:limit-prefix? limit-prefix? boolean? #f]
[#:align align (or/c 'left 'center 'right) 'left] [#:align align (or/c 'left 'center 'right) 'left]
[#:pad-string pad-string non-empty-string? " "] [#:pad-string pad-string non-empty-string? " "]
[#:left-pad-string left-pad-string non-empty-string? pad-string] [#:left-pad-string left-pad-string non-empty-string? pad-string]

View File

@ -485,26 +485,6 @@ Returns the value for the element in @racket[hash] at index
@racket[pos]. If @racket[pos] is not a valid index for @racket[pos]. If @racket[pos] is not a valid index for
@racket[hash], the @exnraise[exn:fail:contract].} @racket[hash], the @exnraise[exn:fail:contract].}
@defproc[(hash-iterate-pair [hash hash?]
[pos exact-nonnegative-integer?])
(cons any any)]{
Returns a pair containing the key and value for the element
in @racket[hash] at index
@racket[pos]. If @racket[pos] is not a valid index for
@racket[hash], the @exnraise[exn:fail:contract].}
@history[#:added "6.4.0.5"]
@defproc[(hash-iterate-key+value [hash hash?]
[pos exact-nonnegative-integer?])
(values any any)]{
Returns the key and value for the element in @racket[hash] at index
@racket[pos]. If @racket[pos] is not a valid index for
@racket[hash], the @exnraise[exn:fail:contract].}
@history[#:added "6.4.0.5"]
@defproc[(hash-copy [hash hash?]) @defproc[(hash-copy [hash hash?])
(and/c hash? (not/c immutable?))]{ (and/c hash? (not/c immutable?))]{
@ -532,16 +512,7 @@ the returned number is the same.}
Returns a @tech{fixnum}; for any two calls with @racket[equal?] values, Returns a @tech{fixnum}; for any two calls with @racket[equal?] values,
the returned number is the same. A hash code is computed even when the returned number is the same. A hash code is computed even when
@racket[v] contains a cycle through pairs, vectors, boxes, and/or @racket[v] contains a cycle through pairs, vectors, boxes, and/or
inspectable structure fields. See also @racket[gen:equal+hash]. inspectable structure fields. See also @racket[gen:equal+hash].}
For any @racket[v] that could be produced by @racket[read], if
@racket[v2] is produced by @racket[read] for the same input
characters, the @racket[(equal-hash-code v)] is the same as
@racket[(equal-hash-code v2)] --- even if @racket[v] and @racket[v2]
do not exist at the same time (and therefore could not be compared by
calling @racket[equal?]).
@history[#:changed "6.4.0.12" @elem{Strengthened guarantee for @racket[read]able values.}]}
@defproc[(equal-secondary-hash-code [v any/c]) fixnum?]{ @defproc[(equal-secondary-hash-code [v any/c]) fixnum?]{

View File

@ -40,7 +40,7 @@ Returns a @tech{resolved module path} that encapsulates @racket[path],
where a list @racket[path] corresponds to a @tech{submodule} path. where a list @racket[path] corresponds to a @tech{submodule} path.
If @racket[path] is a path or starts with a path, the path normally should be If @racket[path] is a path or starts with a path, the path normally should be
@tech{cleanse}d (see @racket[cleanse-path]) and simplified (see @tech{cleanse}d (see @racket[cleanse-path]) and simplified (see
@racket[simplify-path], including consulting the file system). @racket[simplify-path]).
A @tech{resolved module path} is interned. That is, if two A @tech{resolved module path} is interned. That is, if two
@tech{resolved module path} values encapsulate paths that are @tech{resolved module path} values encapsulate paths that are

View File

@ -437,7 +437,7 @@ Coerces @racket[q] to an exact number, finds the numerator of the
@defproc[(denominator [q rational?]) integer?]{ @defproc[(denominator [q rational?]) integer?]{
Coerces @racket[q] to an exact number, finds the denominator of the Coerces @racket[q] to an exact number, finds the numerator of the
number expressed in its simplest fractional form, and returns this number expressed in its simplest fractional form, and returns this
number coerced to the exactness of @racket[q]. number coerced to the exactness of @racket[q].

View File

@ -534,10 +534,6 @@ either order), then the elements preserve their relative order from
@racket[sort] with a strict comparison functions (e.g., @racket[<] or @racket[sort] with a strict comparison functions (e.g., @racket[<] or
@racket[string<?]; not @racket[<=] or @racket[string<=?]). @racket[string<?]; not @racket[<=] or @racket[string<=?]).
@margin-note{Because of the peculiar fact that the IEEE-754 number system
specifies that +nan.0 is neither greater nor less than nor equal to any other
number, sorting lists containing this value may produce a surprising result.}
The @racket[#:key] argument @racket[extract-key] is used to extract a The @racket[#:key] argument @racket[extract-key] is used to extract a
key value for comparison from each list element. That is, the full key value for comparison from each list element. That is, the full
comparison procedure is essentially comparison procedure is essentially

View File

@ -4,10 +4,10 @@
@title[#:tag "port-ops"]{Managing Ports} @title[#:tag "port-ops"]{Managing Ports}
@defproc[(input-port? [v any/c]) boolean?]{ @defproc[(input-port? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is an @tech{input port}, @racket[#f] otherwise.} Returns @racket[#t] if @racket[v] is an input port, @racket[#f] otherwise.}
@defproc[(output-port? [v any/c]) boolean?]{ @defproc[(output-port? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is an @tech{output port}, @racket[#f] otherwise.} Returns @racket[#t] if @racket[v] is an output port, @racket[#f] otherwise.}
@defproc[(port? [v any/c]) boolean?]{ @defproc[(port? [v any/c]) boolean?]{
Returns @racket[#t] if either @racket[(input-port? v)] or Returns @racket[#t] if either @racket[(input-port? v)] or

View File

@ -158,8 +158,8 @@ each element in the sequence.
(sequence? "word") (sequence? "word")
(sequence? #\x)]} (sequence? #\x)]}
@defproc*[([(in-range [end real?]) stream?] @defproc*[([(in-range [end number?]) stream?]
[(in-range [start real?] [end real?] [step real? 1]) stream?])]{ [(in-range [start number?] [end number?] [step number? 1]) stream?])]{
Returns a sequence (that is also a @tech{stream}) whose elements are Returns a sequence (that is also a @tech{stream}) whose elements are
numbers. The single-argument case @racket[(in-range end)] is numbers. The single-argument case @racket[(in-range end)] is
equivalent to @racket[(in-range 0 end 1)]. The first number in the equivalent to @racket[(in-range 0 end 1)]. The first number in the
@ -232,21 +232,9 @@ each element in the sequence.
greater or equal to @racket[end] if @racket[step] is non-negative, greater or equal to @racket[end] if @racket[step] is non-negative,
or less or equal to @racket[end] if @racket[step] is negative. or less or equal to @racket[end] if @racket[step] is negative.
If @racket[start] is not a valid index, then the If @racket[start] is not a valid index, or @racket[stop] is not in
@exnraise[exn:fail:contract], except when @racket[start], @racket[stop], and [-1, @racket[(vector-length vec)]] then the
@racket[(vector-length vec)] are equal, in which case the result is an @exnraise[exn:fail:contract]. If @racket[start] is less than
empty sequence.
@examples[#:eval sequence-evaluator
(for ([x (in-vector (vector 1) 1)]) x)
(eval:error (for ([x (in-vector (vector 1) 2)]) x))
(for ([x (in-vector (vector) 0 0)]) x)
(for ([x (in-vector (vector 1) 1 1)]) x)]
If @racket[stop] is not in [-1, @racket[(vector-length vec)]],
then the @exnraise[exn:fail:contract].
If @racket[start] is less than
@racket[stop] and @racket[step] is negative, then the @racket[stop] and @racket[step] is negative, then the
@exnraise[exn:fail:contract:mismatch]. Similarly, if @racket[start] @exnraise[exn:fail:contract:mismatch]. Similarly, if @racket[start]
is more than @racket[stop] and @racket[step] is positive, then the is more than @racket[stop] and @racket[step] is positive, then the
@ -378,53 +366,6 @@ each element in the sequence.
(printf "key and value: ~a\n" key+value))] (printf "key and value: ~a\n" key+value))]
} }
@deftogether[(
@defproc[(in-mutable-hash
[hash (and/c hash? (not/c immutable?) (not/c hash-weak?))])
sequence?]
@defproc[(in-mutable-hash-keys
[hash (and/c hash? (not/c immutable?) (not/c hash-weak?))])
sequence?]
@defproc[(in-mutable-hash-values
[hash (and/c hash? (not/c immutable?) (not/c hash-weak?))])
sequence?]
@defproc[(in-mutable-hash-pairs
[hash (and/c hash? (not/c immutable?) (not/c hash-weak?))])
sequence?]
@defproc[(in-immutable-hash
[hash (and/c hash? immutable?)])
sequence?]
@defproc[(in-immutable-hash-keys
[hash (and/c hash? immutable?)])
sequence?]
@defproc[(in-immutable-hash-values
[hash (and/c hash? immutable?)])
sequence?]
@defproc[(in-immutable-hash-pairs
[hash (and/c hash? immutable?)])
sequence?]
@defproc[(in-weak-hash
[hash (and/c hash? hash-weak?)])
sequence?]
@defproc[(in-weak-hash-keys
[hash (and/c hash? hash-weak?)])
sequence?]
@defproc[(in-weak-hash-values
[hash (and/c hash? hash-weak?)])
sequence?]
@defproc[(in-weak-hash-pairs
[hash (and/c hash? hash-weak?)])
sequence?]
)]{
Sequence constructors for specific kinds of hash tables.
These may be more performant than the analogous @racket[in-hash]
forms. However, they may consume more space to help with iteration.
@history[#:added "6.4.0.6"]
}
@defproc[(in-directory [dir (or/c #f path-string?) #f] @defproc[(in-directory [dir (or/c #f path-string?) #f]
[use-dir? ((and/c path? complete-path?) . -> . any/c) [use-dir? ((and/c path? complete-path?) . -> . any/c)
(lambda (dir-path) #t)]) (lambda (dir-path) #t)])
@ -1077,26 +1018,6 @@ stream, but plain lists can be used as streams, and functions such as
new stream is constructed lazily. new stream is constructed lazily.
} }
@deftogether[(@defform[(for/stream (for-clause ...) body-or-break ... body)]
@defform[(for*/stream (for-clause ...) body-or-break ... body)])]{
Iterates like @racket[for/list] and @racket[for*/list], respectively, but the
results are lazily collected into a @tech{stream} instead of a list.
Unlike most @racket[for] forms, these forms are evaluated lazily, so each
@racket[body] will not be evaluated until the resulting stream is forced. This
allows @racket[for/stream] and @racket[for*/stream] to iterate over infinite
sequences, unlike their finite counterparts.
@examples[#:eval sequence-evaluator
(for/stream ([i '(1 2 3)]) (* i i))
(stream->list (for/stream ([i '(1 2 3)]) (* i i)))
(stream-ref (for/stream ([i '(1 2 3)]) (displayln i) (* i i)) 1)
(stream-ref (for/stream ([i (in-naturals)]) (* i i)) 25)
]
@history[#:added "6.3.0.9"]
}
@defthing[gen:stream any/c]{ @defthing[gen:stream any/c]{
Associates three methods to a structure type to implement the Associates three methods to a structure type to implement the
@tech{generic interface} (see @secref["struct-generics"]) for @tech{generic interface} (see @secref["struct-generics"]) for

View File

@ -153,24 +153,6 @@ Analogous to @racket[for/list] and @racket[for*/list], but to
construct a @tech{hash set} instead of a list. construct a @tech{hash set} instead of a list.
} }
@deftogether[(
@defproc[(in-immutable-set [st set?]) sequence?]
@defproc[(in-mutable-set [st set-mutable?]) sequence?]
@defproc[(in-weak-set [st set-weak?]) sequence?]
)]{
Explicitly converts a specific kind of @tech{hash set} to a sequence for
use with @racket[for] forms.
As with @racket[in-list] and some other sequence constructors,
@racket[in-immutable-set] is more performant when it appears directly in a
@racket[for] clause.
These sequence constructors are compatible with
@secref["Custom_Hash_Sets" #:doc '(lib "scribblings/reference/reference.scrbl")].
}
@section{Set Predicates and Contracts} @section{Set Predicates and Contracts}
@defproc[(generic-set? [v any/c]) boolean?]{ @defproc[(generic-set? [v any/c]) boolean?]{

View File

@ -501,9 +501,8 @@ but with syntax errors potentially phrased in terms of
The @racket[...] transformer binding prohibits @racket[...] from The @racket[...] transformer binding prohibits @racket[...] from
being used as an expression. This binding is useful only in syntax being used as an expression. This binding is useful only in syntax
patterns and templates (or other unrelated expression forms patterns and templates, where it indicates repetitions of a pattern or
that treat it specially like @racket[->]), where it indicates repetitions template. See @racket[syntax-case] and @racket[syntax].}
of a pattern or template. See @racket[syntax-case] and @racket[syntax].}
@defidform[_]{ @defidform[_]{

View File

@ -5,12 +5,12 @@
Every syntax object has an associated @deftech{syntax property} list, Every syntax object has an associated @deftech{syntax property} list,
which can be queried or extended with which can be queried or extended with
@racket[syntax-property]. A property is set as @tech{preserved} or not; @racket[syntax-property]. Properties are not preserved for a
a preserved property is maintained for a syntax object in a compiled form that is syntax object in a compiled form that is
marshaled to a byte string or @filepath{.zo} file, and other properties marshaled to a byte string or @filepath{.zo} file, except for a @racket['paren-shape]
are discarded when marshaling. property value of @racket[#\[] or @racket[#\{].
In @racket[read-syntax], the reader attaches a preserved @racket['paren-shape] In @racket[read-syntax], the reader attaches a @racket['paren-shape]
property to any pair or vector syntax object generated from parsing a property to any pair or vector syntax object generated from parsing a
pair @litchar{[} and @litchar{]} or @litchar["{"] and pair @litchar{[} and @litchar{]} or @litchar["{"] and
@litchar["}"]; the property value is @racket[#\[] in the former case, @litchar["}"]; the property value is @racket[#\[] in the former case,
@ -23,8 +23,7 @@ transformer may have associated properties. The two sets of properties
are merged by the syntax expander: each property in the original and are merged by the syntax expander: each property in the original and
not present in the result is copied to the result, and the values of not present in the result is copied to the result, and the values of
properties present in both are combined with @racket[cons] (result properties present in both are combined with @racket[cons] (result
value first, original value second) and the @racket[cons]ed value is value first, original value second).
@tech{preserved} if either of the values were preserved.
Before performing the merge, however, the syntax expander Before performing the merge, however, the syntax expander
automatically adds a property to the original syntax object using the automatically adds a property to the original syntax object using the
@ -34,12 +33,11 @@ before the merge, the identifier that triggered the macro expansion
(as syntax) is @racket[cons]ed onto the @racket['origin] (as syntax) is @racket[cons]ed onto the @racket['origin]
property so far. The @racket['origin] property thus records (in property so far. The @racket['origin] property thus records (in
reverse order) the sequence of macro expansions that produced an reverse order) the sequence of macro expansions that produced an
expanded expression. Usually, the @racket['origin] value is a expanded expression. Usually, the @racket['origin] value is an
list of identifiers. However, a transformer might return immutable list of identifiers. However, a transformer might return
syntax that has already been expanded, in which case an syntax that has already been expanded, in which case an
@racket['origin] list can contain other lists after a merge. The @racket['origin] list can contain other lists after a merge. The
@racket[syntax-track-origin] procedure implements this tracking. @racket[syntax-track-origin] procedure implements this tracking.
The @racket['origin] property is added as non-@tech{preserved}.
Besides @racket['origin] tracking for general macro expansion, Besides @racket['origin] tracking for general macro expansion,
Racket adds properties to expanded syntax (often using Racket adds properties to expanded syntax (often using
@ -106,35 +104,17 @@ information on properties and byte codes.
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@defproc*[([(syntax-property [stx syntax?] @defproc*[([(syntax-property [stx syntax?] [key any/c] [v any/c]) syntax?]
[key (if preserved? (and/c symbol? symbol-interned?) any/c)]
[v any/c]
[preserved? any/c (eq? key 'paren-shape)])
syntax?]
[(syntax-property [stx syntax?] [key any/c]) any])]{ [(syntax-property [stx syntax?] [key any/c]) any])]{
The three- or four-argument form extends @racket[stx] by associating The three-argument form extends @racket[stx] by associating an
an arbitrary property value @racket[v] with the key @racket[key]; the arbitrary property value @racket[v] with the key @racket[key]; the
result is a new syntax object with the association (while @racket[stx] result is a new syntax object with the association (while @racket[stx]
itself is unchanged). The property is added as @tech{preserved} if itself is unchanged).
@racket[preserved?] is true, in which case @racket[key] must be an
@tech{interned} symbol, and @racket[v] should be a value can itself
be saved in marshaled bytecode.
The two-argument form returns an arbitrary property value associated The two-argument form returns an arbitrary property value associated
to @racket[stx] with the key @racket[key], or @racket[#f] if no value to @racket[stx] with the key @racket[key], or @racket[#f] if no value
is associated to @racket[stx] for @racket[key]. is associated to @racket[stx] for @racket[key].}
@history[#:changed "6.4.0.14" @elem{Added the @racket[preserved?] argument.}]}
@defproc[(syntax-property-preserved? [stx syntax?] [key (and/c symbol? symbol-interned?)])
boolean?]{
Returns @racket[#t] if @racket[stx] has a @tech{preserved} property
value for @racket[key], @racket[#f] otherwise.
@history[#:added "6.4.0.14"]}
@defproc[(syntax-property-symbol-keys [stx syntax?]) list?]{ @defproc[(syntax-property-symbol-keys [stx syntax?]) list?]{

View File

@ -695,7 +695,7 @@ enclosing module body or top-level sequence.
@transform-time[] If the current expression being transformed is not @transform-time[] If the current expression being transformed is not
within a @racket[module] form or within a top-level expansion, then within a @racket[module] form or within a top-level expansion, then
the @exnraise[exn:fail:contract]. If @racket[stx] form does not start with the @exnraise[exn:fail:contract]. If @racket[stx] form does start with
@racket[module] or @racket[module*], or if it starts with @racket[module*] @racket[module] or @racket[module*], or if it starts with @racket[module*]
in a top-level context, the @exnraise[exn:fail:contract]. in a top-level context, the @exnraise[exn:fail:contract].
@ -1094,23 +1094,7 @@ former list).}
require-transformer?]{ require-transformer?]{
Creates a @tech{require transformer} using the given procedure as the Creates a @tech{require transformer} using the given procedure as the
transformer. transformer.}
Often used in combination with @racket[expand-import].
@examples[
#:eval stx-eval
(require (for-syntax racket/require-transform))
(define-syntax printing
(make-require-transformer
(lambda (stx)
(syntax-case stx ()
[(_ path)
(printf "Importing: ~a~n" #'path)
(expand-import #'path)]))))
(require (printing racket/match))
]}
@defthing[prop:require-transformer struct-type-property?]{ @defthing[prop:require-transformer struct-type-property?]{

View File

@ -165,9 +165,6 @@ result is the result of the last @racket[body].}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@section[#:tag "date-string"]{Date Utilities} @section[#:tag "date-string"]{Date Utilities}
@margin-note{For more date & time operations, see
@other-doc['(lib "gregor/scribblings/gregor.scrbl") #:indirect "Gregor: Date and Time"]
or @link["../srfi/srfi-19.html"]{srfi/19}}
@note-lib-only[racket/date] @note-lib-only[racket/date]
@ -224,16 +221,16 @@ local time by default or UTC if @racket[local-time?] is
error is signaled, otherwise an integer is returned.} error is signaled, otherwise an integer is returned.}
@defproc[(date->julian/scaliger [date date?]) exact-integer?]{ @defproc[(date->julian/scalinger [date date?]) exact-integer?]{
Converts a date structure (up to 2099 BCE Gregorian) into a Julian Converts a date structure (up to 2099 BCE Gregorian) into a Julian
date number. The returned value is not a strict Julian number, but date number. The returned value is not a strict Julian number, but
rather Scaliger's version, which is off by one for easier rather Scalinger's version, which is off by one for easier
calculations.} calculations.}
@defproc[(julian/scaliger->string [date-number exact-integer?]) @defproc[(julian/scalinger->string [date-number exact-integer?])
string?]{ string?]{
Converts a Julian number (Scaliger's off-by-one version) into a Converts a Julian number (Scalinger's off-by-one version) into a
string.} string.}

View File

@ -347,94 +347,6 @@ The index @racket[k] must be between @racket[0] (inclusive) and
the number of fields in the structure (exclusive). In the case of the number of fields in the structure (exclusive). In the case of
@racket[unsafe-struct-set!], the field must be mutable.} @racket[unsafe-struct-set!], the field must be mutable.}
@deftogether[(
@defproc[(unsafe-mutable-hash-iterate-first
[h (and/c hash? (not/c immutable?) (not/c hash-weak?))])
(or/c #f any/c)]
@defproc[(unsafe-mutable-hash-iterate-next
[h (and/c hash? (not/c immutable?) (not/c hash-weak?))]
[i any/c])
(or/c #f any/c)]
@defproc[(unsafe-mutable-hash-iterate-key
[h (and/c hash? (not/c immutable?) (not/c hash-weak?))]
[i any/c])
any/c]
@defproc[(unsafe-mutable-hash-iterate-value
[h (and/c hash? (not/c immutable?) (not/c hash-weak?))]
[i any/c])
any/c]
@defproc[(unsafe-mutable-hash-iterate-key+value
[h (and/c hash? (not/c immutable?) (not/c hash-weak?))]
[i any/c])
(values any/c any/c)]
@defproc[(unsafe-mutable-hash-iterate-pair
[h (and/c hash? (not/c immutable?) (not/c hash-weak?))]
[i any/c])
pair?]
@defproc[(unsafe-immutable-hash-iterate-first
[h (and/c hash? immutable?)])
(or/c #f any/c)]
@defproc[(unsafe-immutable-hash-iterate-next
[h (and/c hash? immutable?)]
[i any/c])
(or/c #f any/c)]
@defproc[(unsafe-immutable-hash-iterate-key
[h (and/c hash? immutable?)]
[i any/c])
any/c]
@defproc[(unsafe-immutable-hash-iterate-value
[h (and/c hash? immutable?)]
[i any/c])
any/c]
@defproc[(unsafe-immutable-hash-iterate-key+value
[h (and/c hash? immutable?)]
[i any/c])
(values any/c any/c)]
@defproc[(unsafe-immutable-hash-iterate-pair
[h (and/c hash? immutable?)]
[i any/c])
pair?]
@defproc[(unsafe-weak-hash-iterate-first
[h (and/c hash? hash-weak?)])
(or/c #f any/c)]
@defproc[(unsafe-weak-hash-iterate-next
[h (and/c hash? hash-weak?)]
[i any/c])
(or/c #f any/c)]
@defproc[(unsafe-weak-hash-iterate-key
[h (and/c hash? hash-weak?)]
[i any/c])
any/c]
@defproc[(unsafe-weak-hash-iterate-value
[h (and/c hash? hash-weak?)]
[i any/c])
any/c]
@defproc[(unsafe-weak-hash-iterate-key+value
[h (and/c hash? hash-weak?)]
[i any/c])
(values any/c any/c)]
@defproc[(unsafe-weak-hash-iterate-pair
[h (and/c hash? hash-weak?)]
[i any/c])
pair?]
)]{
Unsafe versions of @racket[hash-iterate-key] and similar ops. These operations
support @tech{chaperones} and @tech{impersonators}.
Each unsafe @code{-first} and @code{-next} operation may not return a number
index but rather an internal representation of a view into the hash structure,
enabling faster iteration.
The result of these @code{-first} and @code{-next}] functions should be given
to the corresponding unsafe accessor functions.
If the key or value at the position returned by the @code{-first} and
@code{-next} ops becomes invalid (e.g., because of mutation or garbage
collection), then the operations @exnraise[exn:fail:contract].
@history[#:added "6.4.0.6"]
}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section[#:tag "unsafeextfl"]{Unsafe Extflonum Operations} @section[#:tag "unsafeextfl"]{Unsafe Extflonum Operations}
@ -529,36 +441,20 @@ fixnum).}
[prop impersonator-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c procedure? impersonator?)]{ (and/c procedure? impersonator?)]{
Like @racket[impersonate-procedure], except it assumes that @racket[replacement-proc]
is already properly wrapping @racket[proc] and so when the procedure that
@racket[unsafe-impersonate-procedure] produces is invoked, the
@racket[replacement-proc] is invoked directly, ignoring @racket[proc].
Like @racket[impersonate-procedure], but assumes that In addition, it does not specially handle @racket[impersonator-prop:application-mark],
@racket[replacement-proc] calls @racket[proc] itself. When the result instead just treating it as an ordinary property if it is supplied as one of the
of @racket[unsafe-impersonate-procedure] is applied to arguments, the @racket[prop] arguments.
arguments are passed on to @racket[replacement-proc] directly,
ignoring @racket[proc]. At the same time, @racket[impersonator-of?]
reports @racket[#t] when given the result of
@racket[unsafe-impersonate-procedure] and @racket[proc].
If @racket[proc] is itself an impersonator that is derived from This procedure is unsafe only in how it assumes @racket[replacement-proc] is
@racket[impersonate-procedure*] or @racket[chaperone-procedure*], a proper wrapper for @racket[proc]. It otherwise does all of the checking
beware that @racket[replacement-proc] will not be able to call it that @racket[impersonate-procedure] does.
correctly. Specifically, the impersonator produced by
@racket[unsafe-impersonate-procedure] will not get passed to a
wrapper procedure that was supplied to
@racket[impersonate-procedure*] or @racket[chaperone-procedure*] to
generate @racket[proc].
Finally, unlike @racket[impersonate-procedure], As an example, this function:
@racket[unsafe-impersonate-procedure] does not specially handle
@racket[impersonator-prop:application-mark] as a @racket[prop].
The unsafety of @racket[unsafe-impersonate-procedure] is limited to
the above differences from @racket[impersonate-procedure]. The
contracts on the arguments of @racket[unsafe-impersonate-procedure] are
checked when the arguments are supplied.
As an example, assuming that @racket[f] accepts a single argument and
is not derived from @racket[impersonate-procedure*] or
@racket[chaperone-procedure*], then
@racketblock[(λ (f) @racketblock[(λ (f)
(unsafe-impersonate-procedure (unsafe-impersonate-procedure
f f
@ -566,7 +462,7 @@ fixnum).}
(if (number? x) (if (number? x)
(error 'no-numbers!) (error 'no-numbers!)
(f x)))))] (f x)))))]
is equivalent to is equivalent to this one:
@racketblock[(λ (f) @racketblock[(λ (f)
(impersonate-procedure (impersonate-procedure
f f
@ -574,16 +470,17 @@ fixnum).}
(if (number? x) (if (number? x)
(error 'no-numbers!) (error 'no-numbers!)
x))))] x))))]
(except that some error messages start with @litchar{unsafe-impersonate-procedure}
instead of @litchar{impersonate-procedure}).
Similarly, with the same assumptions about @racket[f], the following Similarly the two procedures @racket[_wrap-f1] and
two procedures @racket[_wrap-f1] and
@racket[_wrap-f2] are almost equivalent; they differ only @racket[_wrap-f2] are almost equivalent; they differ only
in the error message produced when their arguments are in the error message produced when their arguments are
functions that return multiple values (and that they update functions that return multiple values (and that they update
different global variables). The version using @racket[unsafe-impersonate-procedure] different global variables). The version using @racket[unsafe-impersonate-procedure]
will signal an error in the @racket[let] expression about multiple will signal an error in the @racket[let] expression about multiple
return values, whereas the one using @racket[impersonate-procedure] signals value return, whereas the one using @racket[impersonate-procedure] signals
an error from @racket[impersonate-procedure] about multiple return values. an error from @racket[impersonate-procedure] about multiple value return.
@racketblock[(define log1-args '()) @racketblock[(define log1-args '())
(define log1-results '()) (define log1-results '())
(define wrap-f1 (define wrap-f1
@ -619,10 +516,6 @@ fixnum).}
[prop-val any] ... ...) [prop-val any] ... ...)
(and/c procedure? chaperone?)]{ (and/c procedure? chaperone?)]{
Like @racket[unsafe-impersonate-procedure], but creates a @tech{chaperone}. Like @racket[unsafe-impersonate-procedure], but creates a @tech{chaperone}.
Since @racket[wrapper-proc] will be called in lieu of @racket[proc],
@racket[wrapper-proc] is assumed to return a chaperone of the value that
@racket[proc] would return.
@history[#:added "6.4.0.4"] @history[#:added "6.4.0.4"]
} }

View File

@ -71,3 +71,30 @@ On occasion, you will find that you are spending a significant amount of
code base. In some cases it is acceptable to delay such tests, e.g., when code base. In some cases it is acceptable to delay such tests, e.g., when
you will not know for a long time whether the performance implications you will not know for a long time whether the performance implications
allow a commit to the PLT repository. allow a commit to the PLT repository.
@margin-note*{See
@hyperlink["http://git.racket-lang.org/intro.html"]{the write-up} on
using git in PLT for details.}
As a reminder, here are the essential elements of git for working on a
fork:
@itemlist[
@item{setup a fork:
@verbatim{
ssh pltgit fork plt eli/my-plt}}
@item{setup mail notifications:
@verbatim{
ssh pltgit config set eli/my-plt hooks.counter true
ssh pltgit config set eli/my-plt hooks.mailinglist @eli,...}}
@item{allow someone else to push commits to my repository:
@verbatim{
ssh pltgit setperms eli/my-plt
RW eli
RW someone-else
^D}}
]

View File

@ -137,27 +137,3 @@ As you can see, the macro on the left calls a function with a list of the
searchable values and a function that encapsulates the body. Every searchable values and a function that encapsulates the body. Every
expansion is a single function call. In contrast, the macro on the right expansion is a single function call. In contrast, the macro on the right
expands to many nested definitions and expressions every time it is used. expands to many nested definitions and expressions every time it is used.
@; -----------------------------------------------------------------------------
@section{Unsafe: Beware}
Racket provides a number of unsafe operations that behave
like their related, safe variants but only when given valid inputs.
They differ in that they eschew checking for performance reasons
and thus behave unpredictably on invalid inputs.
As one example, consider @racket[fx+] and @racket[unsafe-fx+].
When @racket[fx+] is applied to a non-@racket[fixnum?], it raises
an error. In contrast, when @racket[unsafe-fx+] is applied to a non-@racket[fixnum?],
it does not raise an error. Instead it either returns a strange result
that may violate invariants of the run-time system and may cause
later operations (such as printing out the value) to crash Racket itself.
Do not use unsafe operations in your programs unless you are writing
software that builds proofs that the unsafe operations receive only
valid inputs (e.g., a type system like Typed Racket) or you are building
an abstraction that always inserts the right checks very close to
the unsafe operation (e.g., a macro like @racket[for]). And even in these
situations, avoid unsafe operations unless you have done a careful performance
analysis to be sure that the performance improvement outweighs
the risk of using the unsafe operations.

View File

@ -1,5 +1,5 @@
#lang info #lang info
(define scribblings '(("scribblings/syntax.scrbl" (multi-page) ("Syntax Extensions")))) (define scribblings '(("scribblings/syntax.scrbl" (multi-page))))
(define test-responsibles '((all mflatt))) (define test-responsibles '((all mflatt)))

View File

@ -926,11 +926,13 @@ times in the entire repetition.
If the pattern is matched too few times, then the ellipsis pattern If the pattern is matched too few times, then the ellipsis pattern
fails with the message either @racket[too-few-message-expr] or fails with the message either @racket[too-few-message-expr] or
@racketvalfont{"too few occurrences of @racket[name-expr]"}. @racketvalfont{"too few occurrences of @racket[name-expr]"}, when
@racket[name-expr] is provided.
If the pattern is chosen too many times, then the ellipsis pattern If the pattern is chosen too many times, then the ellipsis pattern
fails with the message either @racket[too-many-message-expr] or fails with the message either @racket[too-many-message-expr] or
@racketvalfont{"too few occurrences of @racket[name-expr]"}. @racketvalfont{"too many occurrences of @racket[name-expr]"}, when
@racket[name-expr] is provided.
} }

View File

@ -4,8 +4,7 @@
(Section 'basic) (Section 'basic)
(require racket/flonum (require racket/flonum
racket/function racket/function)
(only-in '#%kernel (list-pair? k:list-pair?)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -149,13 +148,6 @@
(test #f pair? '#(a b)) (test #f pair? '#(a b))
(arity-test pair? 1 1) (arity-test pair? 1 1)
(test #f k:list-pair? '(a . b))
(test #f k:list-pair? '(a . 1))
(test #t k:list-pair? '(a b c))
(test #f k:list-pair? '())
(test #f k:list-pair? '#(a b))
(arity-test k:list-pair? 1 1)
(test '(a) cons 'a '()) (test '(a) cons 'a '())
(test '((a) b c d) cons '(a) '(b c d)) (test '((a) b c d) cons '(a) '(b c d))
(test '("a" b c) cons "a" '(b c)) (test '("a" b c) cons "a" '(b c))
@ -2658,14 +2650,8 @@
(set-a-y! an-a 8) (set-a-y! an-a 8)
(test v equal-hash-code an-a)) (test v equal-hash-code an-a))
;; Check that `equal-hash-code` is consistent for interned symbols:
(let ()
(define v (random))
(define k (equal-hash-code (string->symbol (format "sym:~a" v))))
(collect-garbage 'minor)
(test k equal-hash-code (string->symbol (format "sym:~a" v))))
;; Try to build a hash table whose indexes don't fit in 32 bits: ;; Try to build a hash table whose indexes fonr't fit in 32 bits:
(let () (let ()
(struct a (x) (struct a (x)
#:property #:property
@ -2694,48 +2680,6 @@
(for ([(k v) (in-hash ht2)]) (for ([(k v) (in-hash ht2)])
v)) v))
;; Check remove in the vicinity of a hash collision:
(let ()
(struct a (x y)
#:property prop:equal+hash
(list
(lambda (a b eql?) (and (equal? (a-x a)
(a-x b))
(equal? (a-y a)
(a-y b))))
(lambda (a hc) (a-x a))
(lambda (a hc) 1)))
(define k (+ (arithmetic-shift 1 10) 1))
(define k2 (+ (arithmetic-shift 1 15) 1))
;; The second hash here is intended to provoke a
;; collision in a subtable, and then remove an
;; element that causes the subtable, in which
;; case the collision should be moved up a layer.
(equal? (hash (a 1 'a) 1
(a 1 'b) 2
(a 2 'c) 3)
(hash-remove (hash (a 1 'a) 1
(a 1 'b) 2
(a 2 'c) 3
(a k 'd) 4)
(a k 'd)))
;; The second hash here is meanto to provoke
;; a similar shape as above, but where the
;; nested table is created to distinguish
;; hash keys instead of handle a collision,
;; and so it should not be moved up.
(equal? (hash (a 1 'a) 1
(a k2 'b) 2
(a 2 'c) 3)
(hash-remove (hash (a 1 'a) 1
(a k2 'b) 2
(a 2 'c) 3
(a k 'd) 4)
(a k 'd))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Misc ;; Misc

View File

@ -2386,39 +2386,6 @@
(define cf (unsafe-chaperone-procedure pf (lambda (x) x))) (define cf (unsafe-chaperone-procedure pf (lambda (x) x)))
(err/rt-test (cf) (λ (x) (regexp-match #rx"^pf:" (exn-message x))))) (err/rt-test (cf) (λ (x) (regexp-match #rx"^pf:" (exn-message x)))))
;; Make sure `unsafe-chaperone-procedure` doesn't propagate a bogus
;; identity to a `chaperone-procedure*` wrapper:
(let ()
(define found-prop? #f)
(define (f1 x) x)
(define-values (prop:p prop:p? prop:get-p)
(make-impersonator-property 'p))
(define (mk*)
(chaperone-procedure*
f1
(λ (f x)
(when (prop:p? f)
(set! found-prop? #t))
x)))
(define f2 (mk*))
(define f2x (mk*))
(define f3 (unsafe-chaperone-procedure f2 f2))
(define f3x (unsafe-chaperone-procedure f2 (lambda (v)
(f2x v)
(f2 v))))
(define f4 (chaperone-procedure f3 #f prop:p 1234))
(test 1 f4 1)
(test #f values found-prop?)
(test 1 f3x 1)
(test #f values found-prop?))
;; ---------------------------------------- ;; ----------------------------------------
(let () (let ()
@ -2474,59 +2441,6 @@
(test-wrapped wrapped-f) (test-wrapped wrapped-f)
(test-wrapped wrapped2-f)) (test-wrapped wrapped2-f))
;; ----------------------------------------
;; Check that continuation-mark depth is handled
;; properly when the JIT has to take a slow
;; path for a tail call
(let ()
(define (counter)
(let ([c 0])
(case-lambda
[() c]
[(x) (when (= c 1) (error 'fail)) (set! c (+ c 1)) #t])))
(for ([i 1000])
(let ([c (counter)])
(letrec ([f
(contract (-> any/c c)
(λ ([x #f]) (if (zero? x) x (f (- x 1))))
'pos
'neg)])
(f 6)))))
;; ----------------------------------------
;; Check that property-only impersonator does not
;; interfere with `chaperone-of?`
;; (Test provided by Vincent)
(let ()
(define-values (prop has-prop? get-prop)
(make-impersonator-property 'prop))
(define add1* (impersonate-procedure add1 #f
prop #f))
(test #t chaperone-of? (chaperone-procedure add1* #f)
add1*)
(test #t chaperone-of? (chaperone-procedure add1* (lambda (x) x))
add1*)
(test #f chaperone-of? (chaperone-procedure add1* #f)
add1)
(test #f chaperone-of? (chaperone-procedure add1* (lambda (x) x))
add1)
(test #t impersonator-of? (chaperone-procedure add1* #f)
add1*)
(test #t impersonator-of? (chaperone-procedure add1* (lambda (x) x))
add1*)
(test #t impersonator-of? (chaperone-procedure add1* #f)
add1)
(test #t impersonator-of? (chaperone-procedure add1* (lambda (x) x))
add1))
;; ---------------------------------------- ;; ----------------------------------------
(report-errs) (report-errs)

View File

@ -26,8 +26,6 @@
(test 0 find-seconds 0 0 0 1 1 1970 #f) (test 0 find-seconds 0 0 0 1 1 1970 #f)
(test 32416215 find-seconds 15 30 4 11 1 1971 #f) (test 32416215 find-seconds 15 30 4 11 1 1971 #f)
(test 1969 date-year (seconds->date (- (* 24 60 60))))
(let* ([s (current-seconds)] (let* ([s (current-seconds)]
[d1 (seconds->date s)] [d1 (seconds->date s)]
[d2 (seconds->date (+ s 1/100000000))]) [d2 (seconds->date (+ s 1/100000000))])
@ -73,12 +71,8 @@
(test-string 'julian #f "JD 2 453 860") (test-string 'julian #f "JD 2 453 860")
(test-string 'julian #t "JD 2 453 860, 03:02:01") (test-string 'julian #t "JD 2 453 860, 03:02:01")
;; In the off chance that one of these changes and not the other,
;; both are provided for tests.
(test 2453860 date->julian/scalinger d) (test 2453860 date->julian/scalinger d)
(test 2453860 date->julian/scaliger d) (test "JD 2 453 860" julian/scalinger->string 2453860))
(test "JD 2 453 860" julian/scalinger->string 2453860)
(test "JD 2 453 860" julian/scaliger->string 2453860))
;; Bad dates ;; Bad dates
(err/rt-test (find-seconds 0 0 0 0 0 1990) exn:fail?) (err/rt-test (find-seconds 0 0 0 0 0 1990) exn:fail?)
@ -110,14 +104,9 @@
;; one of the two possible values, though: ;; one of the two possible values, though:
(test-find 0 30 1 7 11 2010)))) (test-find 0 30 1 7 11 2010))))
;; In the off chance that one of these changes and not the other,
;; both are provided for tests.
;; bug fixes ;; bug fixes
(test "JD 12" julian/scalinger->string 12) (test "JD 12" julian/scalinger->string 12)
(test "JD 12" julian/scaliger->string 12)
(test "JD 123" julian/scalinger->string 123) (test "JD 123" julian/scalinger->string 123)
(test "JD 123" julian/scaliger->string 123)
;; make sure that date* has the correct parent info ;; make sure that date* has the correct parent info
(test #t date*? (test #t date*?
@ -128,11 +117,4 @@
(date* 56 34 12 22 08 2015 6 233 #f 0 789000000 "UTC")]) (date* 56 34 12 22 08 2015 6 233 #f 0 789000000 "UTC")])
(test 789/1000 - (date*->seconds d) (date->seconds d))) (test 789/1000 - (date*->seconds d) (date->seconds d)))
;; Check some overflow handling on Windows:
(when (eq? (system-type) 'windows)
(let ([out-of-range (lambda (exn) (regexp-match? #rx"out-of-range" (exn-message exn)))])
(err/rt-test (seconds->date (expt 2 40)) out-of-range)
(err/rt-test (seconds->date (expt 2 50)) out-of-range)
(err/rt-test (seconds->date (expt 2 60)) out-of-range)))
(report-errs) (report-errs)

View File

@ -5,10 +5,6 @@
(define testing.rktl (build-path (current-load-relative-directory) "testing.rktl")) (define testing.rktl (build-path (current-load-relative-directory) "testing.rktl"))
(define original-dir (current-directory))
(define work-dir (make-temporary-file "path~a" 'directory))
(current-directory work-dir)
(test #t input-port? (current-input-port)) (test #t input-port? (current-input-port))
(test #t output-port? (current-output-port)) (test #t output-port? (current-output-port))
(test #t output-port? (current-error-port)) (test #t output-port? (current-error-port))
@ -1619,9 +1615,6 @@
;; Cleanup files created above ;; Cleanup files created above
(for ([f '("tmp1" "tmp2" "tmp3")] #:when (file-exists? f)) (delete-file f)) (for ([f '("tmp1" "tmp2" "tmp3")] #:when (file-exists? f)) (delete-file f))
(current-directory original-dir)
(delete-directory work-dir)
;; Network - - - - - - - - - - - - - - - - - - - - - - ;; Network - - - - - - - - - - - - - - - - - - - - - -
(define (net-reject? who host port what) (define (net-reject? who host port what)
@ -1648,11 +1641,6 @@
(err/rt-test (udp-connect! early-udp "localhost" 40000) (net-reject? 'udp-connect! "localhost" 40000 'client)) (err/rt-test (udp-connect! early-udp "localhost" 40000) (net-reject? 'udp-connect! "localhost" 40000 'client))
(err/rt-test (udp-send-to early-udp "localhost" 40000 #"hi") (net-reject? 'udp-send-to "localhost" 40000 'client)))) (err/rt-test (udp-send-to early-udp "localhost" 40000 #"hi") (net-reject? 'udp-send-to "localhost" 40000 'client))))
;; Interaction with `system-type` - - - - - - - - - - - - - - - - - - -
(parameterize ([current-security-guard (make-file-sg '())])
(test #f regexp-match? "unknown machine" (system-type 'machine)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check `in-directory' ;; Check `in-directory'
@ -1826,29 +1814,4 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ([tf (make-temporary-file)])
(test tf resolve-path (path->string tf))
(unless (eq? 'windows (system-type))
(delete-file tf)
(make-file-or-directory-link "other.txt" tf)
(test (string->path "other.txt") resolve-path tf))
(delete-file tf)
(case (system-path-convention-type)
[(unix)
(test (string->path "/testing-root/testing-dir/testing-file")
resolve-path
"//testing-root/testing-dir/testing-file")
(test (string->path "/testing-root/testing-dir/testing-file")
resolve-path
"//testing-root////testing-dir//testing-file")]
[(windows)
(test (string->path "C:/testing-root/testing-dir/testing-file")
resolve-path
"C://testing-root/testing-dir/testing-file")
(test (string->path "C:/testing-root/testing-dir\\testing-file")
resolve-path
"C://testing-root////testing-dir\\\\testing-file")]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs) (report-errs)

View File

@ -7,8 +7,7 @@
racket/system racket/system
racket/list) racket/list)
(define tmp-dir (make-temporary-file "filelib~a" 'directory)) (define tmp-name "tmp0-filelib")
(define tmp-name (build-path tmp-dir "tmp0-filelib"))
(when (file-exists? tmp-name) (delete-file tmp-name)) (when (file-exists? tmp-name) (delete-file tmp-name))
(display-lines-to-file '("a" "b" "c") tmp-name #:separator #"\r\n" #:mode 'binary) (display-lines-to-file '("a" "b" "c") tmp-name #:separator #"\r\n" #:mode 'binary)
(test '(a b c) file->list tmp-name) (test '(a b c) file->list tmp-name)
@ -29,7 +28,6 @@
(test #"\"\316\273\"" file->bytes tmp-name) (test #"\"\316\273\"" file->bytes tmp-name)
(test "\u03BB" file->value tmp-name) (test "\u03BB" file->value tmp-name)
(when (file-exists? tmp-name) (delete-file tmp-name)) (when (file-exists? tmp-name) (delete-file tmp-name))
(delete-directory tmp-dir)
(define-syntax-rule (err/rt-chk-test (op arg ...)) (define-syntax-rule (err/rt-chk-test (op arg ...))
(err/rt-test (op arg ...) (check-msg 'op))) (err/rt-test (op arg ...) (check-msg 'op)))
@ -89,79 +87,57 @@
(test #t equal? (sort rel) (sort rel2)) (test #t equal? (sort rel) (sort rel2))
(unless (eq? (system-type) 'windows) (unless (eq? (system-type) 'windows)
(define tmp-dir (make-temporary-file "filelib~a" 'directory)) (make-file-or-directory-link "filelib.rktl" "filelib-link")
(define (touch . elems) (make-file-or-directory-link "." "loop-link")
(call-with-output-file
(apply build-path elems)
void))
(copy-file "filelib.rktl" (build-path tmp-dir "filelib.rktl")) (test (+ 2 (length rel2))
(make-directory (build-path tmp-dir "sub")) fold-files
(touch tmp-dir "a") (lambda (name kind accum)
(touch tmp-dir "b") (test kind values (cond
(touch tmp-dir "sub" "x") [(link-exists? name) 'link]
[(file-exists? name) 'file]
[(directory-exists? name) 'dir]
[else '???]))
(when (member name '("filelib-link" "loop-link"))
(test kind name 'link))
(add1 accum))
0
#f
#f)
(parameterize ([current-directory tmp-dir]) (test (+ 2 (length rel2))
(define rel2 (fold-files (lambda (name kind accum) fold-files
(test kind name (if (file-exists? name) (lambda (name kind accum)
'file (test kind values (cond
'dir)) [(link-exists? name) 'link]
(cons name accum)) [(file-exists? name) 'file]
null)) [(directory-exists? name) 'dir]
[else '???]))
(when (member name '("filelib-link" "loop-link"))
(test kind name 'link))
(values (add1 accum) #t))
0
#f
#f)
(make-file-or-directory-link "filelib.rktl" "filelib-link") (delete-file "loop-link")
(make-file-or-directory-link "." "loop-link")
(test (+ 2 (length rel2)) (test (+ 1 (length rel2))
fold-files fold-files
(lambda (name kind accum) (lambda (name kind accum)
(test kind values (cond (test kind values (cond
[(link-exists? name) 'link] [(file-exists? name) 'file]
[(file-exists? name) 'file] [else 'dir]))
[(directory-exists? name) 'dir] (when (member name '("filelib-link"))
[else '???])) (test kind name 'file))
(when (member name '("filelib-link" "loop-link")) (add1 accum))
(test kind name 'link)) 0
(add1 accum)) #f
0 #t)
#f
#f)
(test (+ 2 (length rel2)) (delete-file "filelib-link")
fold-files
(lambda (name kind accum)
(test kind values (cond
[(link-exists? name) 'link]
[(file-exists? name) 'file]
[(directory-exists? name) 'dir]
[else '???]))
(when (member name '("filelib-link" "loop-link"))
(test kind name 'link))
(values (add1 accum) #t))
0
#f
#f)
(delete-file "loop-link")
(test (+ 1 (length rel2))
fold-files
(lambda (name kind accum)
(test kind values (cond
[(file-exists? name) 'file]
[else 'dir]))
(when (member name '("filelib-link"))
(test kind name 'file))
(add1 accum))
0
#f
#t)
(delete-file "filelib-link")
'done)
(delete-directory/files tmp-dir)))))
'done))))
;; ---------------------------------------- ;; ----------------------------------------
;;---------------------------------------------------------------------- ;;----------------------------------------------------------------------

View File

@ -75,15 +75,9 @@
(= fx-result unsafe-result)))]) (= fx-result unsafe-result)))])
(unless ans (unless ans
(newline) (newline)
(error 'same-results (~a "better die now, rather than continue, what with unsafe ops around:\n" (error 'same-results "better die now, rather than continue, what with unsafe ops around:\n fx-result ~s\n unsafe-result ~s"
" fx-result ~s\n"
" unsafe-result ~s\n"
" op: ~s\n"
" args: ~s")
fx-result fx-result
unsafe-result unsafe-result))
fx
args))
#t))) #t)))
(define (flonum? x) (inexact-real? x)) (define (flonum? x) (inexact-real? x))

View File

@ -369,7 +369,6 @@
(test '() 'in-empty-vector (let ([v (in-vector '#())]) (for/list ([e v]) e))) (test '() 'in-empty-vector (let ([v (in-vector '#())]) (for/list ([e v]) e)))
(test '() 'in-empty-vector (let ([v (in-vector '#() 0)]) (for/list ([e v]) e))) (test '() 'in-empty-vector (let ([v (in-vector '#() 0)]) (for/list ([e v]) e)))
(test '() 'in-empty-vector (let ([v (in-vector '#() 0 0)]) (for/list ([e v]) e))) (test '() 'in-empty-vector (let ([v (in-vector '#() 0 0)]) (for/list ([e v]) e)))
(test '() 'in-empty-vector (let ([v (in-vector '#(1) 1)]) (for/list ([e v]) e)))
(test '() 'in-empty-vector (let ([v (in-vector '#(1) 1 1)]) (for/list ([e v]) e))) (test '() 'in-empty-vector (let ([v (in-vector '#(1) 1 1)]) (for/list ([e v]) e)))
(test '() 'in-empty-vector (let ([v (in-vector '#(1) 0 0)]) (for/list ([e v]) e))) (test '() 'in-empty-vector (let ([v (in-vector '#(1) 0 0)]) (for/list ([e v]) e)))
(test '(1) 'in-empty-vector (let ([v (in-vector '#(1) 0 1)]) (for/list ([e v]) e))) (test '(1) 'in-empty-vector (let ([v (in-vector '#(1) 0 1)]) (for/list ([e v]) e)))
@ -451,240 +450,7 @@
#rx".*expected number of values not received.*") #rx".*expected number of values not received.*")
(test 1 'one (begin (for/fold () () (values)) 1)) (test 1 'one (begin (for/fold () () (values)) 1))
;; iterator contract tests
(err/rt-test (for ([x (in-range (sqrt -1))]) x)
exn:fail:contract?
#rx"expected\\: real\\?")
(err/rt-test (for ([x (in-range 1 (sqrt -1))]) x)
exn:fail:contract?
#rx"expected\\: real\\?")
(err/rt-test (for ([x (in-range 1 2 (sqrt -1))]) x)
exn:fail:contract?
#rx"expected\\: real\\?")
(test (* 10 pi) 'in-range-with-reals
(for/sum ([x (in-range 0 (+ (* 4 pi) .1) pi)]) x))
(err/rt-test (for ([x (in-naturals 1.1)]) x)
exn:fail:contract?
#rx"expected\\: exact-nonnegative-integer\\?")
(err/rt-test (for ([x (in-naturals -1)]) x)
exn:fail:contract?
#rx"expected\\: exact-nonnegative-integer\\?")
(err/rt-test (for ([x (in-list 1)]) x)
exn:fail:contract?
#rx"expected\\: list\\?")
(err/rt-test (for ([x (in-list (vector 1 2 3))]) x)
exn:fail:contract?
#rx"expected\\: list\\?")
(err/rt-test (for ([x (in-list (mcons 1 '()))]) x)
exn:fail:contract?
#rx"expected\\: list\\?")
(err/rt-test (for ([x (in-mlist (list 1 2 3))]) x)
exn:fail:contract?
#rx"expected\\: mpair\\?")
(err/rt-test (for ([x (in-vector '(1 2))]) x)
exn:fail:contract?
#rx"expected\\: vector")
(err/rt-test (for ([x (in-vector (vector 1 2) -1)]) x)
exn:fail:contract?
#rx"starting index is out of range")
(err/rt-test (for ([x (in-vector (vector 1 2) 10)]) x)
exn:fail:contract?
#rx"starting index is out of range")
(err/rt-test (for ([x (in-vector (vector 1 2) 1.1)]) x)
exn:fail:contract?
#rx"expected\\: exact-integer\\?")
(err/rt-test (for ([x (in-vector (vector 1 2) 0 1.1)]) x)
exn:fail:contract?
#rx"expected\\: exact-integer\\?")
(err/rt-test (for ([x (in-vector (vector 1 2) 0 2 1.1)]) x)
exn:fail:contract?
#rx"expected:.*exact-integer\\?")
(err/rt-test (for ([x (in-vector (vector 1 2) 0 2 0)]) x)
exn:fail:contract?
#rx"expected:.*not/c zero\\?")
(err/rt-test (for ([x (in-port (vector 1 2))]) x)
exn:fail:contract?
#rx"expected:.*procedure-arity-includes/c 1")
(err/rt-test (for ([x (in-input-port-bytes (vector 1 2))]) x)
exn:fail:contract?
#rx"expected: input-port\\?")
(err/rt-test (for ([x (in-hash (vector 1 2))]) x)
exn:fail:contract?
#rx"expected: hash\\?")
(err/rt-test (for ([x (in-hash-pairs (vector 1 2))]) x)
exn:fail:contract?
#rx"expected: hash\\?")
(err/rt-test (for ([x (in-hash-keys (vector 1 2))]) x)
exn:fail:contract?
#rx"expected: hash\\?")
(err/rt-test (for ([x (in-hash-values (vector 1 2))]) x)
exn:fail:contract?
#rx"expected: hash\\?")
(err/rt-test (for ([x (in-hash (hash 1 2))]) x)
exn:fail:contract:arity?
#rx"expected number of values not received")
(err/rt-test (for/sum ([x (in-vector (vector 1 2) 2 -1 -1)]) x) ; pr 15227
exn:fail:contract?
#rx"starting index is out of range")
(err/rt-test (for/sum ([x (in-vector (vector) -1 -1 -1)]) x)
exn:fail:contract?
#rx"starting index is out of range")
(err/rt-test (for/sum ([x (in-vector (vector) 1 1 1)]) x)
exn:fail:contract?
#rx"starting index is out of range")
(err/rt-test (for/sum ([x (in-vector (vector 1) 1 2)]) x)
exn:fail:contract?
#rx"starting index is out of range")
(err/rt-test (for/sum ([x (in-vector (vector 1) 0 2)]) x)
exn:fail:contract?
#rx"stopping index is out of range")
(err/rt-test (for/sum ([x (in-vector (vector 1) 0 -1)]) x)
exn:fail:contract?
#rx"starting index more than stopping index, but given a positive step")
(err/rt-test (for/sum ([x (in-vector (vector 1) 0 1 -1)]) x)
exn:fail:contract?
#rx"starting index less than stopping index, but given a negative step")
;; for/fold syntax checking ;; for/fold syntax checking
(syntax-test #'(for/fold () bad 1) #rx".*bad sequence binding clauses.*") (syntax-test #'(for/fold () bad 1) #rx".*bad sequence binding clauses.*")
;; specific hash set iterators
(err/rt-test (for/sum ([x (in-immutable-set '(1 2))]) x)
exn:fail:contract?
#rx"not a hash set")
(err/rt-test (for/sum ([x (in-mutable-set '(1 2))]) x)
exn:fail:contract?
#rx"not a hash set")
(err/rt-test (for/sum ([x (in-weak-set '(1 2))]) x)
exn:fail:contract?
#rx"not a hash set")
(test 10 'in-hash-set (for/sum ([x (in-immutable-set (set 1 2 3 4))]) x))
(test 10 'in-hash-set (for/sum ([x (in-mutable-set (mutable-set 1 2 3 4))]) x))
(test 10 'in-hash-set (for/sum ([x (in-weak-set (weak-set 1 2 3 4))]) x))
(test 10 'in-hash-set (for/sum ([x (in-immutable-set (seteqv 1 2 3 4))]) x))
(test 10 'in-hash-set (for/sum ([x (in-mutable-set (mutable-seteqv 1 2 3 4))]) x))
(test 10 'in-hash-set (for/sum ([x (in-weak-set (weak-seteqv 1 2 3 4))]) x))
(test 10 'in-hash-set (for/sum ([x (in-immutable-set (seteq 1 2 3 4))]) x))
(test 10 'in-hash-set (for/sum ([x (in-mutable-set (mutable-seteq 1 2 3 4))]) x))
(test 10 'in-hash-set (for/sum ([x (in-weak-set (weak-seteq 1 2 3 4))]) x))
(test 10 'in-hash-set (for/sum ([x (in-immutable-set (list->set '(1 2 3 4)))]) x))
(test 10 'in-hash-set (for/sum ([x (in-mutable-set (list->mutable-set '(1 2 3 4)))]) x))
(test 10 'in-hash-set (for/sum ([x (in-weak-set (list->weak-set '(1 2 3 4)))]) x))
(test 30 'custom-in-hash-set
(let ()
(define-custom-set-types pos-set
#:elem? positive?
(λ (x y recur) (+ x y))
(λ (x recur) x))
(define imm
(make-immutable-pos-set '(1 2 3 4)))
(define m
(make-mutable-pos-set '(1 2 3 4)))
(define w
(make-weak-pos-set '(1 2 3 4)))
(+ (for/sum ([x (in-immutable-set imm)]) x)
(for/sum ([x (in-mutable-set m)]) x)
(for/sum ([x (in-weak-set w)]) x))))
(err/rt-test
(for ([(k v) (in-immutable-hash (make-hash '((1 . 2))))]) (+ k v))
exn:fail:contract?
#rx"expected:.*and/c hash\\? immutable\\?")
(err/rt-test
(for ([(k v) (in-immutable-hash (make-weak-hash '((1 . 2))))]) (+ k v))
exn:fail:contract?
#rx"expected:.*and/c hash\\? immutable\\?")
(err/rt-test
(for ([(k v) (in-mutable-hash (make-immutable-hash '((1 . 2))))]) (+ k v))
exn:fail:contract?
#rx"expected:.*and/c hash\\? mutable\\?")
(err/rt-test
(for ([(k v) (in-mutable-hash (make-weak-hash '((1 . 2))))]) (+ k v))
exn:fail:contract?
#rx"expected:.*and/c hash\\? mutable\\?")
(err/rt-test
(for ([(k v) (in-weak-hash (make-immutable-hash '((1 . 2))))]) (+ k v))
exn:fail:contract?
#rx"expected:.*and/c hash\\? hash-weak\\?")
(err/rt-test
(for ([(k v) (in-weak-hash (make-hash '((1 . 2))))]) (+ k v))
exn:fail:contract?
#rx"expected:.*and/c hash\\? hash-weak\\?")
;; keys
(err/rt-test
(for ([k (in-immutable-hash-keys (make-hash '((1 . 2))))]) k)
exn:fail:contract?
#rx"expected:.*and/c hash\\? immutable\\?")
(err/rt-test
(for ([k (in-immutable-hash-keys (make-weak-hash '((1 . 2))))]) k)
exn:fail:contract?
#rx"expected:.*and/c hash\\? immutable\\?")
(err/rt-test
(for ([k (in-mutable-hash-keys (make-immutable-hash '((1 . 2))))]) k)
exn:fail:contract?
#rx"expected:.*and/c hash\\? mutable\\?")
(err/rt-test
(for ([k (in-mutable-hash-keys (make-weak-hash '((1 . 2))))]) k)
exn:fail:contract?
#rx"expected:.*and/c hash\\? mutable\\?")
(err/rt-test
(for ([k (in-weak-hash-keys (make-immutable-hash '((1 . 2))))]) k)
exn:fail:contract?
#rx"expected:.*and/c hash\\? hash-weak\\?")
(err/rt-test
(for ([k (in-weak-hash-keys (make-hash '((1 . 2))))]) k)
exn:fail:contract?
#rx"expected:.*and/c hash\\? hash-weak\\?")
;; values
(err/rt-test
(for ([v (in-immutable-hash-values (make-hash '((1 . 2))))]) v)
exn:fail:contract?
#rx"expected:.*and/c hash\\? immutable\\?")
(err/rt-test
(for ([v (in-immutable-hash-values (make-weak-hash '((1 . 2))))]) v)
exn:fail:contract?
#rx"expected:.*and/c hash\\? immutable\\?")
(err/rt-test
(for ([v (in-mutable-hash-values (make-immutable-hash '((1 . 2))))]) v)
exn:fail:contract?
#rx"expected:.*and/c hash\\? mutable\\?")
(err/rt-test
(for ([v (in-mutable-hash-values (make-weak-hash '((1 . 2))))]) v)
exn:fail:contract?
#rx"expected:.*and/c hash\\? mutable\\?")
(err/rt-test
(for ([v (in-weak-hash-values (make-immutable-hash '((1 . 2))))]) v)
exn:fail:contract?
#rx"expected:.*and/c hash\\? hash-weak\\?")
(err/rt-test
(for ([v (in-weak-hash-values (make-hash '((1 . 2))))]) v)
exn:fail:contract?
#rx"expected:.*and/c hash\\? hash-weak\\?")
;; pairs
(err/rt-test
(for ([p (in-immutable-hash-pairs (make-hash '((1 . 2))))]) p)
exn:fail:contract?
#rx"expected:.*and/c hash\\? immutable\\?")
(err/rt-test
(for ([p (in-immutable-hash-pairs (make-weak-hash '((1 . 2))))]) p)
exn:fail:contract?
#rx"expected:.*and/c hash\\? immutable\\?")
(err/rt-test
(for ([p (in-mutable-hash-pairs (make-immutable-hash '((1 . 2))))]) p)
exn:fail:contract?
#rx"expected:.*and/c hash\\? mutable\\?")
(err/rt-test
(for ([p (in-mutable-hash-pairs (make-weak-hash '((1 . 2))))]) p)
exn:fail:contract?
#rx"expected:.*and/c hash\\? mutable\\?")
(err/rt-test
(for ([p (in-weak-hash-pairs (make-immutable-hash '((1 . 2))))]) p)
exn:fail:contract?
#rx"expected:.*and/c hash\\? hash-weak\\?")
(err/rt-test
(for ([p (in-weak-hash-pairs (make-hash '((1 . 2))))]) p)
exn:fail:contract?
#rx"expected:.*and/c hash\\? hash-weak\\?")
(report-errs) (report-errs)

View File

@ -1,5 +1,4 @@
#include <stdlib.h> #include <stdlib.h>
#include <errno.h>
#ifdef USE_THREAD_TEST #ifdef USE_THREAD_TEST
#include <pthread.h> #include <pthread.h>
#endif #endif
@ -257,15 +256,3 @@ X void* foreign_thread_callback(test_callback_t f,
return r; return r;
} }
#endif #endif
/* This testing function doesn't work reliably on Windows, because it sometimes
* writes to a different errno. */
X int check_multiple_of_ten(int v) {
int r = v % 10;
if (r == 0) {
return 0;
} else {
errno = r;
return -1;
}
}

View File

@ -7,8 +7,7 @@
ffi/unsafe/cvector ffi/unsafe/cvector
ffi/vector ffi/vector
racket/extflonum racket/extflonum
racket/place racket/place)
racket/file)
(define test-async? (and (place-enabled?) (not (eq? 'windows (system-type))))) (define test-async? (and (place-enabled?) (not (eq? 'windows (system-type)))))
@ -98,38 +97,34 @@
(require dynext/compile dynext/link racket/runtime-path) (require dynext/compile dynext/link racket/runtime-path)
(define-runtime-path here ".") (define-runtime-path here ".")
(define test-tmp-dir
(make-temporary-file "foreign~a" 'directory))
(copy-file (build-path here "foreign-test.c")
(build-path test-tmp-dir "foreign-test.c"))
(define delete-test-files (define delete-test-files
(parameterize ([current-directory test-tmp-dir]) (let ([c (build-path here "foreign-test.c")]
(let ([c (build-path (current-directory) "foreign-test.c")] [o (build-path (current-directory)
[o (build-path (current-directory) (if (eq? 'windows (system-type))
(if (eq? 'windows (system-type)) "foreign-test.obj" "foreign-test.o"))]
"foreign-test.obj" "foreign-test.o"))] [so (build-path (current-directory)
[so (build-path (current-directory) (bytes->path (bytes-append #"foreign-test"
(bytes->path (bytes-append #"foreign-test" (system-type 'so-suffix))))])
(system-type 'so-suffix))))]) (when (file-exists? o) (delete-file o))
(when (file-exists? so) (delete-file so))
(parameterize ([current-standard-link-libraries '()]
[current-extension-compiler-flags
(if test-async?
(append '("-pthread" "-DUSE_THREAD_TEST") (current-extension-compiler-flags))
(current-extension-compiler-flags))]
[current-extension-linker-flags
(if test-async?
(append '("-pthread") (current-extension-linker-flags))
(current-extension-linker-flags))])
(compile-extension #t c o '())
(link-extension #t (list o) so))
(lambda ()
(when (file-exists? o) (delete-file o)) (when (file-exists? o) (delete-file o))
(when (file-exists? so) (delete-file so)) (when (file-exists? so)
(parameterize ([current-standard-link-libraries '()]
[current-extension-compiler-flags
(if test-async?
(append '("-pthread" "-DUSE_THREAD_TEST") (current-extension-compiler-flags))
(current-extension-compiler-flags))]
[current-extension-linker-flags
(if test-async?
(append '("-pthread") (current-extension-linker-flags))
(current-extension-linker-flags))])
(compile-extension #t c o '())
(link-extension #t (list o) so))
(lambda ()
(with-handlers ([exn:fail:filesystem? (with-handlers ([exn:fail:filesystem?
(lambda (e) (lambda (e)
(eprintf "warning: could not delete ~e\n" test-tmp-dir))]) (eprintf "warning: could not delete ~e\n" so))])
(delete-directory/files test-tmp-dir)))))) (delete-file so))))))
;; Test arrays ;; Test arrays
(define _c7_list (_array/list _byte 7)) (define _c7_list (_array/list _byte 7))
@ -184,7 +179,7 @@
(define _borl (_union _byte _long)) (define _borl (_union _byte _long))
(define _ic7iorl (_union _ic7i _long)) (define _ic7iorl (_union _ic7i _long))
(define test-lib (ffi-lib (build-path test-tmp-dir "foreign-test"))) (define test-lib (ffi-lib "./foreign-test"))
(for ([n (in-range 5)]) (for ([n (in-range 5)])
(define (ffi name type) (get-ffi-obj name test-lib type)) (define (ffi name type) (get-ffi-obj name test-lib type))
@ -557,43 +552,6 @@
(define a-bar (bar (malloc 16 'raw))) (define a-bar (bar (malloc 16 'raw)))
(free a-bar)) (free a-bar))
(unless (eq? (system-type) 'windows)
;; saved-errno tests
(define check-multiple-of-ten
(get-ffi-obj 'check_multiple_of_ten test-lib (_fun #:save-errno 'posix _int -> _int)))
(test 0 check-multiple-of-ten 40)
(test -1 check-multiple-of-ten 42)
(test 2 saved-errno)
(saved-errno 5)
(test 5 saved-errno)
;; test saved-errno is thread-local
(define errno-from-thread #f)
(sync (thread (lambda () (check-multiple-of-ten 17) (set! errno-from-thread (saved-errno)))))
(test 5 saved-errno) ;; same as before
(test 7 (lambda () errno-from-thread)))
(when (eq? (system-type) 'windows)
;; Use functions from msvcrt.dll that are documented to affect errno.
;; (See note in /racket/src/foreign/foreign.rktc about Windows.)
(define msvcrt (ffi-lib "msvcrt.dll"))
(define ENOENT 2)
(define ERANGE 34)
(define _getcwd ;; sets errno = ERANGE if path longer than buffer
(get-ffi-obj '_getcwd msvcrt (_fun #:save-errno 'posix _bytes _int -> _void)))
(define _chdir ;; sets errno = ENOENT if path doesn't exist
(get-ffi-obj '_chdir msvcrt (_fun #:save-errno 'posix _string -> _int)))
(define (bad/ERANGE) (_getcwd (make-bytes 1) 1))
(define (bad/ENOENT) (_chdir "no-such-directory"))
(bad/ERANGE)
(test ERANGE saved-errno)
(test -1 bad/ENOENT)
(test ENOENT saved-errno)
;; test saved-errno is thread-local
(define errno-from-thread #f)
(sync (thread (lambda () (bad/ERANGE) (set! errno-from-thread (saved-errno)))))
(test ENOENT saved-errno) ;; same as above
(test ERANGE (lambda () errno-from-thread)))
(delete-test-files) (delete-test-files)
(let () (let ()
@ -1131,46 +1089,6 @@
;; ---------------------------------------- ;; ----------------------------------------
(define scheme_make_type
(get-ffi-obj 'scheme_make_type #f (_fun _string -> _short)))
(define scheme_register_type_gc_shape
(get-ffi-obj 'scheme_register_type_gc_shape #f (_fun _short (_list i _intptr) -> _void)))
(define SHAPE_STR_TERM 0)
(define SHAPE_STR_PTR_OFFSET 1)
(define-cstruct _tagged ([type-tag _short]
[obj1 _racket]
[non2 _intptr]
[obj3 _racket]
[non4 _intptr])
#:define-unsafe
#:malloc-mode 'tagged)
(define t (scheme_make_type "new-type"))
(scheme_register_type_gc_shape t (list SHAPE_STR_PTR_OFFSET tagged-obj1-offset
SHAPE_STR_PTR_OFFSET tagged-obj3-offset
SHAPE_STR_TERM))
(define obj1 (make-string 10))
(define obj2 (make-bytes 12))
(define obj3 (make-bytes 14))
(define obj4 (make-string 16))
(define obj2-addr (cast obj2 _racket _intptr))
(define obj4-addr (cast obj4 _racket _intptr))
(define o (make-tagged t obj1 obj2-addr obj3 obj4-addr))
(collect-garbage)
(eq? (tagged-obj1 o) obj1)
(eq? (tagged-obj3 o) obj3)
(= (tagged-non2 o) obj2-addr)
(= (tagged-non4 o) obj4-addr)
;; ----------------------------------------
(report-errs) (report-errs)
#| --- ignore everything below --- #| --- ignore everything below ---

View File

@ -110,9 +110,7 @@
(test 1 procedure-result-arity car) (test 1 procedure-result-arity car)
(test 1 procedure-result-arity list) (test 1 procedure-result-arity list)
(test 1 procedure-result-arity (procedure-reduce-arity car 1))
(test (arity-at-least 0) procedure-result-arity values) (test (arity-at-least 0) procedure-result-arity values)
(test (arity-at-least 0) procedure-result-arity (procedure-reduce-arity values 1))
(test (arity-at-least 0) procedure-result-arity call/cc) (test (arity-at-least 0) procedure-result-arity call/cc)
(let () (let ()
(struct s (x)) (struct s (x))
@ -126,13 +124,6 @@
(if (= 0 (random 1)) (if (= 0 (random 1))
1 1
(values 1 2)))) (values 1 2))))
(test #f procedure-result-arity
(procedure-reduce-arity
(λ ()
(if (= 0 (random 1))
1
(values 1 2)))
0))
(err/rt-test (procedure-result-arity 1) exn:fail?) (err/rt-test (procedure-result-arity 1) exn:fail?)
(test 1 procedure-result-arity (chaperone-procedure car values)) (test 1 procedure-result-arity (chaperone-procedure car values))
(test 1 procedure-result-arity (impersonate-procedure car (λ (x) 1))) (test 1 procedure-result-arity (impersonate-procedure car (λ (x) 1)))

View File

@ -34,290 +34,3 @@
(hash-copy (hash-copy
#hash([one . 1] [two . 2] [three . 3] [four . 4])) #hash([one . 1] [two . 2] [three . 3] [four . 4]))
h)) h))
(let ()
(define-syntax (define-hash-iterations-tester stx)
(syntax-case stx ()
[(_ tag -in-hash -in-pairs -in-keys -in-values)
#'(define-hash-iterations-tester tag
-in-hash -in-hash -in-hash
-in-pairs -in-pairs -in-pairs
-in-keys -in-keys -in-keys
-in-values -in-values -in-values)]
[(_ tag
-in-immut-hash -in-mut-hash -in-weak-hash
-in-immut-hash-pairs -in-mut-hash-pairs -in-weak-hash-pairs
-in-immut-hash-keys -in-mut-hash-keys -in-weak-hash-keys
-in-immut-hash-values -in-mut-hash-values -in-weak-hash-values)
(with-syntax
([name
(datum->syntax #'tag
(string->symbol
(format "test-hash-iters-~a" (syntax->datum #'tag))))])
#'(define (name lst1 lst2)
(define ht/immut (make-immutable-hash (map cons lst1 lst2)))
(define ht/mut (make-hash (map cons lst1 lst2)))
(define ht/weak (make-weak-hash (map cons lst1 lst2)))
(define fake-ht/immut
(chaperone-hash
ht/immut
(lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
(lambda (h k v) values k v) ; set-proc
(lambda (h k) k) ; remove-proc
(lambda (h k) k))) ; key-proc
(define fake-ht/mut
(impersonate-hash
ht/mut
(lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
(lambda (h k v) values k v) ; set-proc
(lambda (h k) k) ; remove-proc
(lambda (h k) k))) ; key-proc
(define fake-ht/weak
(impersonate-hash
ht/weak
(lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
(lambda (h k v) values k v) ; set-proc
(lambda (h k) k) ; remove-proc
(lambda (h k) k))) ; key-proc
(define ht/immut/seq (-in-immut-hash ht/immut))
(define ht/mut/seq (-in-mut-hash ht/mut))
(define ht/weak/seq (-in-weak-hash ht/weak))
(define ht/immut-pair/seq (-in-immut-hash-pairs ht/immut))
(define ht/mut-pair/seq (-in-mut-hash-pairs ht/mut))
(define ht/weak-pair/seq (-in-weak-hash-pairs ht/weak))
(define ht/immut-keys/seq (-in-immut-hash-keys ht/immut))
(define ht/mut-keys/seq (-in-mut-hash-keys ht/mut))
(define ht/weak-keys/seq (-in-weak-hash-keys ht/weak))
(define ht/immut-vals/seq (-in-immut-hash-values ht/immut))
(define ht/mut-vals/seq (-in-mut-hash-values ht/mut))
(define ht/weak-vals/seq (-in-weak-hash-values ht/weak))
(test #t =
(for/sum ([(k v) (-in-immut-hash ht/immut)]) (+ k v))
(for/sum ([(k v) (-in-mut-hash ht/mut)]) (+ k v))
(for/sum ([(k v) (-in-weak-hash ht/weak)]) (+ k v))
(for/sum ([(k v) (-in-immut-hash fake-ht/immut)]) (+ k v))
(for/sum ([(k v) (-in-mut-hash fake-ht/mut)]) (+ k v))
(for/sum ([(k v) (-in-weak-hash fake-ht/weak)]) (+ k v))
(for/sum ([(k v) ht/immut/seq]) (+ k v))
(for/sum ([(k v) ht/mut/seq]) (+ k v))
(for/sum ([(k v) ht/weak/seq]) (+ k v))
(for/sum ([k+v (-in-immut-hash-pairs ht/immut)])
(+ (car k+v) (cdr k+v)))
(for/sum ([k+v (-in-mut-hash-pairs ht/mut)])
(+ (car k+v) (cdr k+v)))
(for/sum ([k+v (-in-weak-hash-pairs ht/weak)])
(+ (car k+v) (cdr k+v)))
(for/sum ([k+v (-in-immut-hash-pairs fake-ht/immut)])
(+ (car k+v) (cdr k+v)))
(for/sum ([k+v (-in-mut-hash-pairs fake-ht/mut)])
(+ (car k+v) (cdr k+v)))
(for/sum ([k+v (-in-weak-hash-pairs fake-ht/weak)])
(+ (car k+v) (cdr k+v)))
(for/sum ([k+v ht/immut-pair/seq]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v ht/mut-pair/seq]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v ht/weak-pair/seq]) (+ (car k+v) (cdr k+v)))
(+ (for/sum ([k (-in-immut-hash-keys ht/immut)]) k)
(for/sum ([v (-in-immut-hash-values ht/immut)]) v))
(+ (for/sum ([k (-in-mut-hash-keys ht/mut)]) k)
(for/sum ([v (-in-mut-hash-values ht/mut)]) v))
(+ (for/sum ([k (-in-weak-hash-keys ht/weak)]) k)
(for/sum ([v (-in-weak-hash-values ht/weak)]) v))
(+ (for/sum ([k (-in-immut-hash-keys fake-ht/immut)]) k)
(for/sum ([v (-in-immut-hash-values fake-ht/immut)]) v))
(+ (for/sum ([k (-in-mut-hash-keys fake-ht/mut)]) k)
(for/sum ([v (-in-mut-hash-values fake-ht/mut)]) v))
(+ (for/sum ([k (-in-weak-hash-keys fake-ht/weak)]) k)
(for/sum ([v (-in-weak-hash-values fake-ht/weak)]) v))
(+ (for/sum ([k ht/immut-keys/seq]) k)
(for/sum ([v ht/immut-vals/seq]) v))
(+ (for/sum ([k ht/mut-keys/seq]) k)
(for/sum ([v ht/mut-vals/seq]) v))
(+ (for/sum ([k ht/weak-keys/seq]) k)
(for/sum ([v ht/weak-vals/seq]) v)))
(test #t =
(for/sum ([(k v) (-in-immut-hash ht/immut)]) k)
(for/sum ([(k v) (-in-mut-hash ht/mut)]) k)
(for/sum ([(k v) (-in-weak-hash ht/weak)]) k)
(for/sum ([(k v) (-in-immut-hash fake-ht/immut)]) k)
(for/sum ([(k v) (-in-mut-hash fake-ht/mut)]) k)
(for/sum ([(k v) (-in-weak-hash fake-ht/weak)]) k)
(for/sum ([(k v) ht/immut/seq]) k)
(for/sum ([(k v) ht/mut/seq]) k)
(for/sum ([(k v) ht/weak/seq]) k)
(for/sum ([k+v (-in-immut-hash-pairs ht/immut)]) (car k+v))
(for/sum ([k+v (-in-mut-hash-pairs ht/mut)]) (car k+v))
(for/sum ([k+v (-in-weak-hash-pairs ht/weak)]) (car k+v))
(for/sum ([k+v (-in-immut-hash-pairs fake-ht/immut)]) (car k+v))
(for/sum ([k+v (-in-mut-hash-pairs fake-ht/mut)]) (car k+v))
(for/sum ([k+v (-in-weak-hash-pairs fake-ht/weak)]) (car k+v))
(for/sum ([k+v ht/immut-pair/seq]) (car k+v))
(for/sum ([k+v ht/mut-pair/seq]) (car k+v))
(for/sum ([k+v ht/weak-pair/seq]) (car k+v))
(for/sum ([k (-in-immut-hash-keys ht/immut)]) k)
(for/sum ([k (-in-mut-hash-keys ht/mut)]) k)
(for/sum ([k (-in-weak-hash-keys ht/weak)]) k)
(for/sum ([k (-in-immut-hash-keys fake-ht/immut)]) k)
(for/sum ([k (-in-mut-hash-keys fake-ht/mut)]) k)
(for/sum ([k (-in-weak-hash-keys fake-ht/weak)]) k)
(for/sum ([k ht/immut-keys/seq]) k)
(for/sum ([k ht/mut-keys/seq]) k)
(for/sum ([k ht/weak-keys/seq]) k))
(test #t =
(for/sum ([(k v) (-in-immut-hash ht/immut)]) v)
(for/sum ([(k v) (-in-mut-hash ht/mut)]) v)
(for/sum ([(k v) (-in-weak-hash ht/weak)]) v)
(for/sum ([(k v) (-in-immut-hash fake-ht/immut)]) v)
(for/sum ([(k v) (-in-mut-hash fake-ht/mut)]) v)
(for/sum ([(k v) (-in-weak-hash fake-ht/weak)]) v)
(for/sum ([(k v) ht/immut/seq]) v)
(for/sum ([(k v) ht/mut/seq]) v)
(for/sum ([(k v) ht/weak/seq]) v)
(for/sum ([k+v (-in-immut-hash-pairs ht/immut)]) (cdr k+v))
(for/sum ([k+v (-in-mut-hash-pairs ht/mut)]) (cdr k+v))
(for/sum ([k+v (-in-weak-hash-pairs ht/weak)]) (cdr k+v))
(for/sum ([k+v (-in-immut-hash-pairs fake-ht/immut)]) (cdr k+v))
(for/sum ([k+v (-in-mut-hash-pairs fake-ht/mut)]) (cdr k+v))
(for/sum ([k+v (-in-weak-hash-pairs fake-ht/weak)]) (cdr k+v))
(for/sum ([k+v ht/immut-pair/seq]) (cdr k+v))
(for/sum ([k+v ht/mut-pair/seq]) (cdr k+v))
(for/sum ([k+v ht/weak-pair/seq]) (cdr k+v))
(for/sum ([v (-in-immut-hash-values ht/immut)]) v)
(for/sum ([v (-in-mut-hash-values ht/mut)]) v)
(for/sum ([v (-in-weak-hash-values ht/weak)]) v)
(for/sum ([v (-in-immut-hash-values fake-ht/immut)]) v)
(for/sum ([v (-in-mut-hash-values fake-ht/mut)]) v)
(for/sum ([v (-in-weak-hash-values fake-ht/weak)]) v)
(for/sum ([v ht/immut-vals/seq]) v)
(for/sum ([v ht/mut-vals/seq]) v)
(for/sum ([v ht/weak-vals/seq]) v))))]))
(define-hash-iterations-tester generic
in-hash in-hash-pairs in-hash-keys in-hash-values)
(define-hash-iterations-tester specific
in-immutable-hash in-mutable-hash in-weak-hash
in-immutable-hash-pairs in-mutable-hash-pairs in-weak-hash-pairs
in-immutable-hash-keys in-mutable-hash-keys in-weak-hash-keys
in-immutable-hash-values in-mutable-hash-values in-weak-hash-values)
(define lst1 (build-list 10 values))
(define lst2 (build-list 10 add1))
(test-hash-iters-generic lst1 lst2)
(test-hash-iters-specific lst1 lst2)
(define lst3 (build-list 100000 values))
(define lst4 (build-list 100000 add1))
(test-hash-iters-generic lst3 lst4)
(test-hash-iters-specific lst3 lst4))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Use keys that are a multile of a power of 2 to
; get "almost" collisions that force the hash table
; to use a deeper tree.
(let ()
(define vals (for/list ([j (in-range 100)]) (add1 j)))
(define sum-vals (for/sum ([v (in-list vals)]) v))
(for ([shift (in-range 150)])
(define keys (for/list ([j (in-range 100)])
(arithmetic-shift j shift)))
; test first the weak table to ensure the keys are not collected
(define ht/weak (make-weak-hash (map cons keys vals)))
(define sum-ht/weak (for/sum ([v (in-weak-hash-values ht/weak)]) v))
(define ht/mut (make-hash (map cons keys vals)))
(define sum-ht/mut (for/sum ([v (in-mutable-hash-values ht/mut)]) v))
(define ht/immut (make-immutable-hash (map cons keys vals)))
(define sum-ht/immut (for/sum ([v (in-immutable-hash-values ht/immut)]) v))
(test #t = sum-vals sum-ht/weak sum-ht/mut sum-ht/immut)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ()
(define err-msg "no element at index")
;; Check that unsafe-weak-hash-iterate- ops do not segfault
;; when a key is collected before access; throw exception instead.
;; They are used for safe iteration in in-weak-hash- sequence forms
(let ()
(define ht #f)
(let ([lst (build-list 10 add1)])
(set! ht (make-weak-hash `((,lst . val)))))
(define i (hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t list? (hash-iterate-key ht i))
(test #t equal? (hash-iterate-value ht i) 'val)
(test #t equal? (cdr (hash-iterate-pair ht i)) 'val)
(test #t equal?
(call-with-values (lambda () (hash-iterate-key+value ht i)) cons)
'((1 2 3 4 5 6 7 8 9 10) . val))
(test #t boolean? (hash-iterate-next ht i))
;; collect key, everything should error
(collect-garbage)(collect-garbage)(collect-garbage)
(test #t boolean? (hash-iterate-first ht))
(err/rt-test (hash-iterate-key ht i) exn:fail:contract? err-msg)
(err/rt-test (hash-iterate-value ht i) exn:fail:contract? err-msg)
(err/rt-test (hash-iterate-pair ht i) exn:fail:contract? err-msg)
(err/rt-test (hash-iterate-key+value ht i) exn:fail:contract? err-msg)
(err/rt-test (hash-iterate-next ht i) exn:fail:contract? err-msg))
;; Check that unsafe mutable hash table operations do not segfault
;; after getting valid index from unsafe-mutable-hash-iterate-first and -next.
;; Throw exception instead since they're used for safe iteration
(let ()
(define ht (make-hash '((a . b))))
(define i (hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t equal? (hash-iterate-key ht i) 'a)
(test #t equal? (hash-iterate-value ht i) 'b)
(test #t equal? (hash-iterate-pair ht i) '(a . b))
(test #t equal?
(call-with-values (lambda () (hash-iterate-key+value ht i)) cons)
'(a . b))
(test #t boolean? (hash-iterate-next ht i))
;; remove element, everything should error
(hash-remove! ht 'a)
(test #t boolean? (hash-iterate-first ht))
(err/rt-test (hash-iterate-key ht i) exn:fail:contract? err-msg)
(err/rt-test (hash-iterate-value ht i) exn:fail:contract? err-msg)
(err/rt-test (hash-iterate-pair ht i) exn:fail:contract? err-msg)
(err/rt-test (hash-iterate-key+value ht i) exn:fail:contract? err-msg)
(err/rt-test (hash-iterate-next ht i) exn:fail:contract? err-msg))
(let ()
(define ht (make-weak-hash '((a . b))))
(define i (hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t equal? (hash-iterate-key ht i) 'a)
(test #t equal? (hash-iterate-value ht i) 'b)
(test #t equal? (hash-iterate-pair ht i) '(a . b))
(test #t equal? (call-with-values
(lambda () (hash-iterate-key+value ht i)) cons)
'(a . b))
(test #t boolean? (hash-iterate-next ht i))
;; remove element, everything should error
(hash-remove! ht 'a)
(test #t boolean? (hash-iterate-first ht))
(err/rt-test (hash-iterate-key ht i) exn:fail:contract?)
(err/rt-test (hash-iterate-value ht i) exn:fail:contract?)
(err/rt-test (hash-iterate-pair ht i) exn:fail:contract?)
(err/rt-test (hash-iterate-key+value ht i) exn:fail:contract?)
(err/rt-test (hash-iterate-next ht i) exn:fail:contract?)))
(report-errs)

View File

@ -456,16 +456,7 @@
(test '(()) sorted-combs '(4 1 2 5 3) 0) (test '(()) sorted-combs '(4 1 2 5 3) 0)
(test (test
'((1 2) (1 3) (1 5) (2 3) (2 5) (4 1) (4 2) (4 3) (4 5) (5 3)) '((1 2) (1 3) (1 5) (2 3) (2 5) (4 1) (4 2) (4 3) (4 5) (5 3))
sorted-combs '(4 1 2 5 3) 2) sorted-combs '(4 1 2 5 3) 2))
(test
'((1 2 3) (1 2 5) (1 5 3) (2 5 3) (4 1 2) (4 1 3) (4 1 5) (4 2 3) (4 2 5) (4 5 3))
sorted-combs '(4 1 2 5 3) 3)
(test
21
(lambda (n k)
(length (combinations n k)))
'(1 2 3 4 5 6 7)
5))
;; ---------- permutations ---------- ;; ---------- permutations ----------
(let () (let ()

View File

@ -1564,50 +1564,6 @@
(regexp-match? #rx"cannot use identifier tainted by macro transformation" (regexp-match? #rx"cannot use identifier tainted by macro transformation"
(exn-message exn)))) (exn-message exn))))
;; ----------------------------------------
;; Check that lifting works right at the top level:
(module macro-that-introduces-a-lifted-one racket
(define-syntax (m stx)
(syntax-local-lift-expression #'1))
(m))
(dynamic-require ''macro-that-introduces-a-lifted-one #f)
(test 1 values (parameterize ([current-namespace
(module->namespace ''macro-that-introduces-a-lifted-one)])
(eval '(values m))))
;; ----------------------------------------
;; Check that expanded references in submodule
;; have the right binding info for 'origin
(let ()
(define m
'(module m racket/base
(define-syntax-rule (m) 1)
(module+ main
(m))))
(define m-expanded
(parameterize ([current-namespace (make-base-namespace)])
(expand m)))
(define-values (bind-m ref-m)
(syntax-case m-expanded ()
[(module _ racket/base
(#%module-begin
_
(define-syntaxes
(m)
_)
(module* main #f
(#%module-begin-2
_
(#%app1 call-with-values (lambda () ONE) print-values)))))
(values #'m (car (syntax-property #'ONE 'origin)))]))
(test #t free-identifier=? bind-m ref-m))
;; ---------------------------------------- ;; ----------------------------------------
(report-errs) (report-errs)

View File

@ -715,9 +715,9 @@
(err/rt-test (inexact->exact -inf.0)) (err/rt-test (inexact->exact -inf.0))
(err/rt-test (inexact->exact +nan.0)) (err/rt-test (inexact->exact +nan.0))
(err/rt-test (inexact->exact +inf.f) (lambda (exn) (regexp-match? #rx"[+]inf[.]f" (exn-message exn)))) (err/rt-test (inexact->exact +inf.f) (lambda (exn) (regexp-match? #rx"[+]inf[.]f" (exn-messgae exn))))
(err/rt-test (inexact->exact -inf.f) (lambda (exn) (regexp-match? #rx"[-]inf[.]f" (exn-message exn)))) (err/rt-test (inexact->exact -inf.f) (lambda (exn) (regexp-match? #rx"[-]inf[.]f" (exn-messgae exn))))
(err/rt-test (inexact->exact +nan.f) (lambda (exn) (regexp-match? #rx"[+]nan[.]f" (exn-message exn)))) (err/rt-test (inexact->exact +nan.f) (lambda (exn) (regexp-match? #rx"[+]nan[.]f" (exn-messgae exn))))
(test 2.0f0 real->single-flonum 2) (test 2.0f0 real->single-flonum 2)
(test 2.25f0 real->single-flonum 2.25) (test 2.25f0 real->single-flonum 2.25)
@ -998,8 +998,6 @@
(test 0.0 modulo -4.0 2) (test 0.0 modulo -4.0 2)
(test 0.0 modulo 4.0 -2) (test 0.0 modulo 4.0 -2)
(test 0.0 modulo -4.0 -2) (test 0.0 modulo -4.0 -2)
(test 1.0 modulo 21.0 2)
(test 1.0 modulo -21.0 2)
(test 0 remainder 4 2) (test 0 remainder 4 2)
(test 0 remainder -4 2) (test 0 remainder -4 2)
(test 0 remainder 4 -2) (test 0 remainder 4 -2)
@ -1008,8 +1006,6 @@
(test 0.0 remainder -4.0 2) (test 0.0 remainder -4.0 2)
(test 0.0 remainder 4.0 -2) (test 0.0 remainder 4.0 -2)
(test 0.0 remainder -4.0 -2) (test 0.0 remainder -4.0 -2)
(test 1.0 remainder 21.0 2)
(test -1.0 remainder -21.0 2)
(test 0 modulo 0 5.0) (test 0 modulo 0 5.0)
(test 0 modulo 0 -5.0) (test 0 modulo 0 -5.0)
(test 0 remainder 0 5.0) (test 0 remainder 0 5.0)
@ -1114,15 +1110,6 @@
(err/rt-test (remainder 2 1+2i)) (err/rt-test (remainder 2 1+2i))
(err/rt-test (modulo 2 1+2i)) (err/rt-test (modulo 2 1+2i))
(test (- (expt 2 65) (expt 2 62))
modulo (- (+ (expt 2 62) (expt 2 65))) (expt 2 65))
(test (- (expt 2 33) (expt 2 30))
modulo (- (+ (expt 2 30) (expt 2 33))) (expt 2 33))
(test (- (expt 2 62))
remainder (- (+ (expt 2 62) (expt 2 65))) (expt 2 65))
(test (- (expt 2 30))
remainder (- (+ (expt 2 30) (expt 2 33))) (expt 2 33))
(test 10 bitwise-ior 10) (test 10 bitwise-ior 10)
(test 10 bitwise-and 10) (test 10 bitwise-and 10)
(test 10 bitwise-xor 10) (test 10 bitwise-xor 10)

File diff suppressed because it is too large Load Diff

View File

@ -71,10 +71,6 @@
(arity-test complete-path? 1 1) (arity-test complete-path? 1 1)
(err/rt-test (complete-path? 'a)) (err/rt-test (complete-path? 'a))
(define original-dir (current-directory))
(define work-dir (make-temporary-file "path~a" 'directory))
(current-directory work-dir)
(call-with-output-file "tmp6" void #:exists 'replace) (call-with-output-file "tmp6" void #:exists 'replace)
(define existant "tmp6") (define existant "tmp6")
@ -224,9 +220,6 @@
(test #t delete-directory/tf "down") (test #t delete-directory/tf "down")
(test #f delete-directory/tf "down") (test #f delete-directory/tf "down")
(current-directory original-dir)
(delete-directory work-dir)
; Redefine these per-platform ; Redefine these per-platform
(define drives null) (define drives null)
(define nondrive-roots (list "/")) (define nondrive-roots (list "/"))
@ -882,12 +875,12 @@
(test (bytes->path #"/home/mflatt/././~") build-path (bytes->path #"/home/mflatt") (bytes->path #"././~")) (test (bytes->path #"/home/mflatt/././~") build-path (bytes->path #"/home/mflatt") (bytes->path #"././~"))
(test (bytes->path #"./~") build-path (bytes->path #"./~")) (test (bytes->path #"./~") build-path (bytes->path #"./~"))
(when use-fs? (when use-fs?
(let ([dir (make-temporary-file "tmp79~a" 'directory)]) (let ([dir "tmp79"])
(unless (directory-exists? dir) (unless (directory-exists? dir)
(make-directory dir)) (make-directory dir))
(close-output-port (open-output-file (build-path dir "~me") #:exists 'replace)) (close-output-port (open-output-file "tmp79/~me" #:exists 'replace))
(test (list (bytes->path #"~me")) directory-list dir) (test (list (bytes->path #"~me")) directory-list dir)
(delete-file (build-path dir (bytes->path #"~me"))) (delete-file (build-path "tmp79" (bytes->path #"~me")))
(delete-directory dir))) (delete-directory dir)))
(void))) (void)))

View File

@ -3,15 +3,6 @@
(Section 'port) (Section 'port)
(define (call-in-temporary-directory thunk)
(define dir (make-temporary-file "tmp~a" 'directory))
(dynamic-wind
void
(lambda ()
(parameterize ([current-directory dir])
(thunk)))
(lambda () (delete-directory dir))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for progress events and commits ;; Tests for progress events and commits
@ -66,15 +57,12 @@
(test-pipe #t)) (test-pipe #t))
(let ([test-file (let ([test-file
(lambda (commit-eof?) (lambda (commit-eof?)
(call-in-temporary-directory (with-output-to-file "tmp8" #:exists 'truncate/replace
(lambda () (lambda () (write-string "hello")))
(with-output-to-file "tmp8" (define p (open-input-file "tmp8"))
#:exists 'truncate/replace (test-hello-port p commit-eof?)
(lambda () (write-string "hello"))) (close-input-port p)
(define p (open-input-file "tmp8")) (delete-file "tmp8"))])
(test-hello-port p commit-eof?)
(close-input-port p)
(delete-file "tmp8"))))])
(test-file #f) (test-file #f)
(test-file #t)) (test-file #t))
@ -789,16 +777,14 @@
(count-lines! in) (count-lines! in)
(check in)) (check in))
(let () (let ()
(call-in-temporary-directory (with-output-to-file "tmp8"
(lambda () #:exists 'truncate/replace
(with-output-to-file "tmp8" (lambda () (display "12345")))
#:exists 'truncate/replace (define in (open-input-file "tmp8"))
(lambda () (display "12345"))) (count-lines! in)
(define in (open-input-file "tmp8")) (check in)
(count-lines! in) (close-input-port in)
(check in) (delete-file "tmp8")))
(close-input-port in)
(delete-file "tmp8")))))
(check-all void) (check-all void)
(check-all port-count-lines!)) (check-all port-count-lines!))

View File

@ -464,42 +464,6 @@
;; let's check that 3/4 were collected: ;; let's check that 3/4 were collected:
(test #t < (hash-count ht) (* 1/4 (length l))))) (test #t < (hash-count ht) (* 1/4 (length l)))))
;;----------------------------------------
;; Check that it works to apply a continuation that shares with
;; an enclosing continuation, where a runstack overflow happens
;; between the continuations
(let ()
(define N 100)
(define N2 10)
(define M 10)
(define p (make-continuation-prompt-tag))
(define (grab n m k-prev q)
(cond
[(positive? n)
(let ([x (grab (sub1 n) m k-prev q)])
(lambda () x))]
[(positive? m)
((call/cc
(lambda (k)
(grab N2 (sub1 m) k q))
p))]
[(positive? q)
(call-with-continuation-prompt
(lambda ()
(k-prev
(lambda ()
(grab N M void (sub1 q)))))
p)]
[else void]))
(call-with-continuation-prompt
(lambda ()
(grab N M void 10))
p))
;;---------------------------------------- ;;----------------------------------------
(report-errs) (report-errs)

View File

@ -531,7 +531,7 @@
(parameterize ([sandbox-output 'bytes] (parameterize ([sandbox-output 'bytes]
[sandbox-error-output current-output-port] [sandbox-error-output current-output-port]
[sandbox-memory-limit 2] [sandbox-memory-limit 2]
[sandbox-eval-limits '(2.5 1)]) [sandbox-eval-limits '(0.25 1)])
(make-base-evaluator!)) (make-base-evaluator!))
;; GCing is needed to allow these to happen (note: the memory limit is very ;; GCing is needed to allow these to happen (note: the memory limit is very
;; tight here, this test usually fails if the sandbox library is not ;; tight here, this test usually fails if the sandbox library is not

View File

@ -57,9 +57,4 @@
(test '(1 3) stream->list (stream-filter odd? '(1 2 3))) (test '(1 3) stream->list (stream-filter odd? '(1 2 3)))
(test '(1 a 2 a 3) stream->list (stream-add-between '(1 2 3) 'a)) (test '(1 a 2 a 3) stream->list (stream-add-between '(1 2 3) 'a))
(test 4 'for/stream (stream-ref (for/stream ([x '(1 2 3)]) (* x x)) 1))
(test 6 'for*/stream (stream-ref (for*/stream ([x '(1 2 3)] [y '(1 2 3)]) (* x y)) 7))
(test 1 'for/stream (stream-first (for*/stream ([x '(1 0)]) (/ x))))
(test 625 'for/stream (stream-ref (for/stream ([x (in-naturals)]) (* x x)) 25))
(report-errs) (report-errs)

View File

@ -2296,50 +2296,4 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ([zo-bounce
(lambda (stx)
(define o (open-output-bytes))
(write (compile #`(quote-syntax #,stx)) o)
(eval
(parameterize ([read-accept-compiled #t])
(read (open-input-bytes (get-output-bytes o))))))])
(test #\{ syntax-property (zo-bounce #'{0}) 'paren-shape)
(test #\[ syntax-property (zo-bounce #'[0]) 'paren-shape)
(test #f syntax-property (zo-bounce (syntax-property #'[0] 'something-else 1))
'something-else)
(test 1 syntax-property (zo-bounce (syntax-property #'[0] 'something-else 1 #t))
'something-else)
(define s0 (syntax-property
(syntax-property
(syntax-property #'[0]
'something-else 1 #t)
'something-not-saved 2)
'a-third-thing 3 #t))
(define s (zo-bounce s0))
(test #\[ syntax-property s 'paren-shape)
(test #\[ syntax-property s0 'paren-shape)
(test #t syntax-property-preserved? s 'paren-shape)
(test #t syntax-property-preserved? s0 'paren-shape)
(test 1 syntax-property s 'something-else)
(test 1 syntax-property s0 'something-else)
(test #t syntax-property-preserved? s 'something-else)
(test #t syntax-property-preserved? s0 'something-else)
(test #f syntax-property s 'something-not-saved)
(test 2 syntax-property s0 'something-not-saved)
(test #f syntax-property-preserved? s 'something-not-saved)
(test #f syntax-property-preserved? s0 'something-not-saved)
(test 3 syntax-property s 'a-third-thing)
(test 3 syntax-property s0 'a-third-thing)
(test #t syntax-property-preserved? s 'a-third-thing)
(test #t syntax-property-preserved? s0 'a-third-thing)
;; 'paren-shape has a special default:
(test #t syntax-property-preserved? (syntax-property #'#f 'paren-shape #\() 'paren-shape))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs) (report-errs)

View File

@ -155,19 +155,5 @@
;; ---------------------------------------- ;; ----------------------------------------
(let ()
(define-syntax-rule (mac-zero) 0)
(define-syntax-parameter x (make-rename-transformer #'mac-zero))
(define-syntax-rule (mac-one) 1)
(define-syntax y (make-rename-transformer #'x))
(test #t = (mac-zero) 0)
(test #t = (mac-one) 1)
(test #t = (x) 0)
(test #t = (y) 0)
(test #t = (syntax-parameterize ([y (make-rename-transformer #'mac-one)]) (x)) 1)
(test #t = (syntax-parameterize ([y (make-rename-transformer #'mac-one)]) (y)) 1))
;; ----------------------------------------
(report-errs) (report-errs)

View File

@ -234,16 +234,12 @@
(wrap-evt (wrap-evt
(alarm-evt (+ (current-inexact-milliseconds) (* 1000 amt))) (alarm-evt (+ (current-inexact-milliseconds) (* 1000 amt)))
(lambda (v) amt)))))]) (lambda (v) amt)))))])
(define fast SYNC-SLEEP-DELAY) (test #f sync/timeout 0.1 (make-delay 0.15) (make-delay 0.2))
(define slow1 (* 100 SYNC-SLEEP-DELAY)) (test 0.15 sync/timeout 18 (make-delay 0.15) (make-delay 0.2))
(define slow2 (* 99 SYNC-SLEEP-DELAY)) (test 0.15 sync/timeout 18 (make-delay 0.2) (make-delay 0.15))
(test #f sync/timeout fast (make-delay slow1) (make-delay slow1)) (test 0.15 sync/timeout 0.18 (make-delay 0.15) (make-delay 0.2))
(test fast sync/timeout slow1 (make-delay fast) (make-delay slow2)) (test 0.15 sync/timeout 18
(test fast sync/timeout slow1 (make-delay slow2) (make-delay fast)) (choice-evt (make-delay 0.2) (make-delay 0.15))))
(test fast sync/timeout slow2 (make-delay fast) (make-delay slow1))
(test fast sync/timeout slow2 (make-delay slow1) (make-delay fast))
(test fast sync/timeout slow2
(choice-evt (make-delay slow1) (make-delay fast))))
;;check flattening of choice evts returned by a guard: ;;check flattening of choice evts returned by a guard:
(let () (let ()

View File

@ -23,7 +23,7 @@
The test form has these two shapes: The test form has these two shapes:
(test <expected> <procedure> <argument1> <argument2> ...) (test <expected> <procdure> <argument1> <argument2> ...)
(test <expected> <symbolic-name> <expression>) (test <expected> <symbolic-name> <expression>)
@ -217,6 +217,7 @@ transcript.
(syntax (syntax
(thunk-error-test (err:mz:lambda () e) (quote-syntax e) exn?))] (thunk-error-test (err:mz:lambda () e) (quote-syntax e) exn?))]
[(_ e exn? msg-rx) [(_ e exn? msg-rx)
(regexp? (syntax-e #'msg-rx))
#'(thunk-error-test #'(thunk-error-test
(err:mz:lambda () e) (err:mz:lambda () e)
(quote-syntax e) (quote-syntax e)

View File

@ -579,104 +579,4 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ()
(define err-msg "no element at index")
;; Check that unsafe-weak-hash-iterate- ops do not segfault
;; when a key is collected before access; throw exception instead.
;; They are used for safe iteration in in-weak-hash- sequence forms
(let ()
(define ht #f)
(let ([lst (build-list 10 add1)])
(set! ht (make-weak-hash `((,lst . val)))))
(define i (unsafe-weak-hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t list? (unsafe-weak-hash-iterate-key ht i))
(test #t equal? (unsafe-weak-hash-iterate-value ht i) 'val)
(test #t equal? (cdr (unsafe-weak-hash-iterate-pair ht i)) 'val)
(test #t equal?
(call-with-values
(lambda () (unsafe-weak-hash-iterate-key+value ht i)) cons)
'((1 2 3 4 5 6 7 8 9 10) . val))
(test #t boolean? (unsafe-weak-hash-iterate-next ht i))
;; collect key, everything should error (but not segfault)
(collect-garbage)(collect-garbage)(collect-garbage)
(test #t boolean? (unsafe-weak-hash-iterate-first ht))
(err/rt-test
(unsafe-weak-hash-iterate-key ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-weak-hash-iterate-value ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-weak-hash-iterate-pair ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-weak-hash-iterate-key+value ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-weak-hash-iterate-next ht i) exn:fail:contract? err-msg))
;; Check that unsafe mutable hash table operations do not segfault
;; after getting valid index from unsafe-mutable-hash-iterate-first and -next.
;; Throw exception instead since they're used for safe iteration
(let ()
(define ht (make-hash '((a . b))))
(define i (unsafe-mutable-hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t equal? (unsafe-mutable-hash-iterate-key ht i) 'a)
(test #t equal? (unsafe-mutable-hash-iterate-value ht i) 'b)
(test #t equal? (unsafe-mutable-hash-iterate-pair ht i) '(a . b))
(test #t equal?
(call-with-values
(lambda () (unsafe-mutable-hash-iterate-key+value ht i)) cons)
'(a . b))
(test #t boolean? (unsafe-mutable-hash-iterate-next ht i))
;; remove element, everything should error (but not segfault)
(hash-remove! ht 'a)
(test #t boolean? (unsafe-mutable-hash-iterate-first ht))
(err/rt-test
(unsafe-mutable-hash-iterate-key ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-mutable-hash-iterate-value ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-mutable-hash-iterate-pair ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-mutable-hash-iterate-key+value ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-mutable-hash-iterate-next ht i) exn:fail:contract? err-msg))
(let ()
(define ht (make-weak-hash '((a . b))))
(define i (unsafe-weak-hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t equal? (unsafe-weak-hash-iterate-key ht i) 'a)
(test #t equal? (unsafe-weak-hash-iterate-value ht i) 'b)
(test #t equal? (unsafe-weak-hash-iterate-pair ht i) '(a . b))
(test #t equal?
(call-with-values
(lambda () (unsafe-weak-hash-iterate-key+value ht i)) cons)
'(a . b))
(test #t boolean? (unsafe-weak-hash-iterate-next ht i))
;; remove element, everything should error (but not segfault)
(hash-remove! ht 'a)
(test #t boolean? (unsafe-weak-hash-iterate-first ht))
(err/rt-test
(unsafe-weak-hash-iterate-key ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-weak-hash-iterate-value ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-weak-hash-iterate-pair ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-weak-hash-iterate-key+value ht i) exn:fail:contract? err-msg)
(err/rt-test
(unsafe-weak-hash-iterate-next ht i) exn:fail:contract? err-msg)))
(report-errs) (report-errs)

View File

@ -22,9 +22,6 @@
;; for `json` tests ;; for `json` tests
"at-exp-lib" "at-exp-lib"
;; for contract tests
"option-contract-lib"
;; used by the planet packages tested by the pkg tests ;; used by the planet packages tested by the pkg tests
"srfi-lib" "srfi-lib"

View File

@ -27,5 +27,5 @@
;; ok if these don't raise unbound id errors ;; ok if these don't raise unbound id errors
(check-equal? (with-output-to-string (lambda () (write (tuple 5)))) "#0=#0#") (check-equal? (with-output-to-string (lambda () (write (tuple 5)))) "#0=#0#")
(check-equal? (tuple 5) (tuple 5)) (check-equal? (tuple 5) (tuple 5))
(check-equal? (equal-hash-code (tuple 5)) 55) (check-equal? (equal-hash-code (tuple 5)) 54)
(check-equal? (equal-secondary-hash-code (tuple 5)) 46)) (check-equal? (equal-secondary-hash-code (tuple 5)) 45))

View File

@ -16,5 +16,5 @@
(check-false (equal? (kons 1 2) 2)) (check-false (equal? (kons 1 2) 2))
(check-false (equal? 2 (kons 1 2))) (check-false (equal? 2 (kons 1 2)))
(check-false (equal? (kons 1 2) (kons 3 4))) (check-false (equal? (kons 1 2) (kons 3 4)))
(check-equal? (equal-hash-code (kons 1 2)) 62) (check-equal? (equal-hash-code (kons 1 2)) 61)
) )

View File

@ -1,35 +1,22 @@
-----BEGIN CERTIFICATE----- -----BEGIN CERTIFICATE-----
MIIGGDCCBACgAwIBAgIJAIoDto5pw5l0MA0GCSqGSIb3DQEBCwUAMIGXMQswCQYD MIIDnTCCAoWgAwIBAgIJAI1o0DxhqPigMA0GCSqGSIb3DQEBBAUAMIGEMRQwEgYD
VQQGEwJVUzEQMA4GA1UECAwHUmFja2V0YTEUMBIGA1UEBwwLUmFja2V0dmlsbGUx VQQDEwtva2NvbXBzLmNvbTELMAkGA1UECBMCT0gxCzAJBgNVBAYTAlVTMR8wHQYJ
GTAXBgNVBAoMEFRlc3RpbmcgRXhhbXBsZXMxEDAOBgNVBAsMB1Rlc3RpbmcxFDAS KoZIhvcNAQkBFhByb290QG9rY29tcHMuY29tMRkwFwYDVQQKExBPSyBDb21wdXRl
BgNVBAMMC2V4YW1wbGUuY29tMR0wGwYJKoZIhvcNAQkBFg5jYUBleGFtcGxlLmNv cnMgTExDMRYwFAYDVQQLEw1JVCBEZXBhcnRtZW50MB4XDTExMDEyMTEzMTEwNloX
bTAgFw0xNjAzMTEyMjAzMjdaGA8yMjE2MDEyMzIyMDMyN1owgZcxCzAJBgNVBAYT DTE2MDEyMDEzMTEwNlowgYQxFDASBgNVBAMTC29rY29tcHMuY29tMQswCQYDVQQI
AlVTMRAwDgYDVQQIDAdSYWNrZXRhMRQwEgYDVQQHDAtSYWNrZXR2aWxsZTEZMBcG EwJPSDELMAkGA1UEBhMCVVMxHzAdBgkqhkiG9w0BCQEWEHJvb3RAb2tjb21wcy5j
A1UECgwQVGVzdGluZyBFeGFtcGxlczEQMA4GA1UECwwHVGVzdGluZzEUMBIGA1UE b20xGTAXBgNVBAoTEE9LIENvbXB1dGVycyBMTEMxFjAUBgNVBAsTDUlUIERlcGFy
AwwLZXhhbXBsZS5jb20xHTAbBgkqhkiG9w0BCQEWDmNhQGV4YW1wbGUuY29tMIIC dG1lbnQwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDTouNqzEoG/eof
IjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEAqCb9pHvY/xnaKDT7DAHAdahs H75hyNEd7VFRjbBddbu1194eCzfqmiNYacTx8Xhphf9fRNkR5Bznz5dfIrzFqvBJ
mxKEtUtcEGpytYWqJUQWGtahN7GwLgFJkkkNi/A7X/Nzz3gLrTn9AryTz1wYwnUI dv4H5BZrZ4cGqDLOdYQtxPdgq5DzfsjIxtck9XKEyZSfV/K2gm1mnqtJ/fYiL2Wm
bNek3HsiMkHRKt+EptxHGCnbhVRP/bWkbV/kd+HYlQfES9wZk0P/uO/4U4Sheb0K Oawrjgtvm3rS/3p0kk/vlS74VfuUX68/S+DgfUX3dvrKXqJn4skcxy1cEt+8GBsH
c00Cyso64Bi4KjQFu6pDeaq9dD/8GBwqfCd5JD7+n7v3Q/LmkP4+n2FFVPb8eAJQ CsfwZC3oh+Oi2HO9bmMatp0OgxvuEyc3cwTbdR9JWOs/7eQeGIp6zYwChJqpajSM
SjToRRt0zDT1RIYfjZVgw2BrRHLbVt+angWGqMr0/6SORt4Oy9WhB9ttGj/PJlxX WfwBfY+oQazZrZGbVY+MDPHGD7QTdHn8P0RPCqZpz3f7RnL3Emc1XXGuZBnRa7sv
H9FQCRbbx9iOzUwUX2RSvxhnv4r41nWugVdO2ngs/b9v2LhzMFSkKYH9m1doInRh KWUsCiP9AgMBAAGjEDAOMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEEBQADggEB
rX3xxJir4mlr/mw28S3Ho4Y7VCbsvr6vtdSWpYL9dMdOYJSS7WZ+uFkLB7sZzkxG AF6ifcd9/uawOKBAvhMrAS7gTFHXSdc+KoVlPp4SM6+6rllrmxGoGrvXv2NQKjiG
K03tG+rkpk0wt+3ZBvaNI9A2xQiACPQUa2rrks4u5ppgApcNTk4xgUrLOCFqxMC+ 4Vz0AENCk5vd/i8U2+wkBXnDQFE2ckZwiao33Z4FBq1BYtOP3+mxcg9DDuz2fywn
fFyNjEYl7peggMOPW44q5n81c7UuP4RsQAqj3coAFhrs5I3UfgOjtTleEDzp9vq6 LCRBVVVeTXEdoAs3kzMjArPGCP4nXzyGD8zQDv9pcSHJfafPf45Sf1QHhPIm8DdL
q4p6i6dFBSqKJcXF01onKfEkMz0Mh/4i8exztwNzIrVuzcSnXKTLiOiPHFbcMdS2 Z2uQQ9aZwMPQwWjVEhPIbB2eXLnRMEMH9JE9mKEhN+epKljyLDADXs+bSkg3QMaT
hvwyyiqLOnAvIeJ1Vu+o8gSnaXmY0au6iQz6I8n5Sptsh+vkJxZg4rVYonAOmqiW d3Bqv9wjBrH2tztqVkq0os0tRFUlVPB6g0ave0Dgp99LolbQJbYlGas6CISS6ueD
gHal923T9r//tB1MwOsCAwEAAaNjMGEwHQYDVR0OBBYEFMMkXbk8vqA3jSkCaqpz plEJK3Mrw7v832Wqnjx8vhE=
DvIx1NPOMB8GA1UdIwQYMBaAFMMkXbk8vqA3jSkCaqpzDvIx1NPOMA8GA1UdEwEB
/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgGGMA0GCSqGSIb3DQEBCwUAA4ICAQAORfTD
zPBdvURtSGqiXN/WPU4gw6MSbeB8cr4E4pEPrizA07XW4wj23/x59STyZNl6ed7F
9pYSz9E4Op4BNGFa7EqTd6FzSBLW4w4j1S45+bOsGoJynSLaQ7EmtP31yMeEF4tM
6pzWT35GIzhHK1EWSZHNglQPcD/Ype51AvUVRN/xf3icsc9scU+sLuZdd2G4sKkS
JvJX+k2Kwe38KCR8ZzGXzJCs33eTYBCkjzaNxe9JOhp9R6m535YkOFlxVYxNSgLp
mfQsRMTwpV1wyoPCn73cYN10WkrtN2JeddfyjtqzDSy+xQ8cglALokStIWEqP+Zm
i7ovDxsuBc4Xs4433ek3xDnwquCwkq4TlG1fbSvjSBaDeWmGIOoF7Mxo5uv3v0gE
YWNP8cHXuNE1V0peGwMPruUt9otpj4K9NrXTstkx3XBjgPMuVb3le1DRldd5Bwde
FusziX44IonAn63h2wYNv1ii+zV4cmbiaB1Ugp1GOV11oLmwSbnYT2kQ8uhdU0OF
1bLIe+tssAQzVKNUMgHKTsczdpzlRYiZ6hwoGyymYtV7l4pbwEb8ctBivzx4fe70
PwP5qQAFZfDWnVlRZNOxKoxYl9/DORtMhZqGjQMm4DreV+vz1RbTyEzSl+1ncxKF
UlW6PRzPhjJE8wt19KXLFZ+6oATODmh7sGuGhQ==
-----END CERTIFICATE----- -----END CERTIFICATE-----

View File

@ -1,27 +1,67 @@
Certificate:
Data:
Version: 3 (0x2)
Serial Number: 4 (0x4)
Signature Algorithm: md5WithRSAEncryption
Issuer: CN=okcomps.com, ST=OH, C=US/emailAddress=root@okcomps.com, O=OK Computers LLC, OU=IT Department
Validity
Not Before: Jan 22 16:49:23 2011 GMT
Not After : Jan 21 16:49:23 2016 GMT
Subject: CN=testclient.okcomps.com, ST=OH, C=US/emailAddress=root@okcomps.com, O=OK Computers LLC, OU=IT
Subject Public Key Info:
Public Key Algorithm: rsaEncryption
RSA Public Key: (1024 bit)
Modulus (1024 bit):
00:e3:a1:8c:40:df:26:a5:52:31:f2:65:94:fa:f3:
32:1a:a1:d1:06:e3:32:f4:ae:17:27:38:49:c4:8f:
f0:6a:61:4a:b1:12:a8:ff:22:5e:a8:b8:d2:be:24:
83:1d:48:e4:62:8d:b8:a3:a0:b7:68:d2:dc:53:11:
fd:cd:87:67:7e:30:76:41:18:d4:97:7d:4f:75:8c:
b3:17:6a:d4:5f:e2:fa:4c:c3:e0:a5:2b:d5:b2:f0:
9a:fc:8c:ec:fb:99:8c:51:b0:62:54:91:c2:64:d1:
79:41:da:8f:88:40:76:81:29:d0:0a:f7:63:51:76:
7a:23:f1:ca:57:d1:0e:1b:b5
Exponent: 65537 (0x10001)
X509v3 extensions:
X509v3 Subject Alternative Name:
DNS:alt.tradeshowhell.com
X509v3 Basic Constraints:
CA:FALSE
Netscape Cert Type:
SSL Client
Signature Algorithm: md5WithRSAEncryption
d0:1c:c8:74:87:06:0b:96:3d:05:4e:19:e4:19:9e:0a:12:76:
57:c7:a3:24:34:dd:af:e9:67:cd:99:2a:43:d7:e6:b6:18:eb:
b4:b0:63:be:e6:d8:ff:99:95:81:a7:88:b9:68:b9:0e:2f:cb:
2b:2b:7c:0e:c4:66:d3:f4:89:91:ba:03:0a:35:e1:6b:19:0e:
41:c8:f3:3c:bf:47:c1:60:ee:88:74:0a:41:08:4e:82:be:ae:
46:b0:31:8d:f8:10:84:1a:af:03:52:39:87:b7:46:2f:7f:2e:
f1:a6:03:4e:3c:bb:ea:0c:08:8f:77:17:b7:c8:d2:a5:a7:a0:
56:9b:c8:5b:53:d1:36:01:96:85:46:c9:73:e5:cf:40:8c:fa:
b2:c1:be:3e:8f:24:97:c3:35:ec:45:59:b3:f4:9b:3f:b0:50:
5d:2b:d3:19:11:c6:5d:c1:61:26:db:34:4a:69:46:5a:c1:f2:
43:f9:5a:4d:71:44:2a:62:28:c0:ac:51:63:35:88:cc:6d:9a:
db:7b:d1:a1:a2:e4:86:96:83:48:73:7f:c9:a3:05:e6:46:82:
1c:b4:99:9e:7a:b6:1e:87:08:e6:1d:b1:04:0f:ed:19:a6:b1:
ce:71:47:ce:73:de:8c:d8:13:aa:a8:6f:b0:04:0c:9b:b7:d1:
61:da:90:e3
-----BEGIN CERTIFICATE----- -----BEGIN CERTIFICATE-----
MIIEnDCCAoQCAhACMA0GCSqGSIb3DQEBCwUAMIGXMQswCQYDVQQGEwJVUzEQMA4G MIIDQzCCAiugAwIBAgIBBDANBgkqhkiG9w0BAQQFADCBhDEUMBIGA1UEAxMLb2tj
A1UECAwHUmFja2V0YTEUMBIGA1UEBwwLUmFja2V0dmlsbGUxGTAXBgNVBAoMEFRl b21wcy5jb20xCzAJBgNVBAgTAk9IMQswCQYDVQQGEwJVUzEfMB0GCSqGSIb3DQEJ
c3RpbmcgRXhhbXBsZXMxEDAOBgNVBAsMB1Rlc3RpbmcxFDASBgNVBAMMC2V4YW1w ARYQcm9vdEBva2NvbXBzLmNvbTEZMBcGA1UEChMQT0sgQ29tcHV0ZXJzIExMQzEW
bGUuY29tMR0wGwYJKoZIhvcNAQkBFg5jYUBleGFtcGxlLmNvbTAgFw0xNjAzMTEy MBQGA1UECxMNSVQgRGVwYXJ0bWVudDAeFw0xMTAxMjIxNjQ5MjNaFw0xNjAxMjEx
MjAzMjhaGA8yMTE4MTExMjIyMDMyOFowgYwxCzAJBgNVBAYTAlVTMRAwDgYDVQQI NjQ5MjNaMIGEMR8wHQYDVQQDExZ0ZXN0Y2xpZW50Lm9rY29tcHMuY29tMQswCQYD
DAdSYWNrZXRhMRkwFwYDVQQKDBBUZXN0aW5nIEV4YW1wbGVzMRAwDgYDVQQLDAdU VQQIEwJPSDELMAkGA1UEBhMCVVMxHzAdBgkqhkiG9w0BCQEWEHJvb3RAb2tjb21w
ZXN0aW5nMRswGQYDVQQDDBJjbGllbnQuZXhhbXBsZS5jb20xITAfBgkqhkiG9w0B cy5jb20xGTAXBgNVBAoTEE9LIENvbXB1dGVycyBMTEMxCzAJBgNVBAsTAklUMIGf
CQEWEmNsaWVudEBleGFtcGxlLmNvbTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCC MA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDjoYxA3yalUjHyZZT68zIaodEG4zL0
AQoCggEBAMDIKlIqHrCjgP2Z2TVBFSiYMZ1L4c3GHPFKxx7PLD5Op0t63ngJkY3Z rhcnOEnEj/BqYUqxEqj/Il6ouNK+JIMdSORijbijoLdo0txTEf3Nh2d+MHZBGNSX
MQY4f4vVh1YxC7m0EfCz1HwpNwCntkHO+SWGe3QPxsKT88/NaHvOxWln2AN18ITX fU91jLMXatRf4vpMw+ClK9Wy8Jr8jOz7mYxRsGJUkcJk0XlB2o+IQHaBKdAK92NR
ZOkabEhaCFfwVwEXuoR0lP1R26hSNdDEJ7g0xoXm2xa5bqCLagz6qh09N03XY9wU dnoj8cpX0Q4btQIDAQABo0IwQDAgBgNVHREEGTAXghVhbHQudHJhZGVzaG93aGVs
P63c2V8hGwF5pIBEYIFaV/NLG4Yen/sXbTg92OleCkl66YpRv2XgUc180KPzy53R bC5jb20wCQYDVR0TBAIwADARBglghkgBhvhCAQEEBAMCB4AwDQYJKoZIhvcNAQEE
sEvNiytuNczQf+iQp8QNtkAKYCuftIn6gz94zuZvbbeCxWUnBPLTQQlhnBzDk7hr BQADggEBANAcyHSHBguWPQVOGeQZngoSdlfHoyQ03a/pZ82ZKkPX5rYY67SwY77m
5Zjhn9LgZEccPrSF10F5T1zzhwm/oT8CAwEAATANBgkqhkiG9w0BAQsFAAOCAgEA 2P+ZlYGniLlouQ4vyysrfA7EZtP0iZG6Awo14WsZDkHI8zy/R8Fg7oh0CkEIToK+
BxoEWniRHlfcPaeODLZoOINneZc1Ipv3B59h1rprMZXscr+cKuOvJsnjDASOafrY rkawMY34EIQarwNSOYe3Ri9/LvGmA048u+oMCI93F7fI0qWnoFabyFtT0TYBloVG
vmO+ytEBdk+LqxT2AmN0wQHodbwNTKdPfQak4EkNsl9NqMpL9/dlVkjoEnklgeD5 yXPlz0CM+rLBvj6PJJfDNexFWbP0mz+wUF0r0xkRxl3BYSbbNEppRlrB8kP5Wk1x
zRhGkFoCDXzYh3vTMdo3X5w/j2XZcW1t70b64G5a9319vsfq9qcWLqciSjfPJrq0 RCpiKMCsUWM1iMxtmtt70aGi5IaWg0hzf8mjBeZGghy0mZ56th6HCOYdsQQP7Rmm
34ZziHtSya8Xls/AaMpaPnEAUNlUMFNV30EvOWb/QnXExgqjyDkRHRwTiskLT1Or sc5xR85z3ozYE6qob7AEDJu30WHakOM=
K49K7W8/OtfHHpFMl9l/nyxNT4359dOO9runII5hXbZvy/3P04nHfQ5gz4P4b/Bo
Hp0xzoJyDfavI0CjLIZaKn8Ls15xdaVRY3KvhX477mVWEOGsV4p2Na+uZ/nHrAiG
tCI8k+TT6L9y+1E6W6SbN0xrebgGwgG1/q6aC3bZamYNPJ/I2h84gBVe2I+eywQW
8fo5loaPgHcFvImeaMdx3DcjmIKfzry8Cr2sv6/VNqaKcdak5zpgAHQj5kLlyAuv
2tiuW6JQsv9KA4u0MAwESBlycVL7DqZwY69K1Y1WPHKFoBCUkIScuNABFA9mvL+1
Ylz3pARDdYkU2JUL54kTD7BkhCBiFGYGP4A6+knSvezpytdp9IQ/tF2ona0ytll+
Ka2IZ62rjlyNWDDbQQ67FfaKGZGwiwTlcDIXTqg/LWk=
-----END CERTIFICATE----- -----END CERTIFICATE-----

View File

@ -1,27 +1,15 @@
-----BEGIN RSA PRIVATE KEY----- -----BEGIN RSA PRIVATE KEY-----
MIIEpAIBAAKCAQEAwMgqUioesKOA/ZnZNUEVKJgxnUvhzcYc8UrHHs8sPk6nS3re MIICXAIBAAKBgQDjoYxA3yalUjHyZZT68zIaodEG4zL0rhcnOEnEj/BqYUqxEqj/
eAmRjdkxBjh/i9WHVjELubQR8LPUfCk3AKe2Qc75JYZ7dA/GwpPzz81oe87FaWfY Il6ouNK+JIMdSORijbijoLdo0txTEf3Nh2d+MHZBGNSXfU91jLMXatRf4vpMw+Cl
A3XwhNdk6RpsSFoIV/BXARe6hHSU/VHbqFI10MQnuDTGhebbFrluoItqDPqqHT03 K9Wy8Jr8jOz7mYxRsGJUkcJk0XlB2o+IQHaBKdAK92NRdnoj8cpX0Q4btQIDAQAB
Tddj3BQ/rdzZXyEbAXmkgERggVpX80sbhh6f+xdtOD3Y6V4KSXrpilG/ZeBRzXzQ AoGAPgUF8abbILAEa8bBkJ4ySI9OJFJCz+ee51CuyJ9vIYzgjN5IrTrwD4hL4wKP
o/PLndGwS82LK241zNB/6JCnxA22QApgK5+0ifqDP3jO5m9tt4LFZScE8tNBCWGc tqrljvSOGgbv8d+BqCB+xkDeMT/mFBOyCKrrOX7TSSvVfu9ihRtiy7v2vjodwTNq
HMOTuGvlmOGf0uBkRxw+tIXXQXlPXPOHCb+hPwIDAQABAoIBAAlH2Zm5A183j9cl L82JKscJXTwgR3QrJv6JPb/iZItbweFE4/UWMFDEd7J+dQECQQD5WzSmGTxWdvjx
l+pTZsRch07uP0GbvvrywaE/Ef8x5CXjFWCr/UDZ6t1EzQcbUXeZxtm6zH5M+fa8 l+jhdVQmA6O87txBPAJP+hAfq/ViAIwVxEeDTBDYKHXBAzIjSpigerG6WkW8AeCQ
OTSj3kdOwnnG/px4wfXOD5e6aMRFEQXhBOotvFV41RfPuNTG2M36+QVJciY8Qovr 2aDJOnRHAkEA6bIo+1xwwhZb42kPWiLKhW4bwKM7K7Y3uetQMehu8BOubr6QMHKb
a+qvgn25Y7wfdkst8PAoHyZFb+aN+RkiQLPPcZOYVJPKk8/3cC1j0hcRfluL0ygH QCjz3/e+ldQ3tV9AgcFmp0juZ4YoBTcaIwJAPVZjIAyLHBXN7NfaUENlPKieiWYU
KCeQmef+UtBn8bg1msjQQRL9vM3RbGyC/rYbKj3uU0pXT3WzxGu3QOEBgTQx8IB1 RfO1+ehgOPo6tS2/R8dtc+2tIw7o0F6x4Z6C5s7nkxiLmNC5Zcgy1e0MFwJBAIwP
pku0e/mfaTbiGRn2Xh4zoZPshi3YN31c7jza6NjT3Fq4bJhl88ESpLY4toOFQxwo WPx9RJ8uI1hCKQ9Odq5NdZiYu+fQx8lHvMKMmaCNSyfYUjaXGXD0mmUK6FCH5fNv
ktfAJOECgYEA/tgrko+xaNPKfJWoysAiDZF2T/5JZSJ4T+EGx7r0XS/bMX4sudM7 6QtbTBjKXwfwoZ+ujJ0CQHAOCJY1vtycRYFh7B+A6Emp/w5aJAqJqS4A79FjCf3N
iD46JUNz/wavYeAlg2TIufYLz6323u5E/Uc9YAGCMtVHNWqxj6fLLM6qJBKdq6CU w8MwJrAPTXvKILEnvhuW5uxg5VXqndK/gz+6z/eZyS4=
8Cd9e7ZhWfMn6eOi8UAff1Yk+rYwXEKOMB4bCbtBE8m4dvjOKxK6mO8CgYEAwafz
jbGPRTEw1no1jMBTLyACEvRsTShXYrfE68saj/3uB2ms+7JOFMtPiyI0q439t7Od
ogfr1PQ+MQ3tPwWkYgbb3CD1xdrNlk2qtKehmX4u9HNsYapZY3hZCxPyXkpeOrN2
zxFzqZ+ks6mWTKp8OPIKOybBF9XlJTKYLHiaXLECgYBMLkTAODI5eu5R1c8yZMMJ
OU2b1hEMqYQ7pLIJLMr1vGOS5PvrxMhMDwYEs6hOOSpeYMn2AD+8z19ygreEpsd6
yzv+ohTQq07xGebgYbFrwI+93s7BSmybacKqI7fwUq7AzSqdYaTIxPCi/alxOvgU
TDua6h4nEysQbYn7+EpNgwKBgQCVT8tnenm+nZjMJVnYdgktEn7G4pIGQ45s3MgG
DYkjcGPwbzgisG2ndsKTwgHeLBJtax2k6nqYrOCurdA4gT8nHaay6O7WaEePFb8C
nyTn1fSaIcx02QUmvonZEr4SmUBh/jEiopANPruckqsB3Yj91xCwXscOe6q7rXDL
CQnrYQKBgQCabbpley7Ln8Ta9T0n1goD4MeLEvbdKpbMYgd69ibrGCt4YM/Oir68
HMh0YDi6UnyxvTMWasmyADoIQvI7jHdPDRIZQJ5BDs84Bv2fRLsjXAw/uRNBK0vU
CobgqrqaMoD2reaRjjGOJ/LXC+DyrndM1gLsVaOWmYk/J5tvs0Admg==
-----END RSA PRIVATE KEY----- -----END RSA PRIVATE KEY-----

View File

@ -62,10 +62,10 @@
(check "Server: Verified ~v~n" (ssl-peer-verified? out) valid?) (check "Server: Verified ~v~n" (ssl-peer-verified? out) valid?)
(check "Server: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in) (check "Server: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in)
(and valid? (and valid?
#"/C=US/ST=Racketa/O=Testing Examples/OU=Testing/CN=client.example.com/emailAddress=client@example.com")) #"/CN=testclient.okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT"))
(check "Server: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in) (check "Server: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in)
(and valid? (and valid?
#"/C=US/ST=Racketa/L=Racketville/O=Testing Examples/OU=Testing/CN=example.com/emailAddress=ca@example.com")) #"/CN=okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT Department"))
(ssl-close ssl-listener) (ssl-close ssl-listener)
(check "Server: From Client: ~a~n" (read-line in) "yay the connection was made") (check "Server: From Client: ~a~n" (read-line in) "yay the connection was made")
(close-input-port in) (close-input-port in)
@ -83,6 +83,7 @@
(ssl-load-verify-root-certificates! ssl-client-context cacert) (ssl-load-verify-root-certificates! ssl-client-context cacert)
(ssl-set-verify! ssl-client-context #t)) (ssl-set-verify! ssl-client-context #t))
(let-values ([(in out) (ssl-connect "127.0.0.1" (let-values ([(in out) (ssl-connect "127.0.0.1"
55000 55000
ssl-client-context)]) ssl-client-context)])
@ -95,9 +96,9 @@
(check "Client: Verified ~v~n" (ssl-peer-verified? in) valid?) (check "Client: Verified ~v~n" (ssl-peer-verified? in) valid?)
(check "Client: Verified ~v~n" (ssl-peer-verified? out) valid?) (check "Client: Verified ~v~n" (ssl-peer-verified? out) valid?)
(check "Client: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in) (check "Client: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in)
#"/C=US/ST=Racketa/O=Testing Examples/OU=Testing/CN=server.example.com/emailAddress=server@example.com") #"/CN=test.okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT")
(check "Client: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in) (check "Client: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in)
#"/C=US/ST=Racketa/L=Racketville/O=Testing Examples/OU=Testing/CN=example.com/emailAddress=ca@example.com") #"/CN=okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT Department")
(write-string (format "yay the connection was made~n") out) (write-string (format "yay the connection was made~n") out)
(close-input-port in) (close-input-port in)

View File

@ -1,35 +1,67 @@
Certificate:
Data:
Version: 3 (0x2)
Serial Number: 1 (0x1)
Signature Algorithm: md5WithRSAEncryption
Issuer: CN=okcomps.com, ST=OH, C=US/emailAddress=root@okcomps.com, O=OK Computers LLC, OU=IT Department
Validity
Not Before: Jan 21 13:19:20 2011 GMT
Not After : Jan 20 13:19:20 2016 GMT
Subject: CN=test.okcomps.com, ST=OH, C=US/emailAddress=root@okcomps.com, O=OK Computers LLC, OU=IT
Subject Public Key Info:
Public Key Algorithm: rsaEncryption
RSA Public Key: (1024 bit)
Modulus (1024 bit):
00:ca:d0:a2:7c:5d:0c:bc:df:3b:1c:d2:b7:d4:b3:
68:12:1b:3a:df:5e:75:f6:9f:71:1a:b2:29:76:e7:
55:eb:2d:d2:cf:c1:a7:2f:54:91:68:cc:f0:ce:10:
42:d4:d2:82:0d:56:f0:16:aa:a8:a4:f3:4f:c3:f7:
55:3c:a0:90:c3:a9:04:63:86:90:7f:64:49:77:0d:
9b:7b:02:e2:04:ec:52:08:c4:01:72:e4:e6:89:18:
f6:fc:cc:8d:b6:9b:24:f4:c6:a9:78:67:e4:15:d4:
68:1e:da:67:4f:d9:40:48:44:f0:9a:ae:5a:87:24:
2a:b5:2e:83:d6:ad:f4:e5:9b
Exponent: 65537 (0x10001)
X509v3 extensions:
X509v3 Subject Alternative Name:
DNS:alt.tradeshowhell.com
X509v3 Basic Constraints:
CA:FALSE
Netscape Cert Type:
SSL Server
Signature Algorithm: md5WithRSAEncryption
ab:c9:75:73:f9:79:31:34:b9:3b:83:2f:3f:9e:4e:33:01:98:
37:9b:bd:08:d6:14:ea:d9:a1:fa:7a:0d:ae:dc:00:fd:a6:01:
ba:3e:d6:ed:8b:8d:43:ba:41:51:08:c6:c5:db:84:34:34:07:
17:19:35:5d:8c:7f:37:b8:c1:02:c3:22:d9:dc:f4:85:4d:1c:
6e:44:43:0d:7a:5a:de:4c:ba:a3:4b:a3:9b:07:3a:dd:f0:69:
3d:89:65:e4:0d:f6:0d:04:58:00:74:b6:11:5e:e2:a7:1c:8d:
d4:83:e3:9b:93:85:f7:d1:7c:5f:67:0c:38:02:1f:d6:44:0d:
73:22:5f:d2:ff:e1:ef:be:11:e4:e7:1c:b7:d6:8b:b6:78:bb:
09:e1:46:94:48:24:98:88:b2:6d:27:2a:85:5a:cd:34:b5:c4:
74:1b:58:97:f8:4a:aa:13:e1:13:4d:86:80:36:b2:9a:31:3a:
be:3f:c7:1b:76:71:e9:b5:7d:4b:61:9b:59:ad:c7:1b:2e:b8:
7c:bd:6f:f8:06:44:eb:7b:fd:53:45:b0:fa:a4:37:b4:56:e2:
87:ba:d4:5c:49:db:7d:31:a4:42:d3:d7:47:a3:6f:cb:e3:9d:
5c:be:2e:eb:1b:0a:06:e2:ce:d6:c4:81:c2:c1:85:36:dc:4c:
03:5b:b3:14
-----BEGIN CERTIFICATE----- -----BEGIN CERTIFICATE-----
MIIGDzCCA/egAwIBAgICEAAwDQYJKoZIhvcNAQELBQAwgZcxCzAJBgNVBAYTAlVT MIIDPDCCAiSgAwIBAgIBATANBgkqhkiG9w0BAQQFADCBhDEUMBIGA1UEAxMLb2tj
MRAwDgYDVQQIDAdSYWNrZXRhMRQwEgYDVQQHDAtSYWNrZXR2aWxsZTEZMBcGA1UE b21wcy5jb20xCzAJBgNVBAgTAk9IMQswCQYDVQQGEwJVUzEfMB0GCSqGSIb3DQEJ
CgwQVGVzdGluZyBFeGFtcGxlczEQMA4GA1UECwwHVGVzdGluZzEUMBIGA1UEAwwL ARYQcm9vdEBva2NvbXBzLmNvbTEZMBcGA1UEChMQT0sgQ29tcHV0ZXJzIExMQzEW
ZXhhbXBsZS5jb20xHTAbBgkqhkiG9w0BCQEWDmNhQGV4YW1wbGUuY29tMCAXDTE2 MBQGA1UECxMNSVQgRGVwYXJ0bWVudDAeFw0xMTAxMjExMzE5MjBaFw0xNjAxMjAx
MDMxMTIyMDMyN1oYDzIxMTgxMTEyMjIwMzI3WjCBjDELMAkGA1UEBhMCVVMxEDAO MzE5MjBaMH4xGTAXBgNVBAMTEHRlc3Qub2tjb21wcy5jb20xCzAJBgNVBAgTAk9I
BgNVBAgMB1JhY2tldGExGTAXBgNVBAoMEFRlc3RpbmcgRXhhbXBsZXMxEDAOBgNV MQswCQYDVQQGEwJVUzEfMB0GCSqGSIb3DQEJARYQcm9vdEBva2NvbXBzLmNvbTEZ
BAsMB1Rlc3RpbmcxGzAZBgNVBAMMEnNlcnZlci5leGFtcGxlLmNvbTEhMB8GCSqG MBcGA1UEChMQT0sgQ29tcHV0ZXJzIExMQzELMAkGA1UECxMCSVQwgZ8wDQYJKoZI
SIb3DQEJARYSc2VydmVyQGV4YW1wbGUuY29tMIIBIjANBgkqhkiG9w0BAQEFAAOC hvcNAQEBBQADgY0AMIGJAoGBAMrQonxdDLzfOxzSt9SzaBIbOt9edfafcRqyKXbn
AQ8AMIIBCgKCAQEAxwtM2E82qRxm1OH5LkGh+Ad5lHB55hBGY+Ge/xJWyoLaWnNf Vest0s/Bpy9UkWjM8M4QQtTSgg1W8BaqqKTzT8P3VTygkMOpBGOGkH9kSXcNm3sC
DjeyJ7l7eutUw4lDy1qnyg4oTPdzB5kR9v01f4W3AVAZd3j+Ea7lKhrsh7UHhZOb 4gTsUgjEAXLk5okY9vzMjbabJPTGqXhn5BXUaB7aZ0/ZQEhE8JquWockKrUug9at
N5v8/Evnmom2nWbGHqMeHMp8eatNr/RcsKX/NxUnSOMHROc1Ih9YCTsZBEW+QIQ3 9OWbAgMBAAGjQjBAMCAGA1UdEQQZMBeCFWFsdC50cmFkZXNob3doZWxsLmNvbTAJ
73pc394PEM4cXGSf2QkL2Ej/uan7LnAXgofTYAYf9olrItyvMDPXAg24CYV2YjOR BgNVHRMEAjAAMBEGCWCGSAGG+EIBAQQEAwIGQDANBgkqhkiG9w0BAQQFAAOCAQEA
I41F09OyUb0rSIvXHsgg95xXQp63SgrBJ70FtMw47qd36AqEPpvAYZBfDKuZwxBM q8l1c/l5MTS5O4MvP55OMwGYN5u9CNYU6tmh+noNrtwA/aYBuj7W7YuNQ7pBUQjG
82VvWlNK8eQXJsWed05VjzEpR7ohuTthvgaXfwIDAQABo4IBajCCAWYwCQYDVR0T xduENDQHFxk1XYx/N7jBAsMi2dz0hU0cbkRDDXpa3ky6o0ujmwc63fBpPYll5A32
BAIwADARBglghkgBhvhCAQEEBAMCBkAwMwYJYIZIAYb4QgENBCYWJE9wZW5TU0wg DQRYAHS2EV7ipxyN1IPjm5OF99F8X2cMOAIf1kQNcyJf0v/h774R5Occt9aLtni7
R2VuZXJhdGVkIFNlcnZlciBDZXJ0aWZpY2F0ZTAdBgNVHQ4EFgQUnuY2r6AUzT6X CeFGlEgkmIiybScqhVrNNLXEdBtYl/hKqhPhE02GgDaymjE6vj/HG3Zx6bV9S2Gb
a3tJWZ8WFQoWgQQwgcwGA1UdIwSBxDCBwYAUwyRduTy+oDeNKQJqqnMO8jHU086h Wa3HGy64fL1v+AZE63v9U0Ww+qQ3tFbih7rUXEnbfTGkQtPXR6Nvy+OdXL4u6xsK
gZ2kgZowgZcxCzAJBgNVBAYTAlVTMRAwDgYDVQQIDAdSYWNrZXRhMRQwEgYDVQQH BuLO1sSBwsGFNtxMA1uzFA==
DAtSYWNrZXR2aWxsZTEZMBcGA1UECgwQVGVzdGluZyBFeGFtcGxlczEQMA4GA1UE
CwwHVGVzdGluZzEUMBIGA1UEAwwLZXhhbXBsZS5jb20xHTAbBgkqhkiG9w0BCQEW
DmNhQGV4YW1wbGUuY29tggkAigO2jmnDmXQwDgYDVR0PAQH/BAQDAgWgMBMGA1Ud
JQQMMAoGCCsGAQUFBwMBMA0GCSqGSIb3DQEBCwUAA4ICAQBtdUfWn4C9ezYKMlo8
T+BVrDfGW4Cudygt4ckzhUhv6JxYmB3Z74VV0aVwx3Rb6BgBxbs7CjD3RU00IT8c
SzLBVz8UMIttlu2B2EgKcpek/n+/PEp/TNGbK0DoSYyrmyzgEdv70/GMEziDcWxt
K1577l+0IZEIXvVmjL9RXz2peaPNz5chGxTPrwwN08Ps6XPgtTzt1GpDDTow1jLR
eZ8B+X6N1mNaXDQJdGXJek+VVss/lqUcXIOeVgyn8nJKmPrTT/drD7Y8JK+v2MIm
AxMntYPi8YysgMmfSWZbReKaz0AkpCK0Fz/LAJmwYsbQ3F7BmU+dvjIy4BR0kj4L
3MbbiDkoGOkAFrkz0GF0YqUgkkh9azzq5gxX1Q14xLrfHgdPIaVxJileQ1UJ8UJd
m3uM7SuVFrtw4Al+OtWnlt/iWX71ERc07z3Y3LVTg++AS2sEmGvVdRge53uyCN79
0g/3ZOL74k6/v0fE40qoo8VzZFLpXDaR73ITwcG6OwLWvEhd/RzovzOTPHrUnqJK
rtVH81gMAdQ0eHhWtY312gAv9jyHCrtuUUD4n+sFv8yWkFm7ND2F7KrP2pgPX8z1
WM8dPIChyjPFQHiAfp73Xl+DFJ85fqQq5FoaoFE562x2sj0LS8wC6FjGwMSKfy8s
Z1z/rPg6199Dz4Nng87yTq6fAA==
-----END CERTIFICATE----- -----END CERTIFICATE-----

View File

@ -1,35 +1,14 @@
-----BEGIN CERTIFICATE----- -----BEGIN CERTIFICATE-----
MIIGETCCA/mgAwIBAgICEAEwDQYJKoZIhvcNAQELBQAwgZcxCzAJBgNVBAYTAlVT MIICETCCAXoCCQChYEk8e/hBbjANBgkqhkiG9w0BAQUFADBNMQswCQYDVQQGEwJV
MRAwDgYDVQQIDAdSYWNrZXRhMRQwEgYDVQQHDAtSYWNrZXR2aWxsZTEZMBcGA1UE UzELMAkGA1UECAwCTUExDzANBgNVBAcMBkJvc3RvbjENMAsGA1UECgwEVGVzdDER
CgwQVGVzdGluZyBFeGFtcGxlczEQMA4GA1UECwwHVGVzdGluZzEUMBIGA1UEAwwL MA8GA1UEAwwIdGVzdC5jb20wHhcNMTQwNTA5MTQ1NjQwWhcNMTcwMjAyMTQ1NjQw
ZXhhbXBsZS5jb20xHTAbBgkqhkiG9w0BCQEWDmNhQGV4YW1wbGUuY29tMCAXDTE2 WjBNMQswCQYDVQQGEwJVUzELMAkGA1UECAwCTUExDzANBgNVBAcMBkJvc3RvbjEN
MDMxMTIyMDMyN1oYDzIxMTgxMTEyMjIwMzI3WjCBjjELMAkGA1UEBhMCVVMxEDAO MAsGA1UECgwEVGVzdDERMA8GA1UEAwwIdGVzdC5jb20wgZ8wDQYJKoZIhvcNAQEB
BgNVBAgMB1JhY2tldGExGTAXBgNVBAoMEFRlc3RpbmcgRXhhbXBsZXMxEDAOBgNV BQADgY0AMIGJAoGBAMrQonxdDLzfOxzSt9SzaBIbOt9edfafcRqyKXbnVest0s/B
BAsMB1Rlc3RpbmcxHDAaBgNVBAMME3NlcnZlcjIuZXhhbXBsZS5jb20xIjAgBgkq py9UkWjM8M4QQtTSgg1W8BaqqKTzT8P3VTygkMOpBGOGkH9kSXcNm3sC4gTsUgjE
hkiG9w0BCQEWE3NlcnZlcjJAZXhhbXBsZS5jb20wggEiMA0GCSqGSIb3DQEBAQUA AXLk5okY9vzMjbabJPTGqXhn5BXUaB7aZ0/ZQEhE8JquWockKrUug9at9OWbAgMB
A4IBDwAwggEKAoIBAQDHC0zYTzapHGbU4fkuQaH4B3mUcHnmEEZj4Z7/ElbKgtpa AAEwDQYJKoZIhvcNAQEFBQADgYEASX12GYExD+DqEpxykXGmfJ5d608EmlTgSaCr
c18ON7InuXt661TDiUPLWqfKDihM93MHmRH2/TV/hbcBUBl3eP4RruUqGuyHtQeF EQCqo5xKkf1hqVIMVKfuiJ45nYhZ12t8+un2GKp7+ZZfn+pk7MJtb5TeH40JsLZr
k5s3m/z8S+eaibadZsYeox4cynx5q02v9Fywpf83FSdI4wdE5zUiH1gJOxkERb5A wb1WZ2jx4sjSBwiosxgAUtcdbOgxOha71SdhxPDMhBHLG25kq8gf0gFCo/4fcSNM
hDfvelzf3g8QzhxcZJ/ZCQvYSP+5qfsucBeCh9NgBh/2iWsi3K8wM9cCDbgJhXZi Ax1QFNs=
M5EjjUXT07JRvStIi9ceyCD3nFdCnrdKCsEnvQW0zDjup3foCoQ+m8BhkF8Mq5nD
EEzzZW9aU0rx5BcmxZ53TlWPMSlHuiG5O2G+Bpd/AgMBAAGjggFqMIIBZjAJBgNV
HRMEAjAAMBEGCWCGSAGG+EIBAQQEAwIGQDAzBglghkgBhvhCAQ0EJhYkT3BlblNT
TCBHZW5lcmF0ZWQgU2VydmVyIENlcnRpZmljYXRlMB0GA1UdDgQWBBSe5javoBTN
Ppdre0lZnxYVChaBBDCBzAYDVR0jBIHEMIHBgBTDJF25PL6gN40pAmqqcw7yMdTT
zqGBnaSBmjCBlzELMAkGA1UEBhMCVVMxEDAOBgNVBAgMB1JhY2tldGExFDASBgNV
BAcMC1JhY2tldHZpbGxlMRkwFwYDVQQKDBBUZXN0aW5nIEV4YW1wbGVzMRAwDgYD
VQQLDAdUZXN0aW5nMRQwEgYDVQQDDAtleGFtcGxlLmNvbTEdMBsGCSqGSIb3DQEJ
ARYOY2FAZXhhbXBsZS5jb22CCQCKA7aOacOZdDAOBgNVHQ8BAf8EBAMCBaAwEwYD
VR0lBAwwCgYIKwYBBQUHAwEwDQYJKoZIhvcNAQELBQADggIBAAXT2DwEkIZu3EsJ
9seWfunZ2Two9G1BHaT4LzVMLiYejBVlV4MTjj4RYYToH6oGbpL+XefInZTlecUB
FZjLcLFNoSKvNLMyUGwM5uC89i5W6l8/MIRw1L+GB5xVcbNIMp0EYQlTnoy7k3NF
7NNU3rThr/kRuFndjZ7k3QN5uTcnkFqGwtWFM+yHcOq4fnJUA6y9gniEDnXXF8x+
FRfcsKsQrqEyUGXiXrThUGtQd6j4oUdYdsN1HTTX1QPVMYZ8Qp62Fl9M+g5ZQJzG
ON1+f+c5m0xGK/5lb5ugWeld/45coavXGn48ev5jfiW8D7jJl4owooB6at5xDxRJ
+G3k3JfZpRNdUyahE4TBk+Ml8mKPYeiYs3Zfgs3ggubzZxoUyc0lGZquQLOZtLtq
uXqH7abLgflVBsf9edkQw0asN4axLVMIuYtpuxP5UcIjlYx1hyAxfidiIZbzfAND
0L1UPPlDG4Yf3ClAM875fyUz+xWe6FrVANTq1hWTI5azwXCQ5ucpfwNT2Tbos+/y
oX6sVvWfs8qQd1whWHzFksj6jf9Wdiz95tyj5b0QcvP9BrPCGd94TXvNuecg8ZMw
wF3S4Qo9P9LrhWhFFrPZQkzKbdtIrCaR16d7lzue1qLXMHR3NfqUzk0IswNlV10T
IwkCwD3IE2RiB59HUJqv8y9JKr/P
-----END CERTIFICATE----- -----END CERTIFICATE-----

View File

@ -1,27 +1,15 @@
-----BEGIN RSA PRIVATE KEY----- -----BEGIN RSA PRIVATE KEY-----
MIIEpgIBAAKCAQEAxwtM2E82qRxm1OH5LkGh+Ad5lHB55hBGY+Ge/xJWyoLaWnNf MIICXQIBAAKBgQDK0KJ8XQy83zsc0rfUs2gSGzrfXnX2n3Easil251XrLdLPwacv
DjeyJ7l7eutUw4lDy1qnyg4oTPdzB5kR9v01f4W3AVAZd3j+Ea7lKhrsh7UHhZOb VJFozPDOEELU0oINVvAWqqik80/D91U8oJDDqQRjhpB/ZEl3DZt7AuIE7FIIxAFy
N5v8/Evnmom2nWbGHqMeHMp8eatNr/RcsKX/NxUnSOMHROc1Ih9YCTsZBEW+QIQ3 5OaJGPb8zI22myT0xql4Z+QV1Gge2mdP2UBIRPCarlqHJCq1LoPWrfTlmwIDAQAB
73pc394PEM4cXGSf2QkL2Ej/uan7LnAXgofTYAYf9olrItyvMDPXAg24CYV2YjOR AoGAN2HRfPRLzieHFM/Vsxdqi8czxFsfC0FuuUN9XyK8q4PP1TukU6BcNKoB98Mo
I41F09OyUb0rSIvXHsgg95xXQp63SgrBJ70FtMw47qd36AqEPpvAYZBfDKuZwxBM /MSfDtV2qjnf42stlO2tMOkHnmkx6Kz/aoiG7rfPjVqRVOy+LZ6HZj5bxaIC0WkF
82VvWlNK8eQXJsWed05VjzEpR7ohuTthvgaXfwIDAQABAoIBAQC7FkQEjXAzRB7j 2RbuHB2pLmrZGfQI0F/aFQpUQCqM4S4e1SDBxAyygtzkaUECQQD7pqWpXQ+VjejK
ugMdF1PGbkA45f+t315KQ6fO2M37S0MyAX83PeKWtCD8SHZD1KGEYpGTufrnXS8h /Gd8hNPQk71vziJsXn3fVVa0aYxh8WapbvQODC6aMvow4ows6oJgMJdsfjBfBDbd
1R6tqRK/6k85TLCjO3aT6HA+Q1BPvjhztWoPuu7vtejbuNWM3S0bXvbO2QRm2D0N KNtcTCbHAkEAzlHtfH+o6dVuAaURUfhDj4Ld25/ZQepKMsI3CJaS3eP5+efVbjhr
RgJZh617eMaUG9CZUzj9+bgl9QZum/T7lE0IQvel2hUCQPNAfdm11hFzDPLBUkMy yedC+p7moN9oTLPxee+EqoB8921MWa4mjQJAI/upNnVrFAxtnBDJT2HC09E8Ri9o
N+h5VhMLfBbYd8YxS2m+/9V0UMcQjwsCGsk75dGQ0jUJjiMDXBYXMqMGCVZd0LYQ dqxwPS37ruJkw2B8OH/3/8Y4J65gXfsW5hlGOTDZhhbpHb0Bh1AfRaxR4wJBALn+
JNMx0GqaSFj5LsR2CPMY2M3xn9ulh13vgSNBxprjH4XaLSpujEtZIqm7bPUaL7n/ EWFSlCt4RBsne12xuPX+u5HpoClT1F+9xW7wjqWJhyhKXpVmN4Vj/XWBGdecjqHW
IeGliaoBAoGBAPjIxLf+Dp3EepcSpOERlVhpSzjSXPyz1v/k+ZwUeBn8urzAsrNs 9bE+wxIRkpZa6aFO5WECQQChsZbIQ3Oa5D5cjmImzmhWS7pYB/hTt3RZODiB35Ec
9Q9dWthAAmIQorUpgG/iizkVQm1dXhxzR47DlFSCfsn9g1JdEHRLt0bWq38YwPb5 0tDEkEYz3kx2WmVQdXnlP3/JS8F9FrDJX+y2YxLhvQ75
OctGEFsqchrNpvonb1iBaQuCZesLw29Hwm3x6jpoPyhkgEgVRAL3/n+ZAoGBAMzR
NbB/YnATd/hXK81OVEpHx6KT9W4Emz3DCIYhVX2rk5b9ZDirl3QpHcwjoX9TW6iM
MQV/lRPU5MLHJH3N9MibzDnNoiejXYoGiFEFXcxBQeSEnPi79WOV86EEIHji+oCG
4viwUNnDNFo06Oo/3ZRfKmC2WBGdQTarbkHicZ7XAoGBAK17MtIqsv6I+ANI2Pip
Tj8sjWu+JWGB9rbScMzJ6UYV2hGtPe+oVuqz6plJaWAAwbUaj5l1nCfeD0g8B1hH
euqur0yPAuLPiTdx9ftioRcgss4Z8NVHzWlWHim0W4UdSwa9YQOSmjGQaImS1mFO
5OHOA8tezkvYaSvayGZZkHphAoGBALytuaz3HGKsvKcM/q/qCaJID7NIZB7OpYg2
4+JUUOItLhA5K5s9D4+V1PpalIqr6tMRGpO7HUUgqQB53bb7BRXM2E0jjs6/Iwtk
yy0AKZFhSGdQdx54YC02VTIukA9s4WGHYQ3Btyl0NwUmmq442VG2fV6MfAL1/75y
HGcbSJoPAoGBALnnFpCr1BT2ogcDXdUWPTmKMde4QZOM0O7DguTEkSFtPdjlijhn
TButsiroGsC44gYi+wbll9mmaj6ZjCVclH7Z9lbvoZQxYiis/hD/eH8HR0yyFsp/
MMyX3yCv+fawwKGU1eZQSijz38lGNBvM/hWhc8vFSycaarrEaE5wcjcw
-----END RSA PRIVATE KEY----- -----END RSA PRIVATE KEY-----

View File

@ -14,18 +14,14 @@
(for/list ([f-stx (in-list (syntax->list #'(f ...)))]) (for/list ([f-stx (in-list (syntax->list #'(f ...)))])
(define f (syntax->datum f-stx)) (define f (syntax->datum f-stx))
(format "tests-~a.rkt" f))]) (format "tests-~a.rkt" f))])
(syntax/loc stx (syntax/loc stx
(let ([succesful 0]) (run-tests*
(run-tests* (list (let ()
(list (let () (local-require (only-in tests-f run-pkg-tests))
(local-require (only-in tests-f run-pkg-tests)) (λ ()
(λ () (printf "starting ~a\n" 'tests-f)
(printf "starting ~a\n" 'tests-f) (run-pkg-tests)))
(run-pkg-tests) ...))))]))
(set! succesful (add1 succesful))))
...))
(unless (= succesful (length '(f ...)))
(exit 1)))))]))
(define (run-tests* l) (define (run-tests* l)
(run-pkg-tests* (run-pkg-tests*

View File

@ -22,35 +22,18 @@
(shelly-begin (shelly-begin
(initialize-catalogs) (initialize-catalogs)
(define-syntax-rule (shelly-install-dry-run what src)
(shelly-case
(format "Test dry-run installation of ~a" what)
$ "racket -e '(require pkg-test1)'" =exit> 1
$ (~a "raco pkg install --dry-run " src)
$ "racket -e '(require pkg-test1)'" =exit> 1))
(define-syntax-rule (shelly-install/d what src)
(begin
(shelly-install-dry-run what src)
(shelly-install what src)))
(define-syntax-rule (shelly-install*/d what srcs pkgs)
(begin
(shelly-install-dry-run what srcs)
(shelly-install* what srcs pkgs)))
(shelly-case (shelly-case
"raco pkg install tests" "raco pkg install tests"
(shelly-install/d "local package (tgz)" "test-pkgs/pkg-test1.tgz") (shelly-install "local package (tgz)" "test-pkgs/pkg-test1.tgz")
(shelly-install/d "local package (zip)" "test-pkgs/pkg-test1.zip") (shelly-install "local package (zip)" "test-pkgs/pkg-test1.zip")
(shelly-install/d "local package (file://zip)" (url->string (path->url (path->complete-path "test-pkgs/pkg-test1.zip")))) (shelly-install "local package (file://zip)" (url->string (path->url (path->complete-path "test-pkgs/pkg-test1.zip"))))
(shelly-install/d "local package (plt)" "test-pkgs/pkg-test1.plt") (shelly-install "local package (plt)" "test-pkgs/pkg-test1.plt")
(shelly-install*/d "local package (zip, compiled)" "test-pkgs/pkg-test1b.zip" "pkg-test1b") (shelly-install* "local package (zip, compiled)" "test-pkgs/pkg-test1b.zip" "pkg-test1b")
(shelly-install*/d "local package (zip, single-collection)" (shelly-install* "local package (zip, single-collection)"
"test-pkgs/pkg-test1.zip test-pkgs/pkg-test3.zip" "test-pkgs/pkg-test1.zip test-pkgs/pkg-test3.zip"
"pkg-test1 pkg-test3") "pkg-test1 pkg-test3")
(shelly-install/d "local package (dir)" (url->string (path->url (path->complete-path "test-pkgs/pkg-test1")))) (shelly-install "local package (dir)" (url->string (path->url (path->complete-path "test-pkgs/pkg-test1"))))
(shelly-install/d "local package (file://dir)" (url->string (path->url (path->complete-path "test-pkgs/pkg-test1")))) (shelly-install "local package (file://dir)" (url->string (path->url (path->complete-path "test-pkgs/pkg-test1"))))
;; Check ".zip" file with extra directory layer: ;; Check ".zip" file with extra directory layer:
(let ([dir (make-temporary-file "zip~a" 'directory)] (let ([dir (make-temporary-file "zip~a" 'directory)]
@ -136,18 +119,17 @@
"local directory fails when not there" "local directory fails when not there"
$ "raco pkg install --copy test-pkgs/pkg-test1-not-there/" =exit> 1) $ "raco pkg install --copy test-pkgs/pkg-test1-not-there/" =exit> 1)
(parameterize ([current-directory test-source-directory]) (shelly-case
(shelly-case "directory fails due to path overlap"
"directory fails due to path overlap" $ "raco pkg install test-pkgs/pkg-test1"
$ "raco pkg install test-pkgs/pkg-test1" =exit> 1
=exit> 1 =stderr> #rx"overlap"
=stderr> #rx"overlap" $ (~a "raco pkg install " (find-collects-dir))
$ (~a "raco pkg install " (find-collects-dir)) =exit> 1
=exit> 1 =stderr> #rx"overlap.*collection"
=stderr> #rx"overlap.*collection" $ (~a "raco pkg install " (collection-path "tests"))
$ (~a "raco pkg install " (collection-path "tests")) =exit> 1
=exit> 1 =stderr> #rx"overlap.*package")
=stderr> #rx"overlap.*package"))
(define tmp-dir (path->directory-path (make-temporary-file "pkg~a" 'directory))) (define tmp-dir (path->directory-path (make-temporary-file "pkg~a" 'directory)))
$ (~a "cp -r test-pkgs/pkg-test1 "tmp-dir"pkg-test1") $ (~a "cp -r test-pkgs/pkg-test1 "tmp-dir"pkg-test1")
@ -183,24 +165,23 @@
$ (~a "cp -r "tmp-dir"pkg-test1 "tmp-dir"pkg-test1-linking") $ (~a "cp -r "tmp-dir"pkg-test1 "tmp-dir"pkg-test1-linking")
$ (~a "cp -r test-pkgs/pkg-test1-staging "tmp-dir"pkg-test1-staging") $ (~a "cp -r test-pkgs/pkg-test1-staging "tmp-dir"pkg-test1-staging")
(parameterize ([current-directory test-source-directory]) (with-fake-root
(with-fake-root (shelly-case
(shelly-case "linking local directory"
"linking local directory" $ "racket -e '(require pkg-test1)'" =exit> 1
$ "racket -e '(require pkg-test1)'" =exit> 1 $ (~a "raco pkg install --link "tmp-dir"pkg-test1-linking")
$ (~a "raco pkg install --link "tmp-dir"pkg-test1-linking") $ "racket -e '(require pkg-test1)'"
$ "racket -e '(require pkg-test1)'" $ "racket -e '(require pkg-test1/a)'" =exit> 1
$ "racket -e '(require pkg-test1/a)'" =exit> 1 $ (~a "racket -e '(require pkg/lib)' -e '(path->pkg \""tmp-dir"pkg-test1-linking\")'") =stdout> "\"pkg-test1-linking\"\n"
$ (~a "racket -e '(require pkg/lib)' -e '(path->pkg \""tmp-dir"pkg-test1-linking\")'") =stdout> "\"pkg-test1-linking\"\n" $ (~a "racket -e '(require pkg/lib)' -e '(path->pkg \""tmp-dir"pkg-test1-linking/README\")'") =stdout> "\"pkg-test1-linking\"\n"
$ (~a "racket -e '(require pkg/lib)' -e '(path->pkg \""tmp-dir"pkg-test1-linking/README\")'") =stdout> "\"pkg-test1-linking\"\n" $ "racket -e '(require pkg/lib)' -e '(path->pkg \"test-pkgs\")'" =stdout> "\"racket-test\"\n"
$ "racket -e '(require pkg/lib)' -e '(path->pkg \"test-pkgs\")'" =stdout> "\"racket-test\"\n" $ "racket -e '(require pkg/lib)' -e '(path->pkg (collection-file-path \"main.rkt\" \"racket\"))'" =stdout> "#f\n"
$ "racket -e '(require pkg/lib)' -e '(path->pkg (collection-file-path \"main.rkt\" \"racket\"))'" =stdout> "#f\n" $ (~a "cp "tmp-dir"pkg-test1-staging/a.rkt "tmp-dir"pkg-test1-linking/pkg-test1/a.rkt")
$ (~a "cp "tmp-dir"pkg-test1-staging/a.rkt "tmp-dir"pkg-test1-linking/pkg-test1/a.rkt") $ "racket -e '(require pkg-test1/a)'"
$ "racket -e '(require pkg-test1/a)'" $ (~a "rm -f "tmp-dir"pkg-test1-linking/pkg-test1/a.rkt")
$ (~a "rm -f "tmp-dir"pkg-test1-linking/pkg-test1/a.rkt") $ "racket -e '(require pkg-test1/a)'" =exit> 1
$ "racket -e '(require pkg-test1/a)'" =exit> 1 $ "raco pkg remove pkg-test1-linking"
$ "raco pkg remove pkg-test1-linking" $ "racket -e '(require pkg-test1)'" =exit> 1))
$ "racket -e '(require pkg-test1)'" =exit> 1)))
$ (~a "cp -r "tmp-dir"pkg-test3 "tmp-dir"pkg-test3-linking") $ (~a "cp -r "tmp-dir"pkg-test3 "tmp-dir"pkg-test3-linking")

View File

@ -29,7 +29,5 @@
" (build-path (find-system-path 'addon-dir) (symbol->string 'other)))\"") " (build-path (find-system-path 'addon-dir) (symbol->string 'other)))\"")
$ "raco pkg remove -u --auto pkg-b" $ "raco pkg remove -u --auto pkg-b"
$ "raco pkg show -l -u -a" =stdout> " [none]\n" $ "raco pkg show -l -u -a" =stdout> " [none]\n"
$ "raco pkg migrate --dry-run -u other"
$ "raco pkg show -l -u -a" =stdout> " [none]\n"
$ "raco pkg migrate -u other" $ "raco pkg migrate -u other"
$ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9.]+ \\(catalog \"pkg-a\"\\)\npkg-b +[a-f0-9.]+ +\\(catalog \"pkg-b\"\\)\n"))) $ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-a\\* +[a-f0-9.]+ \\(catalog \"pkg-a\"\\)\npkg-b +[a-f0-9.]+ +\\(catalog \"pkg-b\"\\)\n")))

View File

@ -15,11 +15,11 @@
"promote" "promote"
$ "raco pkg config --set catalogs http://localhost:9990" $ "raco pkg config --set catalogs http://localhost:9990"
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0 $ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0
$ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test2.zip\"\\)\n" $ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\"\\)\n"
$ "raco pkg install test-pkgs/pkg-test2.zip" =exit> 1 =stderr> #rx"already installed" $ "raco pkg install test-pkgs/pkg-test2.zip" =exit> 1 =stderr> #rx"already installed"
$ "raco pkg install test-pkgs/pkg-test1.zip" =exit> 1 =stderr> #rx"already installed from a different source" $ "raco pkg install test-pkgs/pkg-test1.zip" =exit> 1 =stderr> #rx"already installed from a different source"
$ "raco pkg install pkg-test1" ; promote $ "raco pkg install pkg-test1" ; promote
$ "raco pkg show -l -u -a" =stdout> #rx"Package +Checksum +Source\npkg-test1 +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test2.zip\"\\)\n" $ "raco pkg show -l -u -a" =stdout> #rx"Package +Checksum +Source\npkg-test1 +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\"\\)\n"
$ "raco pkg install pkg-test1" =exit> 1 =stderr> #rx"already installed" ; redundant promote fails $ "raco pkg install pkg-test1" =exit> 1 =stderr> #rx"already installed" ; redundant promote fails
$ "racket -e '(require pkg-test1)'" =exit> 0 $ "racket -e '(require pkg-test1)'" =exit> 0
$ "racket -e '(require pkg-test2)'" =exit> 0 $ "racket -e '(require pkg-test2)'" =exit> 0
@ -32,9 +32,9 @@
"demote" "demote"
$ "raco pkg config --set catalogs http://localhost:9990" $ "raco pkg config --set catalogs http://localhost:9990"
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0 $ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0
$ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test2.zip\"\\)\n" $ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\"\\)\n"
$ "raco pkg remove --demote pkg-test2" $ "raco pkg remove --demote pkg-test2"
$ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2\\* +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test2.zip\"\\)\n" $ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2\\* +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\"\\)\n"
$ "racket -e '(require pkg-test1)'" =exit> 0 $ "racket -e '(require pkg-test1)'" =exit> 0
$ "racket -e '(require pkg-test2)'" =exit> 0 $ "racket -e '(require pkg-test2)'" =exit> 0
$ "raco pkg remove --auto" $ "raco pkg remove --auto"
@ -44,8 +44,8 @@
"demote+auto" "demote+auto"
$ "raco pkg config --set catalogs http://localhost:9990" $ "raco pkg config --set catalogs http://localhost:9990"
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0 $ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0
$ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test2.zip\"\\)\n" $ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\"\\)\n"
$ "raco pkg remove --demote --auto pkg-test1" =exit> 0 ; should have no effect $ "raco pkg remove --demote --auto pkg-test1" =exit> 0 ; should have no effect
$ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test2.zip\"\\)\n" $ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\"\\)\n"
$ "raco pkg remove --demote --auto pkg-test2" $ "raco pkg remove --demote --auto pkg-test2"
$ "raco pkg show -l -u -a" =stdout> " [none]\n")))) $ "raco pkg show -l -u -a" =stdout> " [none]\n"))))

View File

@ -21,8 +21,7 @@
"remove and show" "remove and show"
(shelly-case "remove of not installed package fails" (shelly-case "remove of not installed package fails"
$ "raco pkg show -l -u -a" =stdout> " [none]\n" $ "raco pkg show -l -u -a" =stdout> " [none]\n"
$ "raco pkg remove not-there" =exit> 1 $ "raco pkg remove not-there" =exit> 1)
$ "raco pkg remove --dry-run not-there" =exit> 1)
(shelly-case "remove of bad name" (shelly-case "remove of bad name"
$ "raco pkg remove bad/" =exit> 1 $ "raco pkg remove bad/" =exit> 1
=stderr> #rx"disallowed") =stderr> #rx"disallowed")
@ -36,21 +35,16 @@
"pkg-test1 pkg-test1") "pkg-test1 pkg-test1")
(shelly-install "remove of dep fails" (shelly-install "remove of dep fails"
"test-pkgs/pkg-test1.zip" "test-pkgs/pkg-test1.zip"
$ "raco pkg show -l -u -a" =stdout> #rx"Package +Checksum +Source\npkg-test1 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test1.zip\"\\)\n" $ "raco pkg show -l -u -a" =stdout> #rx"Package +Checksum +Source\npkg-test1 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\"\\)\n"
$ "raco pkg install test-pkgs/pkg-test2.zip" $ "raco pkg install test-pkgs/pkg-test2.zip"
$ "raco pkg show -l -u -a" =stdout> #rx"Package +Checksum +Source\npkg-test1 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test1.zip\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test2.zip\"\\)\n" $ "raco pkg show -l -u -a" =stdout> #rx"Package +Checksum +Source\npkg-test1 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\"\\)\n"
$ "raco pkg remove pkg-test1" =exit> 1 =stderr> #rx"pkg-test1 \\(required by: \\(pkg-test2\\)\\)" $ "raco pkg remove pkg-test1" =exit> 1 =stderr> #rx"pkg-test1 \\(required by: \\(pkg-test2\\)\\)"
$ "raco pkg remove --dry-run pkg-test1" =exit> 1 =stderr> #rx"pkg-test1 \\(required by: \\(pkg-test2\\)\\)"
$ "raco pkg remove --dry-run pkg-test2"
$ "raco pkg show -l -u -a" =stdout> #rx"Package +Checksum +Source\npkg-test1 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test1.zip\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test2.zip\"\\)\n"
$ "raco pkg remove pkg-test2" $ "raco pkg remove pkg-test2"
$ "raco pkg show -l -u -a" =stdout> #rx"Package +Checksum +Source\npkg-test1 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test1.zip\"\\)\n") $ "raco pkg show -l -u -a" =stdout> #rx"Package +Checksum +Source\npkg-test1 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test1.zip\"\\)\n")
(shelly-install "remove of dep can be forced" (shelly-install "remove of dep can be forced"
"test-pkgs/pkg-test1.zip" "test-pkgs/pkg-test1.zip"
$ "raco pkg install test-pkgs/pkg-test2.zip" $ "raco pkg install test-pkgs/pkg-test2.zip"
$ "racket -e '(require pkg-test2/contains-dep)'" =exit> 0 $ "racket -e '(require pkg-test2/contains-dep)'" =exit> 0
$ "raco pkg remove --dry-run --force pkg-test1"
$ "racket -e '(require pkg-test2/contains-dep)'" =exit> 0
$ "raco pkg remove --force pkg-test1" $ "raco pkg remove --force pkg-test1"
$ "racket -e '(require pkg-test2/contains-dep)'" =exit> 1 $ "racket -e '(require pkg-test2/contains-dep)'" =exit> 1
$ "raco pkg install test-pkgs/pkg-test1.zip" $ "raco pkg install test-pkgs/pkg-test1.zip"
@ -74,7 +68,7 @@
$ "racket -e '(require pkg-test1)'" =exit> 1 $ "racket -e '(require pkg-test1)'" =exit> 1
$ "racket -e '(require pkg-test2)'" =exit> 1 $ "racket -e '(require pkg-test2)'" =exit> 1
$ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0 $ "raco pkg install --deps search-auto test-pkgs/pkg-test2.zip" =exit> 0
$ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+/test-pkgs/pkg-test2.zip\"\\)\n" $ "raco pkg show -l -u -a" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source\npkg-test1\\* +[a-f0-9.]+ +\\(catalog \"pkg-test1\"\\)\npkg-test2 +[a-f0-9.]+ +\\(file .+tests/pkg/test-pkgs/pkg-test2.zip\"\\)\n"
$ "racket -e '(require pkg-test1)'" =exit> 0 $ "racket -e '(require pkg-test1)'" =exit> 0
$ "racket -e '(require pkg-test2)'" =exit> 0 $ "racket -e '(require pkg-test2)'" =exit> 0
$ "racket -e '(require pkg-test2/contains-dep)'" =exit> 0 $ "racket -e '(require pkg-test2/contains-dep)'" =exit> 0

View File

@ -45,8 +45,6 @@
"test-pkgs/pkg-test1.zip" "test-pkgs/pkg-test1.zip"
"pkg-test1" "pkg-test1"
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
$ "raco pkg update --dry-run test-pkgs/update-test/pkg-test1.zip"
$ "racket -e '(require pkg-test1/update)'" =exit> 42
$ "raco pkg update test-pkgs/update-test/pkg-test1.zip" $ "raco pkg update test-pkgs/update-test/pkg-test1.zip"
$ "racket -e '(require pkg-test1/update)'" =exit> 43) $ "racket -e '(require pkg-test1/update)'" =exit> 43)
(finally (finally
@ -54,8 +52,6 @@
(shelly-install "packages can be replaced with local packages (file + name)" (shelly-install "packages can be replaced with local packages (file + name)"
"test-pkgs/pkg-test1.zip" "test-pkgs/pkg-test1.zip"
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
$ "raco pkg update --dry-run --name pkg-test1 test-pkgs/pkg-test1-v2.zip"
$ "racket -e '(require pkg-test1/update)'" =exit> 42
$ "raco pkg update --name pkg-test1 test-pkgs/pkg-test1-v2.zip" $ "raco pkg update --name pkg-test1 test-pkgs/pkg-test1-v2.zip"
$ "racket -e '(require pkg-test1/update)'" =exit> 43) $ "racket -e '(require pkg-test1/update)'" =exit> 43)
(define tmp2-dir (path->directory-path (make-temporary-file "pkg~a" 'directory))) (define tmp2-dir (path->directory-path (make-temporary-file "pkg~a" 'directory)))
@ -64,8 +60,6 @@
(shelly-install "packages can be replaced with local packages (directory)" (shelly-install "packages can be replaced with local packages (directory)"
"test-pkgs/pkg-test1.zip" "test-pkgs/pkg-test1.zip"
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
$ (~a "raco pkg update --dry-run --name pkg-test1 "tmp2-dir"pkg-test1-v2")
$ "racket -e '(require pkg-test1/update)'" =exit> 42
$ (~a "raco pkg update --name pkg-test1 "tmp2-dir"pkg-test1-v2") $ (~a "raco pkg update --name pkg-test1 "tmp2-dir"pkg-test1-v2")
$ "racket -e '(require pkg-test1/update)'" =exit> 43) $ "racket -e '(require pkg-test1/update)'" =exit> 43)
(shelly-install "replacement checksum can be checked" (shelly-install "replacement checksum can be checked"
@ -74,8 +68,6 @@
(shelly-install "checksum can be supplied for local directory" (shelly-install "checksum can be supplied for local directory"
"test-pkgs/pkg-test1.zip" "test-pkgs/pkg-test1.zip"
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
$ (~a "raco pkg update --dry-run --name pkg-test1 --checksum abcdef "tmp2-dir"pkg-test1-v2")
$ "racket -e '(require pkg-test1/update)'" =exit> 42
$ (~a "raco pkg update --name pkg-test1 --checksum abcdef "tmp2-dir"pkg-test1-v2") $ (~a "raco pkg update --name pkg-test1 --checksum abcdef "tmp2-dir"pkg-test1-v2")
$ "racket -e '(require pkg-test1/update)'" =exit> 43 $ "racket -e '(require pkg-test1/update)'" =exit> 43
$ "raco pkg show" =stdout> #rx"abcdef" $ "raco pkg show" =stdout> #rx"abcdef"
@ -100,8 +92,6 @@
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
$ "cp -f test-pkgs/pkg-test1-v2.zip test-pkgs/update-test/pkg-test1.zip" $ "cp -f test-pkgs/pkg-test1-v2.zip test-pkgs/update-test/pkg-test1.zip"
$ "cp -f test-pkgs/pkg-test1-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test1-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM"
$ "raco pkg update --dry-run pkg-test1" =exit> 0
$ "racket -e '(require pkg-test1/update)'" =exit> 42
$ "raco pkg update pkg-test1" =exit> 0 $ "raco pkg update pkg-test1" =exit> 0
$ "racket -e '(require pkg-test1/update)'" =exit> 43) $ "racket -e '(require pkg-test1/update)'" =exit> 43)
(finally (finally
@ -115,12 +105,9 @@
(shelly-install* "remote packages can be updated, single-collection to multi-collection" (shelly-install* "remote packages can be updated, single-collection to multi-collection"
"test-pkgs/pkg-test1.zip http://localhost:9997/update-test/pkg-test3.zip" "test-pkgs/pkg-test1.zip http://localhost:9997/update-test/pkg-test3.zip"
"pkg-test1 pkg-test3" "pkg-test1 pkg-test3"
$ "racket -e '(require pkg-test3)'" =stdout> "pkg-test3/main loaded\n"
$ "raco pkg update pkg-test3" =exit> 0 =stdout> "Downloading checksum for pkg-test3\nNo updates available\n" $ "raco pkg update pkg-test3" =exit> 0 =stdout> "Downloading checksum for pkg-test3\nNo updates available\n"
$ "cp -f test-pkgs/pkg-test3-v2.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3-v2.zip test-pkgs/update-test/pkg-test3.zip"
$ "cp -f test-pkgs/pkg-test3-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test3-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
$ "raco pkg update --dry-run pkg-test3" =exit> 0
$ "racket -e '(require pkg-test3)'" =stdout> "pkg-test3/main loaded\n"
$ "raco pkg update pkg-test3" =exit> 0 $ "raco pkg update pkg-test3" =exit> 0
$ "racket -e '(require pkg-test3)'" =stdout> "pkg-test3/main version 2 loaded\n") $ "racket -e '(require pkg-test3)'" =stdout> "pkg-test3/main version 2 loaded\n")
(finally (finally
@ -131,15 +118,12 @@
$ "mkdir -p test-pkgs/update-test" $ "mkdir -p test-pkgs/update-test"
$ "cp -f test-pkgs/pkg-test3-v2.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3-v2.zip test-pkgs/update-test/pkg-test3.zip"
$ "cp -f test-pkgs/pkg-test3-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test3-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
(shelly-install* "remote packages can be updated, multi-collection to single-collection" (shelly-install* "remote packages can be updated, multi-colelction to single-collection"
"test-pkgs/pkg-test1.zip http://localhost:9997/update-test/pkg-test3.zip" "test-pkgs/pkg-test1.zip http://localhost:9997/update-test/pkg-test3.zip"
"pkg-test1 pkg-test3" "pkg-test1 pkg-test3"
$ "racket -e '(require pkg-test3)'" =stdout> "pkg-test3/main version 2 loaded\n"
$ "raco pkg update pkg-test3" =exit> 0 =stdout> "Downloading checksum for pkg-test3\nNo updates available\n" $ "raco pkg update pkg-test3" =exit> 0 =stdout> "Downloading checksum for pkg-test3\nNo updates available\n"
$ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip" $ "cp -f test-pkgs/pkg-test3.zip test-pkgs/update-test/pkg-test3.zip"
$ "cp -f test-pkgs/pkg-test3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test3.zip.CHECKSUM test-pkgs/update-test/pkg-test3.zip.CHECKSUM"
$ "raco pkg update --dry-run pkg-test3" =exit> 0
$ "racket -e '(require pkg-test3)'" =stdout> "pkg-test3/main version 2 loaded\n"
$ "raco pkg update pkg-test3" =exit> 0 $ "raco pkg update pkg-test3" =exit> 0
$ "racket -e '(require pkg-test3)'" =stdout> "pkg-test3/main loaded\n") $ "racket -e '(require pkg-test3)'" =stdout> "pkg-test3/main loaded\n")
(finally (finally
@ -161,8 +145,6 @@
$ "racket -e '(require pkg-test1/update)'" =exit> 42 $ "racket -e '(require pkg-test1/update)'" =exit> 42
$ "cp -f test-pkgs/pkg-test1-v2.zip test-pkgs/update-test/pkg-test1.zip" $ "cp -f test-pkgs/pkg-test1-v2.zip test-pkgs/update-test/pkg-test1.zip"
$ "cp -f test-pkgs/pkg-test1-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM" $ "cp -f test-pkgs/pkg-test1-v2.zip.CHECKSUM test-pkgs/update-test/pkg-test1.zip.CHECKSUM"
$ "raco pkg update --dry-run --update-deps pkg-test2" =exit> 0
$ "racket -e '(require pkg-test1/update)'" =exit> 42
$ "raco pkg update --update-deps pkg-test2" =exit> 0 $ "raco pkg update --update-deps pkg-test2" =exit> 0
$ "racket -e '(require pkg-test1/update)'" =exit> 43 $ "racket -e '(require pkg-test1/update)'" =exit> 43
$ "raco pkg remove pkg-test2") $ "raco pkg remove pkg-test2")

View File

@ -13,23 +13,7 @@
setup/dirs setup/dirs
"shelly.rkt") "shelly.rkt")
(define-runtime-path test-source-directory ".") (define-runtime-path test-directory ".")
;; Use a consistent directory, so that individual tests can be
;; run after "tests-create.rkt":
(define-runtime-path test-directory (build-path (find-system-path 'temp-dir)
"pkg-test-work"))
(define (sync-test-directory)
(printf "Syncing test directory\n")
(make-directory* test-directory)
(parameterize ([current-directory test-source-directory])
(for ([f (in-directory)])
(define src f)
(define dest (build-path test-directory f))
(cond
[(directory-exists? src) (make-directory* dest)]
[else (copy-file src dest #t)]))))
(define-syntax-rule (this-test-is-run-by-the-main-test) (define-syntax-rule (this-test-is-run-by-the-main-test)
(module test racket/base)) (module test racket/base))
@ -202,7 +186,6 @@
(shelly-case "setup info cache" $ "raco setup -nDKxiI --no-foreign-libs") (shelly-case "setup info cache" $ "raco setup -nDKxiI --no-foreign-libs")
(with-fake-root (with-fake-root
(parameterize ([current-directory test-directory]) (parameterize ([current-directory test-directory])
(sync-test-directory)
(t))))))) (t)))))))
(define-syntax-rule (shelly-install** message pkg rm-pkg (pre ...) (more ...)) (define-syntax-rule (shelly-install** message pkg rm-pkg (pre ...) (more ...))

View File

@ -787,8 +787,7 @@
'pos 'pos
'neg)) 'neg))
x) x)
'(body ctc) '(body ctc))
'(body ctc ctc)) ; result if contract is applied twice
(test/spec-passed/result (test/spec-passed/result
'->d-underscore3 '->d-underscore3
@ -798,8 +797,7 @@
'pos 'pos
'neg)) 'neg))
x) x)
'(ctc body) '(ctc body))
'(ctc ctc body)) ; result if contract is applied twice
(test/spec-passed/result (test/spec-passed/result
'->d-underscore4 '->d-underscore4

View File

@ -732,8 +732,7 @@
(quote neg)) (quote neg))
b) b)
(unbox b)) (unbox b))
'(5 4 3 2 1) '(5 4 3 2 1))
'(5 4 5 4 3 2 1 2 1)) ; result if contract is applied twice
(test/spec-passed/result (test/spec-passed/result
'->i44 '->i44
@ -857,8 +856,7 @@
'neg) 'neg)
1) 1)
x) x)
'(res-check res-eval body arg-eval) '(res-check res-eval body arg-eval))
'(res-check res-eval res-check res-eval body arg-eval arg-eval)) ; result if contract is applied twice
(test/spec-passed/result (test/spec-passed/result
'->i49 '->i49
@ -874,8 +872,7 @@
'neg) 'neg)
1) 1)
x) x)
'(res-check body res-eval arg-eval) '(res-check body res-eval arg-eval))
'(res-check res-check body res-eval res-eval arg-eval arg-eval)) ; result if contract is applied twice
(test/spec-passed/result (test/spec-passed/result
'->i50 '->i50
@ -891,8 +888,7 @@
'neg) 'neg)
1) 1)
x) x)
'(res-check body res-eval arg-eval) '(res-check body res-eval arg-eval))
'(res-check res-check body res-eval arg-eval res-eval arg-eval)) ; result if contract is applied twice
(test/spec-passed/result (test/spec-passed/result
'->i51 '->i51
@ -908,8 +904,7 @@
'neg) 'neg)
1) 1)
x) x)
'(res-check body res-eval arg-eval) '(res-check body res-eval arg-eval))
'(res-check res-check body res-eval arg-eval res-eval arg-eval)) ; result if contract is applied twice
(test/spec-passed/result (test/spec-passed/result
'->i52 '->i52
@ -929,14 +924,6 @@
3 2 1) 3 2 1)
3) 3)
(test/spec-passed/result
'->i54
'((contract (->i (#:one [one any/c] #:two [two any/c] #:three [three any/c]) any)
(λ (#:one one #:two two #:three three) (list one two three))
'pos 'neg)
#:one 1 #:two 2 #:three 3)
'(1 2 3))
(test/pos-blame (test/pos-blame
'->i-arity1 '->i-arity1
'(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg)) '(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg))
@ -1354,8 +1341,7 @@
'pos 'pos
'neg)) 'neg))
x) x)
'(body ctc) '(body ctc))
'(body ctc ctc)) ; result if contract is applied twice
(test/spec-passed/result (test/spec-passed/result
'->i-underscore3 '->i-underscore3
@ -1365,8 +1351,7 @@
'pos 'pos
'neg)) 'neg))
x) x)
'(body ctc) '(body ctc))
'(body ctc ctc)) ; result if contract is applied twice
(test/spec-passed/result (test/spec-passed/result
'->i-underscore4 '->i-underscore4
@ -1393,8 +1378,7 @@
'neg) 'neg)
11) 11)
x) x)
'(body ctc) '(body ctc))
'(body ctc ctc)) ; result if contract is applied twice
(test/pos-blame (test/pos-blame
'->i-bad-number-of-result-values1 '->i-bad-number-of-result-values1
@ -1440,22 +1424,4 @@
(λ (x y) x) (λ (x y) x)
'pos 'neg) 1 2) 'pos 'neg) 1 2)
"didn't raise an error") "didn't raise an error")
#t) #t))
(test/spec-passed/result
'shortcut-error-message
'(with-handlers ([exn:fail?
(λ (x) (define m
(regexp-match #rx"expected: ([^\n]*)\n"
(exn-message x)))
(if m
(list-ref m 1)
(format "ack regexp didn't match: ~s"
(exn-message x))))])
((contract (->i ([y () (and/c number? (>/c 1))]) any)
(λ (y) 1)
'pos 'neg)
1))
"(and/c number? (>/c 1))")
)

View File

@ -716,20 +716,4 @@
(test/spec-passed (test/spec-passed
'->*-opt-optional5 '->*-opt-optional5
'((contract (->* () integer? #:post #t) (lambda x 1) 'pos 'neg))) '((contract (->* () integer? #:post #t) (lambda x 1) 'pos 'neg))))
(test/pos-blame
'->*-opt-vs-mand1
'(contract (->* (integer?) (symbol? boolean?) number?)
(lambda (x y [z #t])
x)
'pos
'neg))
(test/pos-blame
'->*-opt-vs-mand2
'(contract (->* () (symbol? boolean?) symbol?)
(lambda (y [z #t])
y)
'pos
'neg))
)

View File

@ -262,12 +262,6 @@
'contract-arrow4 'contract-arrow4
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1)) '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1))
(test/pos-blame
'contract-arrow5
'(let ()
(struct s (x))
((contract (-> s? integer?) s-x 'pos 'neg) (s #f))))
(test/neg-blame (test/neg-blame
'contract-arrow-arity1 'contract-arrow-arity1
'((contract (-> number? number? number?) '((contract (-> number? number? number?)
@ -341,38 +335,6 @@
(eq? f (contract (-> any/c any) f 'pos 'neg))) (eq? f (contract (-> any/c any) f 'pos 'neg)))
#f) #f)
(test/spec-passed/result
'contract->...1
'((contract (-> integer? char? ... boolean? any)
(λ args args)
'pos 'neg)
1 #\a #\b #\c #f)
'(1 #\a #\b #\c #f))
(test/neg-blame
'contract->...2
'((contract (-> integer? char? ... boolean? any)
(λ args args)
'pos 'neg)
1 #\a "b" #\c #f))
(test/spec-passed/result
'contract->...3
'((contract (-> integer? ... any)
(λ args args)
'pos 'neg)
1 2 3 4 5 6 7)
'(1 2 3 4 5 6 7))
(test/neg-blame
'contract->...4
'((contract (-> integer? ... any)
(λ args args)
'pos 'neg)
1 2 3 4 #f 6 7))
(test/spec-passed
'contract->...5
'(contract (-> procedure? any/c ... list? any)
(λ (proc last . stuff) stuff)
'pos 'neg))
(test/spec-passed (test/spec-passed
'contract-arrow-all-kwds2 'contract-arrow-all-kwds2
@ -411,27 +373,6 @@
'something-else 'yet-another-thing) 'something-else 'yet-another-thing)
1))) 1)))
(test/spec-passed/result
'chaperone-procedure*-and-contract-interaction
'(let ()
(define (f1 x) x)
(define-values (prop:p prop:p? prop:get-p)
(make-impersonator-property 'p))
(define the-answer 'dont-know)
(define f2 (chaperone-procedure*
f1
(λ (f x)
(set! the-answer (and (prop:p? f) (prop:get-p f)))
x)))
(define f3 (contract (-> integer? integer?) f2 'pos 'neg))
(define f4 (chaperone-procedure f3 #f prop:p 1234))
(f4 1)
the-answer)
1234)
(test/pos-blame (test/pos-blame
'predicate/c1 'predicate/c1
'(contract predicate/c 1 'pos 'neg)) '(contract predicate/c 1 'pos 'neg))
@ -485,30 +426,6 @@
((impersonate-procedure s? (λ (x) (values (λ (r) "") x))) 11)) ((impersonate-procedure s? (λ (x) (values (λ (r) "") x))) 11))
'pos 'neg)) 'pos 'neg))
(test/spec-passed
'any/c-in-domain1
'((contract (-> any/c real?)
(λ (x) 0)
'pos 'neg) 0))
(test/pos-blame
'any/c-in-domain2
'((contract (-> any/c real?)
(λ (x) #f)
'pos 'neg) 0))
(test/spec-passed
'any/c-in-domain3
'((contract (-> any/c any/c any/c any/c real?)
(λ (x y z w) 0)
'pos 'neg) 0 1 2 3))
(test/pos-blame
'any/c-in-domain4
'((contract (-> any/c any/c any/c any/c real?)
(λ (x y z w) #f)
'pos 'neg) 0 1 2 3))
;; this test ensures that no contract wrappers ;; this test ensures that no contract wrappers
;; are created for struct predicates ;; are created for struct predicates
(test/spec-passed/result (test/spec-passed/result
@ -589,55 +506,4 @@
'neg)) 'neg))
(void))) (void)))
(test/spec-passed/result
'->-order-of-evaluation1
'(let ([l '()])
(-> (begin (set! l (cons 1 l)) #f)
(begin (set! l (cons 2 l)) #f)
(begin (set! l (cons 3 l)) #f)
(begin (set! l (cons 4 l)) #f)
(begin (set! l (cons 5 l)) #f))
(reverse l))
'(1 2 3 4 5))
(test/spec-passed/result
'->-order-of-evaluation2
'(let ([l '()])
(-> (begin (set! l (cons 1 l)) #f)
(begin (set! l (cons 2 l)) #f)
(begin (set! l (cons 3 l)) #f)
...
(begin (set! l (cons 4 l)) #f)
(begin (set! l (cons 5 l)) #f)
(begin (set! l (cons 6 l)) #f))
(reverse l))
'(1 2 3 4 5 6))
(contract-error-test
'->-arity-error1
'(contract
(-> any/c any/c)
(lambda (x y) #t)
'pos 'neg)
(lambda (e)
(regexp-match? "a procedure that accepts 1 non-keyword argument"
(exn-message e))))
(contract-error-test
'->-arity-error2
'(contract
(-> any/c)
(lambda (x y) #t)
'pos 'neg)
(lambda (e)
(regexp-match? "a procedure that accepts 0 non-keyword argument"
(exn-message e))))
(contract-error-test
'->-arity-error3
'(contract
(->* (any/c) (#:x any/c) any/c)
(lambda (x) #t)
'pos 'neg)
(lambda (e)
(regexp-match? "a procedure that accepts the #:x keyword argument"
(exn-message e))))
) )

View File

@ -283,16 +283,4 @@
(define-struct/contract thing ([stuff flat-blame-ok/c])) (define-struct/contract thing ([stuff flat-blame-ok/c]))
(thing-stuff (thing 5))))) (thing-stuff (thing 5)))))
(test/spec-passed/result
'suggest/c1
'(with-handlers ([exn:fail?
(λ (x)
(define m (regexp-match #rx"suggestion:[^\n]*\n"
(exn-message x)))
(and m (car m)))])
(contract (suggest/c zero? "suggestion" "try zero?")
1
'pos 'neg))
"suggestion: try zero?\n")
) )

View File

@ -2615,33 +2615,4 @@
(init-field [x 0])) (init-field [x 0]))
'pos 'neg)]) 'pos 'neg)])
(equal? (new c%) (new c%))) (equal? (new c%) (new c%)))
#f) #f))
(contract-error-test
'->m-arity-error-1
'(contract (->m string? string?)
(lambda (y) y)
'pos
'neg)
(lambda (e)
(regexp-match? "a method that accepts 1 non-keyword argument"
(exn-message e))))
(contract-error-test
'->m-arity-error-2
'(contract (->m string?)
(lambda () y)
'pos
'neg)
(lambda (e)
(regexp-match? "a method that accepts 0 non-keyword argument"
(exn-message e))))
(contract-error-test
'->m-arity-error3
'(contract (->*m (any/c) (#:x any/c) any/c)
(lambda (x y) #t)
'pos
'neg)
(lambda (e)
(regexp-match? "a method that accepts the #:x keyword argument"
(exn-message e))))
)

View File

@ -1069,19 +1069,6 @@
(eval '(dynamic-require ''provide/contract55-m2 'a))) (eval '(dynamic-require ''provide/contract55-m2 'a)))
'5) '5)
(test/spec-failed
'provide/contract56
'(let ()
(eval '(module provide/contract56-m1 racket/base
(require racket/contract/base)
(provide
(contract-out
[f (-> integer? integer?)]))
(define f 1)))
(eval '(dynamic-require ''provide/contract56-m1 #f)))
"provide/contract56-m1")
(contract-error-test (contract-error-test
'contract-error-test8 'contract-error-test8
#'(begin #'(begin

View File

@ -27,8 +27,7 @@
'pos 'pos
'neg) 'neg)
(λ (x) x))) (λ (x) x)))
11 11)
do-not-double-wrap)
(test/pos-blame (test/pos-blame
'∀1 '∀1
@ -53,5 +52,4 @@
'pos 'pos
'neg) 'neg)
11)) 11))
11 11))
do-not-double-wrap))

View File

@ -58,12 +58,6 @@
(ctest #t contract-first-order-passes? (non-empty-listof integer?) (list 1)) (ctest #t contract-first-order-passes? (non-empty-listof integer?) (list 1))
(ctest #f contract-first-order-passes? (non-empty-listof integer?) (list)) (ctest #f contract-first-order-passes? (non-empty-listof integer?) (list))
(ctest #t contract-first-order-passes? (*list/c integer? boolean? char?) '(1 2 3 4 #f #\a))
(ctest #t contract-first-order-passes? (*list/c integer? boolean? char?) '(#f #\a))
(ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) '(1 2 #f 4 #f #\a))
(ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) '())
(ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) '(#f))
(ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) 1)
(ctest #t contract-first-order-passes? (ctest #t contract-first-order-passes?
(vector-immutableof integer?) (vector-immutableof integer?)

View File

@ -1,6 +1,6 @@
#lang racket #lang racket
(require rackunit (require rackunit
racket/contract/private/arrow-common racket/contract/private/arrow
(for-template racket/contract/private/arrow-val-first) (for-template racket/contract/private/arrow-val-first)
racket/contract/private/application-arity-checking racket/contract/private/application-arity-checking
@ -78,16 +78,8 @@
(valid-app-shapes '(2) '() '())) (valid-app-shapes '(2) '() '()))
(check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c integer?)) (check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c integer?))
(valid-app-shapes '(1) '(#:x) '())) (valid-app-shapes '(1) '(#:x) '()))
(check-equal? (->-valid-app-shapes #'(-> integer? (... ...) any)) (check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c #:y any/c integer?))
(valid-app-shapes 0 '() '())) (valid-app-shapes '(1) '(#:x #:y) '()))
(check-equal? (->-valid-app-shapes #'(-> integer? integer? (... ...) any))
(valid-app-shapes 1 '() '()))
(check-equal? (->-valid-app-shapes #'(-> integer? integer? (... ...) integer? any))
(valid-app-shapes 2 '() '()))
(check-equal? (->-valid-app-shapes #'(-> integer? integer? (... ...) integer? boolean? char? any))
(valid-app-shapes 4 '() '()))
(check-equal? (->-valid-app-shapes #'(-> integer? boolean? char? (... ...) integer? char? any))
(valid-app-shapes 4 '() '()))
(check-equal? (->*-valid-app-shapes #'(->* (integer? #:x any/c #:y any/c) integer?)) (check-equal? (->*-valid-app-shapes #'(->* (integer? #:x any/c #:y any/c) integer?))
(valid-app-shapes '(1) '(#:x #:y) '())) (valid-app-shapes '(1) '(#:x #:y) '()))
@ -105,6 +97,7 @@
(check-equal? (->*-valid-app-shapes #'(->i ([m any/c]) ([o any/c]) #:rest [r any/c] [r any/c])) (check-equal? (->*-valid-app-shapes #'(->i ([m any/c]) ([o any/c]) #:rest [r any/c] [r any/c]))
(valid-app-shapes '(1 2 . 3) '() '())) (valid-app-shapes '(1 2 . 3) '() '()))
(check-true (valid-argument-list? #'(f x) (valid-app-shapes '(1 2 . 3) '() '()))) (check-true (valid-argument-list? #'(f x) (valid-app-shapes '(1 2 . 3) '() '())))
(check-true (valid-argument-list? #'(f x y) (valid-app-shapes '(1 2 . 3) '() '()))) (check-true (valid-argument-list? #'(f x y) (valid-app-shapes '(1 2 . 3) '() '())))
(check-true (valid-argument-list? #'(f x y a b c d) (valid-app-shapes '(1 2 . 3) '() '()))) (check-true (valid-argument-list? #'(f x y a b c d) (valid-app-shapes '(1 2 . 3) '() '())))

View File

@ -57,16 +57,6 @@
'(list-contract? (list*of any/c)) '(list-contract? (list*of any/c))
#f) #f)
(test/spec-passed/result
'list-contract-10c
'(list-contract? (list*of any/c boolean?))
#f)
(test/spec-passed/result
'list-contract-10d
'(list-contract? (list*of any/c null?))
#t)
(test/spec-passed/result (test/spec-passed/result
'list-contract-11 'list-contract-11
'(list-contract? (non-empty-listof any/c)) '(list-contract? (non-empty-listof any/c))
@ -159,18 +149,6 @@
c)) c))
#t) #t)
(test/spec-passed/result
'list-contract-25
'(list-contract?
(*list/c integer? boolean? char?))
#t)
(test/spec-passed/result
'list-contract-26
'(list-contract?
(*list/c (-> integer? integer?) boolean? char?))
#t)
(test/pos-blame (test/pos-blame
'test-contract-25 'test-contract-25
'(contract (letrec ([c (recursive-contract (first-or/c (cons/c any/c c) empty?) '(contract (letrec ([c (recursive-contract (first-or/c (cons/c any/c c) empty?)

View File

@ -65,29 +65,6 @@
'imlistof5 'imlistof5
'(contract (list*of integer?) (cons #f #t) 'pos 'neg)) '(contract (list*of integer?) (cons #f #t) 'pos 'neg))
(test/spec-passed/result
'imlistof6
'(contract (list*of integer? char?) '(1 2 . #\3) 'pos 'neg)
'(1 2 . #\3))
(test/pos-blame
'imlistof7
'(contract (list*of integer? char?) '() 'pos 'neg))
(test/pos-blame
'imlistof8
'(contract (list*of integer? char?) #f 'pos 'neg))
(test/pos-blame
'imlistof9
'(contract (list*of integer? char?) (list 1 2) 'pos 'neg))
(test/pos-blame
'imlistof10
'(contract (list*of integer? char?) (cons #f #t) 'pos 'neg))
(test/spec-passed
'imlistof11
'(contract (list*of (-> integer? integer?)
(-> boolean? boolean? boolean?))
(cons (λ (x) x) (cons (λ (y) y) (λ (a b) a)))
'pos 'neg))
(test/pos-blame (test/pos-blame
'cons/dc1 'cons/dc1
'(contract (cons/dc [hd integer?] [tl (hd) integer?]) '(contract (cons/dc [hd integer?] [tl (hd) integer?])
@ -171,39 +148,4 @@
'(contract? (cons/dc [hd integer?] [tl (hd) integer?] #:impersonator)) '(contract? (cons/dc [hd integer?] [tl (hd) integer?] #:impersonator))
#t) #t)
(test/spec-passed/result
'*list/c1
'(contract (*list/c integer? char? boolean?) '(1 2 3 #\a #f) 'pos 'neg)
'(1 2 3 #\a #f))
(test/pos-blame
'*list/c2
'(contract (*list/c integer? char? boolean?) '(1 2 #\a #\a #f) 'pos 'neg))
(test/spec-passed/result
'*list/c3
'((car (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
(list (λ (x) x) (λ (y) y)) 'pos 'neg))
1)
1)
(test/neg-blame
'*list/c4
'((car (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
(list (λ (x) x) (λ (y) y)) 'pos 'neg))
#f))
(test/spec-passed/result
'*list/c5
'((cadr (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
(list (λ (x) x) (λ (y) y)) 'pos 'neg))
#f)
#f)
(test/neg-blame
'*list/c6
'((cadr (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
(list (λ (x) x) (λ (y) y)) 'pos 'neg))
1))
(test/pos-blame
'*list/c7
'((caddr (contract (*list/c (-> integer? integer?) (-> boolean? boolean?) (-> char? char?))
(list (λ (x) x) (λ (y) y) (λ (y) 'not-a-bool) (λ (y) y)) 'pos 'neg))
#f))
) )

View File

@ -29,8 +29,7 @@
(test/spec-passed/result (test/spec-passed/result
'make-contract-1 'make-contract-1
'((contract proj:add1->sub1 sqrt 'pos 'neg) 15) '((contract proj:add1->sub1 sqrt 'pos 'neg) 15)
3 3)
do-not-double-wrap)
(test/pos-blame (test/pos-blame
'make-contract-2 'make-contract-2

Some files were not shown because too many files have changed in this diff Show More